lisp/ange-ftp.el

   1 ;;; ange-ftp.el --- transparent FTP support for GNU Emacs
   2
   3 ;;; Copyright (C) 1989,90,91,92,93,94,95  Free Software Foundation, Inc.
   4 ;;;
   5 ;; Author: Andy Norman (ange@hplb.hpl.hp.com)
   6 ;; Keywords: comm
   7 ;;;
   8 ;;; This program is free software; you can redistribute it and/or modify
   9 ;;; it under the terms of the GNU General Public License as published by
  10 ;;; the Free Software Foundation; either version 2, or (at your option)
  11 ;;; any later version.
  12 ;;;
  13 ;;; This program is distributed in the hope that it will be useful,
  14 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 ;;; GNU General Public License for more details.
  17 ;;;
  18 ;;; A copy of the GNU General Public License can be obtained from this
  19 ;;; program's author (send electronic mail to ange@hplb.hpl.hp.com) or from
  20 ;;; the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA
  21 ;;; 02139, USA.
  22
  23 ;;; Commentary:
  24 ;;;
  25 ;;; This package attempts to make accessing files and directories using FTP
  26 ;;; from within GNU Emacs as simple and transparent as possible.  A subset of
  27 ;;; the common file-handling routines are extended to interact with FTP.
  28
  29 ;;; Usage:
  30 ;;;
  31 ;;; Some of the common GNU Emacs file-handling operations have been made
  32 ;;; FTP-smart.  If one of these routines is given a filename that matches
  33 ;;; '/user@host:name' then it will spawn an FTP process connecting to machine
  34 ;;; 'host' as account 'user' and perform its operation on the file 'name'.
  35 ;;;
  36 ;;; For example: if find-file is given a filename of:
  37 ;;;
  38 ;;;   /ange@anorman:/tmp/notes
  39 ;;;
  40 ;;; then ange-ftp spawns an FTP process, connect to the host 'anorman' as
  41 ;;; user 'ange', get the file '/tmp/notes' and pop up a buffer containing the
  42 ;;; contents of that file as if it were on the local filesystem.  If ange-ftp
  43 ;;; needs a password to connect then it reads one in the echo area.
  44
  45 ;;; Extended filename syntax:
  46 ;;;
  47 ;;; The default extended filename syntax is '/user@host:name', where the
  48 ;;; 'user@' part may be omitted.  This syntax can be customised to a certain
  49 ;;; extent by changing ange-ftp-name-format.  There are limitations.
  50 ;;;
  51 ;;; If the user part is omitted then ange-ftp generates a default user
  52 ;;; instead whose value depends on the variable ange-ftp-default-user.
  53
  54 ;;; Passwords:
  55 ;;;
  56 ;;; A password is required for each host/user pair.  Ange-ftp reads passwords
  57 ;;; as needed.  You can also specify a password with ange-ftp-set-passwd, or
  58 ;;; in a *valid* ~/.netrc file.
  59
  60 ;;; Passwords for user "anonymous":
  61 ;;;
  62 ;;; Passwords for the user "anonymous" (or "ftp") are handled
  63 ;;; specially.  The variable `ange-ftp-generate-anonymous-password'
  64 ;;; controls what happens: if the value of this variable is a string,
  65 ;;; then this is used as the password; if non-nil (the default), then
  66 ;;; the value of `user-mail-address' is used; if nil then the user
  67 ;;; is prompted for a password as normal.
  68
  69 ;;; "Dumb" UNIX hosts:
  70 ;;;
  71 ;;; The FTP servers on some UNIX machines have problems if the 'ls' command is
  72 ;;; used.
  73 ;;;
  74 ;;; The routine ange-ftp-add-dumb-unix-host can be called to tell ange-ftp to
  75 ;;; limit itself to the DIR command and not 'ls' for a given UNIX host.  Note
  76 ;;; that this change will take effect for the current GNU Emacs session only.
  77 ;;; See below for a discussion of non-UNIX hosts.  If a large number of
  78 ;;; machines with similar hostnames have this problem then it is easier to set
  79 ;;; the value of ange-ftp-dumb-unix-host-regexp in your .emacs file. ange-ftp
  80 ;;; is unable to automatically recognize dumb unix hosts.
  81
  82 ;;; File name completion:
  83 ;;;
  84 ;;; Full file-name completion is supported on UNIX, VMS, CMS, and MTS hosts.
  85 ;;; To do filename completion, ange-ftp needs a listing from the remote host.
  86 ;;; Therefore, for very slow connections, it might not save any time.
  87
  88 ;;; FTP processes:
  89 ;;;
  90 ;;; When ange-ftp starts up an FTP process, it leaves it running for speed
  91 ;;; purposes.  Some FTP servers will close the connection after a period of
  92 ;;; time, but ange-ftp should be able to quietly reconnect the next time that
  93 ;;; the process is needed.
  94 ;;;
  95 ;;; Killing the "*ftp user@host*" buffer also kills the ftp process.
  96 ;;; This should not cause ange-ftp any grief.
  97
  98 ;;; Binary file transfers:
  99 ;;;
 100 ;;; By default ange-ftp transfers files in ASCII mode.  If a file being
 101 ;;; transferred matches the value of ange-ftp-binary-file-name-regexp then
 102 ;;; binary mode is used for that transfer.
 103
 104 ;;; Account passwords:
 105 ;;;
 106 ;;; Some FTP servers require an additional password which is sent by the
 107 ;;; ACCOUNT command.  ange-ftp partially supports this by allowing the user to
 108 ;;; specify an account password by either calling ange-ftp-set-account, or by
 109 ;;; specifying an account token in the .netrc file.  If the account password
 110 ;;; is set by either of these methods then ange-ftp will issue an ACCOUNT
 111 ;;; command upon starting the FTP process.
 112
 113 ;;; Preloading:
 114 ;;;
 115 ;;; ange-ftp can be preloaded, but must be put in the site-init.el file and
 116 ;;; not the site-load.el file in order for the documentation strings for the
 117 ;;; functions being overloaded to be available.
 118
 119 ;;; Status reports:
 120 ;;;
 121 ;;; Most ange-ftp commands that talk to the FTP process output a status
 122 ;;; message on what they are doing.  In addition, ange-ftp can take advantage
 123 ;;; of the FTP client's HASH command to display the status of transferring
 124 ;;; files and listing directories.  See the documentation for the variables
 125 ;;; ange-ftp-{ascii,binary}-hash-mark-size, ange-ftp-send-hash and
 126 ;;; ange-ftp-process-verbose for more details.
 127
 128 ;;; Gateways:
 129 ;;;
 130 ;;; Sometimes it is necessary for the FTP process to be run on a different
 131 ;;; machine than the machine running GNU Emacs.  This can happen when the
 132 ;;; local machine has restrictions on what hosts it can access.
 133 ;;;
 134 ;;; ange-ftp has support for running the ftp process on a different (gateway)
 135 ;;; machine.  The way it works is as follows:
 136 ;;;
 137 ;;; 1) Set the variable 'ange-ftp-gateway-host' to the name of a machine
 138 ;;;    that doesn't have the access restrictions.
 139 ;;;
 140 ;;; 2) Set the variable 'ange-ftp-local-host-regexp' to a regular expression
 141 ;;;    that matches hosts that can be contacted from running a local ftp
 142 ;;;    process, but fails to match hosts that can't be accessed locally.  For
 143 ;;;    example:
 144 ;;;
 145 ;;;    "\\.hp\\.com$\\|^[^.]*$"
 146 ;;;
 147 ;;;    will match all hosts that are in the .hp.com domain, or don't have an
 148 ;;;    explicit domain in their name, but will fail to match hosts with
 149 ;;;    explicit domains or that are specified by their ip address.
 150 ;;;
 151 ;;; 3) Using NFS and symlinks, make sure that there is a shared directory with
 152 ;;;    the *same* name between the local machine and the gateway machine.
 153 ;;;    This directory is necessary for temporary files created by ange-ftp.
 154 ;;;
 155 ;;; 4) Set the variable 'ange-ftp-gateway-tmp-name-template' to the name of
 156 ;;;    this directory plus an identifying filename prefix.  For example:
 157 ;;;
 158 ;;;    "/nfs/hplose/ange/ange-ftp"
 159 ;;;
 160 ;;;    where /nfs/hplose/ange is a directory that is shared between the
 161 ;;;    gateway machine and the local machine.
 162 ;;;
 163 ;;; The simplest way of getting a ftp process running on the gateway machine
 164 ;;; is if you can spawn a remote shell using either 'rsh' or 'remsh'.  If you
 165 ;;; can't do this for some reason such as security then points 7 onwards will
 166 ;;; discuss an alternative approach.
 167 ;;;
 168 ;;; 5) Set the variable ange-ftp-gateway-program to the name of the remote
 169 ;;;    shell process such as 'remsh' or 'rsh' if the default isn't correct.
 170 ;;;
 171 ;;; 6) Set the variable ange-ftp-gateway-program-interactive to nil if it
 172 ;;;    isn't already.  This tells ange-ftp that you are using a remote shell
 173 ;;;    rather than logging in using telnet or rlogin.
 174 ;;;
 175 ;;; That should be all you need to allow ange-ftp to spawn a ftp process on
 176 ;;; the gateway machine.  If you have to use telnet or rlogin to get to the
 177 ;;; gateway machine then follow the instructions below.
 178 ;;;
 179 ;;; 7) Set the variable ange-ftp-gateway-program to the name of the program
 180 ;;;    that lets you log onto the gateway machine.  This may be something like
 181 ;;;    telnet or rlogin.
 182 ;;;
 183 ;;; 8) Set the variable ange-ftp-gateway-prompt-pattern to a regular
 184 ;;;    expression that matches the prompt you get when you login to the
 185 ;;;    gateway machine.  Be very specific here; this regexp must not match
 186 ;;;    *anything* in your login banner except this prompt.
 187 ;;;    shell-prompt-pattern is far too general as it appears to match some
 188 ;;;    login banners from Sun machines.  For example:
 189 ;;;
 190 ;;;    "^$*$ *"
 191 ;;;
 192 ;;; 9) Set the variable ange-ftp-gateway-program-interactive to 't' to let
 193 ;;;    ange-ftp know that it has to "hand-hold" the login to the gateway
 194 ;;;    machine.
 195 ;;;
 196 ;;; 10) Set the variable ange-ftp-gateway-setup-term-command to a UNIX command
 197 ;;;     that will put the pty connected to the gateway machine into a
 198 ;;;     no-echoing mode, and will strip off carriage-returns from output from
 199 ;;;     the gateway machine.  For example:
 200 ;;;
 201 ;;;     "stty -onlcr -echo"
 202 ;;;
 203 ;;;     will work on HP-UX machines, whereas:
 204 ;;;
 205 ;;;     "stty -echo nl"
 206 ;;;
 207 ;;;     appears to work for some Sun machines.
 208 ;;;
 209 ;;; That's all there is to it.
 210
 211 ;;; Smart gateways:
 212 ;;;
 213 ;;; If you have a "smart" ftp program that allows you to issue commands like
 214 ;;; "USER foo@bar" which do nice proxy things, then look at the variables
 215 ;;; ange-ftp-smart-gateway and ange-ftp-smart-gateway-port.
 216 ;;;
 217 ;;; Otherwise, if there is an alternate ftp program that implements proxy in
 218 ;;; a transparent way (i.e. w/o specifying the proxy host), that will
 219 ;;; connect you directly to the desired destination host:
 220 ;;; Set ange-ftp-gateway-ftp-program-name to that program's name.
 221 ;;; Set ange-ftp-local-host-regexp to a value as stated earlier on.
 222 ;;; Leave ange-ftp-gateway-host set to nil.
 223 ;;; Set ange-ftp-smart-gateway to t.
 224
 225 ;;; Tips for using ange-ftp:
 226 ;;;
 227 ;;; 1. For dired to work on a host which marks symlinks with a trailing @ in
 228 ;;;    an ls -alF listing, you need to (setq dired-ls-F-marks-symlinks t).
 229 ;;;    Most UNIX systems do not do this, but ULTRIX does. If you think that
 230 ;;;    there is a chance you might connect to an ULTRIX machine (such as
 231 ;;;    prep.ai.mit.edu), then set this variable accordingly.  This will have
 232 ;;;    the side effect that dired will have problems with symlinks whose names
 233 ;;;    end in an @.  If you get yourself into this situation then editing
 234 ;;;    dired's ls-switches to remove "F", will temporarily fix things.
 235 ;;;
 236 ;;; 2. If you know that you are connecting to a certain non-UNIX machine
 237 ;;;    frequently, and ange-ftp seems to be unable to guess its host-type,
 238 ;;;    then setting the appropriate host-type regexp
 239 ;;;    (ange-ftp-vms-host-regexp, ange-ftp-mts-host-regexp, or
 240 ;;;    ange-ftp-cms-host-regexp) accordingly should help. Also, please report
 241 ;;;    ange-ftp's inability to recognize the host-type as a bug.
 242 ;;;
 243 ;;; 3. For slow connections, you might get "listing unreadable" error
 244 ;;;    messages, or get an empty buffer for a file that you know has something
 245 ;;;    in it. The solution is to increase the value of ange-ftp-retry-time.
 246 ;;;    Its default value is 5 which is plenty for reasonable connections.
 247 ;;;    However, for some transatlantic connections I set this to 20.
 248 ;;;
 249 ;;; 4. Beware of compressing files on non-UNIX hosts. Ange-ftp will do it by
 250 ;;;    copying the file to the local machine, compressing it there, and then
 251 ;;;    sending it back. Binary file transfers between machines of different
 252 ;;;    architectures can be a risky business. Test things out first on some
 253 ;;;    test files. See "Bugs" below. Also, note that ange-ftp copies files by
 254 ;;;    moving them through the local machine. Again, be careful when doing
 255 ;;;    this with binary files on non-Unix machines.
 256 ;;;
 257 ;;; 5. Beware that dired over ftp will use your setting of dired-no-confirm
 258 ;;;    (list of dired commands for which confirmation is not asked).  You
 259 ;;;    might want to reconsider your setting of this variable, because you
 260 ;;;    might want confirmation for more commands on remote direds than on
 261 ;;;    local direds. For example, I strongly recommend that you not include
 262 ;;;    compress and uncompress in this list. If there is enough demand it
 263 ;;;    might be a good idea to have an alist ange-ftp-dired-no-confirm of
 264 ;;;    pairs ( TYPE . LIST ), where TYPE is an operating system type and LIST
 265 ;;;    is a list of commands for which confirmation would be suppressed.  Then
 266 ;;;    remote dired listings would take their (buffer-local) value of
 267 ;;;    dired-no-confirm from this alist. Who votes for this?
 268
 269 ;;; ---------------------------------------------------------------------
 270 ;;; Non-UNIX support:
 271 ;;; ---------------------------------------------------------------------
 272
 273 ;;; VMS support:
 274 ;;;
 275 ;;; Ange-ftp has full support for VMS hosts.  It
 276 ;;; should be able to automatically recognize any VMS machine. However, if it
 277 ;;; fails to do this, you can use the command ange-ftp-add-vms-host.  As well,
 278 ;;; you can set the variable ange-ftp-vms-host-regexp in your .emacs file. We
 279 ;;; would be grateful if you would report any failures to automatically
 280 ;;; recognize a VMS host as a bug.
 281 ;;;
 282 ;;; Filename Syntax:
 283 ;;;
 284 ;;; For ease of *implementation*, the user enters the VMS filename syntax in a
 285 ;;; UNIX-y way.  For example:
 286 ;;;  PUB$:[ANONYMOUS.SDSCPUB.NEXT]README.TXT;1
 287 ;;; would be entered as:
 288 ;;;  /PUB$$:/ANONYMOUS/SDSCPUB/NEXT/README.TXT;1
 289 ;;; i.e. to log in as anonymous on ymir.claremont.edu and grab the file:
 290 ;;;  [.CSV.POLICY]RULES.MEM
 291 ;;; you would type:
 292 ;;;  C-x C-f /anonymous@ymir.claremont.edu:CSV/POLICY/RULES.MEM
 293 ;;;
 294 ;;; A legal VMS filename is of the form: FILE.TYPE;##
 295 ;;; where FILE can be up to 39 characters
 296 ;;;       TYPE can be up to 39 characters
 297 ;;;       ## is a version number (an integer between 1 and 32,767)
 298 ;;; Valid characters in FILE and TYPE are A-Z 0-9 _ - $
 299 ;;; $ cannot begin a filename, and - cannot be used as the first or last
 300 ;;; character.
 301 ;;;
 302 ;;; Tips:
 303 ;;; 1. Although VMS is not case sensitive, EMACS running under UNIX is.
 304 ;;;    Therefore, to access a VMS file, you must enter the filename with upper
 305 ;;;    case letters.
 306 ;;; 2. To access the latest version of file under VMS, you use the filename
 307 ;;;    without the ";" and version number. You should always edit the latest
 308 ;;;    version of a file. If you want to edit an earlier version, copy it to a
 309 ;;;    new file first. This has nothing to do with ange-ftp, but is simply
 310 ;;;    good VMS operating practice. Therefore, to edit FILE.TXT;3 (say 3 is
 311 ;;;    latest version), do C-x C-f /ymir.claremont.edu:FILE.TXT. If you
 312 ;;;    inadvertently do C-x C-f /ymir.claremont.edu:FILE.TXT;3, you will find
 313 ;;;    that VMS will not allow you to save the file because it will refuse to
 314 ;;;    overwrite FILE.TXT;3, but instead will want to create FILE.TXT;4, and
 315 ;;;    attach the buffer to this file. To get out of this situation, M-x
 316 ;;;    write-file /ymir.claremont.edu:FILE.TXT will attach the buffer to
 317 ;;;    latest version of the file. For this reason, in dired "f"
 318 ;;;    (dired-find-file), always loads the file sans version, whereas "v",
 319 ;;;    (dired-view-file), always loads the explicit version number. The
 320 ;;;    reasoning being that it reasonable to view old versions of a file, but
 321 ;;;    not to edit them.
 322 ;;; 3. EMACS has a feature in which it does environment variable substitution
 323 ;;;    in filenames. Therefore, to enter a $ in a filename, you must quote it
 324 ;;;    by typing $$.
 325
 326 ;;; MTS support:
 327 ;;;
 328 ;;; Ange-ftp has full support for hosts running
 329 ;;; the Michigan terminal system.  It should be able to automatically
 330 ;;; recognize any MTS machine. However, if it fails to do this, you can use
 331 ;;; the command ange-ftp-add-mts-host.  As well, you can set the variable
 332 ;;; ange-ftp-mts-host-regexp in your .emacs file. We would be grateful if you
 333 ;;; would report any failures to automatically recognize a MTS host as a bug.
 334 ;;;
 335 ;;; Filename syntax:
 336 ;;;
 337 ;;; MTS filenames are entered in a UNIX-y way. For example, if your account
 338 ;;; was YYYY, the file FILE in the account XXXX: on mtsg.ubc.ca would be
 339 ;;; entered as
 340 ;;;   /YYYY@mtsg.ubc.ca:/XXXX:/FILE
 341 ;;; In other words, MTS accounts are treated as UNIX directories. Of course,
 342 ;;; to access a file in another account, you must have access permission for
 343 ;;; it.  If FILE were in your own account, then you could enter it in a
 344 ;;; relative name fashion as
 345 ;;;   /YYYY@mtsg.ubc.ca:FILE
 346 ;;; MTS filenames can be up to 12 characters. Like UNIX, the structure of the
 347 ;;; filename does not contain a TYPE (i.e. it can have as many "."'s as you
 348 ;;; like.) MTS filenames are always in upper case, and hence be sure to enter
 349 ;;; them as such! MTS is not case sensitive, but an EMACS running under UNIX
 350 ;;; is.
 351
 352 ;;; CMS support:
 353 ;;;
 354 ;;; Ange-ftp has full support for hosts running
 355 ;;; CMS.  It should be able to automatically recognize any CMS machine.
 356 ;;; However, if it fails to do this, you can use the command
 357 ;;; ange-ftp-add-cms-host.  As well, you can set the variable
 358 ;;; ange-ftp-cms-host-regexp in your .emacs file. We would be grateful if you
 359 ;;; would report any failures to automatically recognize a CMS host as a bug.
 360 ;;;
 361 ;;; Filename syntax:
 362 ;;;
 363 ;;; CMS filenames are entered in a UNIX-y way. In otherwords, minidisks are
 364 ;;; treated as UNIX directories. For example to access the file READ.ME in
 365 ;;; minidisk *.311 on cuvmb.cc.columbia.edu, you would enter
 366 ;;;   /anonymous@cuvmb.cc.columbia.edu:/*.311/READ.ME
 367 ;;; If *.301 is the default minidisk for this account, you could access
 368 ;;; FOO.BAR on this minidisk as
 369 ;;;   /anonymous@cuvmb.cc.columbia.edu:FOO.BAR
 370 ;;; CMS filenames are of the form FILE.TYPE, where both FILE and TYPE can be
 371 ;;; up to 8 characters. Again, beware that CMS filenames are always upper
 372 ;;; case, and hence must be entered as such.
 373 ;;;
 374 ;;; Tips:
 375 ;;; 1. CMS machines, with the exception of anonymous accounts, nearly always
 376 ;;;    need an account password. To have ange-ftp send an account password,
 377 ;;;    you can either include it in your .netrc file, or use
 378 ;;;    ange-ftp-set-account.
 379 ;;; 2. Ange-ftp cannot send "write passwords" for a minidisk. Hopefully, we
 380 ;;;    can fix this.
 381 ;;;
 382 ;;; ------------------------------------------------------------------
 383 ;;; Bugs:
 384 ;;; ------------------------------------------------------------------
 385 ;;;
 386 ;;; 1. Umask problems:
 387 ;;;    Be warned that files created by using ange-ftp will take account of the
 388 ;;;    umask of the ftp daemon process rather than the umask of the creating
 389 ;;;    user.  This is particularly important when logging in as the root user.
 390 ;;;    The way that I tighten up the ftp daemon's umask under HP-UX is to make
 391 ;;;    sure that the umask is changed to 027 before I spawn /etc/inetd.  I
 392 ;;;    suspect that there is something similar on other systems.
 393 ;;;
 394 ;;; 2. Some combinations of FTP clients and servers break and get out of sync
 395 ;;;    when asked to list a non-existent directory.  Some of the ai.mit.edu
 396 ;;;    machines cause this problem for some FTP clients. Using
 397 ;;;    ange-ftp-kill-ftp-process can restart the ftp process, which
 398 ;;;    should get things back in synch.
 399 ;;;
 400 ;;; 3. Ange-ftp does not check to make sure that when creating a new file,
 401 ;;;    you provide a valid filename for the remote operating system.
 402 ;;;    If you do not, then the remote FTP server will most likely
 403 ;;;    translate your filename in some way. This may cause ange-ftp to
 404 ;;;    get confused about what exactly is the name of the file. The
 405 ;;;    most common causes of this are using lower case filenames on systems
 406 ;;;    which support only upper case, and using filenames which are too
 407 ;;;    long.
 408 ;;;
 409 ;;; 4. Null (blank) passwords confuse both ange-ftp and some FTP daemons.
 410 ;;;
 411 ;;; 5. Ange-ftp likes to use pty's to talk to its FTP processes.  If GNU Emacs
 412 ;;;    for some reason creates a FTP process that only talks via pipes then
 413 ;;;    ange-ftp won't be getting the information it requires at the time that
 414 ;;;    it wants it since pipes flush at different times to pty's.  One
 415 ;;;    disgusting way around this problem is to talk to the FTP process via
 416 ;;;    rlogin which does the 'right' things with pty's.
 417 ;;;
 418 ;;; 6. For CMS support, we send too many cd's. Since cd's are cheap, I haven't
 419 ;;;    worried about this too much. Eventually, we should have some caching
 420 ;;;    of the current minidisk.
 421 ;;;
 422 ;;; 7. Some CMS machines do not assign a default minidisk when you ftp them as
 423 ;;;    anonymous. It is then necessary to guess a valid minidisk name, and cd
 424 ;;;    to it. This is (understandably) beyond ange-ftp.
 425 ;;;
 426 ;;; 8. Remote to remote copying of files on non-Unix machines can be risky.
 427 ;;;    Depending on the variable ange-ftp-binary-file-name-regexp, ange-ftp
 428 ;;;    will use binary mode for the copy. Between systems of different
 429 ;;;    architecture, this still may not be enough to guarantee the integrity
 430 ;;;    of binary files. Binary file transfers from VMS machines are
 431 ;;;    particularly problematical. Should ange-ftp-binary-file-name-regexp be
 432 ;;;    an alist of OS type, regexp pairs?
 433 ;;;
 434 ;;; 9. The code to do compression of files over ftp is not as careful as it
 435 ;;;    should be. It deletes the old remote version of the file, before
 436 ;;;    actually checking if the local to remote transfer of the compressed
 437 ;;;    file succeeds. Of course to delete the original version of the file
 438 ;;;    after transferring the compressed version back is also dangerous,
 439 ;;;    because some OS's have severe restrictions on the length of filenames,
 440 ;;;    and when the compressed version is copied back the "-Z" or ".Z" may be
 441 ;;;    truncated. Then, ange-ftp would delete the only remaining version of
 442 ;;;    the file.  Maybe ange-ftp should make backups when it compresses files
 443 ;;;    (of course, the backup "~" could also be truncated off, sigh...).
 444 ;;;    Suggestions?
 445 ;;;
 446
 447 ;;; 10. If a dir listing is attempted for an empty directory on (at least
 448 ;;;     some) VMS hosts, an ftp error is given. This is really an ftp bug, and
 449 ;;;     I don't know how to get ange-ftp work to around it.
 450 ;;;
 451 ;;; 11. Bombs on filenames that start with a space. Deals well with filenames
 452 ;;;     containing spaces, but beware that the remote ftpd may not like them
 453 ;;;     much.
 454 ;;;
 455 ;;; 12. The dired support for non-Unix-like systems does not currently work.
 456 ;;;     It needs to be reimplemented by modifying the parse-...-listing
 457 ;;;     functions to convert the directory listing to ls -l format.
 458 ;;;
 459 ;;; 13. The famous @ bug. As mentioned above in TIPS, ULTRIX marks symlinks
 460 ;;;     with a trailing @ in a ls -alF listing. In order to account for this
 461 ;;;     ange-ftp looks to chop trailing @'s off of symlink names when it is
 462 ;;;     parsing a listing with the F switch. This will cause ange-ftp to
 463 ;;;     incorrectly get the name of a symlink on a non-ULTRIX host if its name
 464 ;;;     ends in an @. ange-ftp will correct itself if you take F out of the
 465 ;;;     dired ls switches (C-u s will allow you to edit the switches). The
 466 ;;;     dired buffer will be automatically reverted, which will allow ange-ftp
 467 ;;;     to fix its files hashtable.  A cookie to anyone who can think of a
 468 ;;;     fast, sure-fire way to recognize ULTRIX over ftp.
 469
 470 ;;; If you find any bugs or problems with this package, PLEASE either e-mail
 471 ;;; the above author, or send a message to the ange-ftp-lovers mailing list
 472 ;;; below.  Ideas and constructive comments are especially welcome.
 473
 474 ;;; ange-ftp-lovers:
 475 ;;;
 476 ;;; ange-ftp has its own mailing list modestly called ange-ftp-lovers.  All
 477 ;;; users of ange-ftp are welcome to subscribe (see below) and to discuss
 478 ;;; aspects of ange-ftp.  New versions of ange-ftp are posted periodically to
 479 ;;; the mailing list.
 480 ;;;
 481 ;;; To [un]subscribe to ange-ftp-lovers, or to report mailer problems with the
 482 ;;; list, please mail one of the following addresses:
 483 ;;;
 484 ;;;     ange-ftp-lovers-request@anorman.hpl.hp.com
 485 ;;; or
 486 ;;;     ange-ftp-lovers-request%anorman.hpl.hp.com@hplb.hpl.hp.com
 487 ;;;
 488 ;;; Please don't forget the -request part.
 489 ;;;
 490 ;;; For mail to be posted directly to ange-ftp-lovers, send to one of the
 491 ;;; following addresses:
 492 ;;;
 493 ;;;     ange-ftp-lovers@anorman.hpl.hp.com
 494 ;;; or
 495 ;;;     ange-ftp-lovers%anorman.hpl.hp.com@hplb.hpl.hp.com
 496 ;;;
 497 ;;; Alternatively, there is a mailing list that only gets announcements of new
 498 ;;; ange-ftp releases.  This is called ange-ftp-lovers-announce, and can be
 499 ;;; subscribed to by e-mailing to the -request address as above.  Please make
 500 ;;; it clear in the request which mailing list you wish to join.
 501
 502 ;;; The latest version of ange-ftp can usually be obtained via anonymous ftp
 503 ;;; from:
 504 ;;;     alpha.gnu.ai.mit.edu:ange-ftp/ange-ftp.tar.Z
 505 ;;; or:
 506 ;;;     ugle.unit.no:/pub/gnu/emacs-lisp/ange-ftp.tar.Z
 507 ;;; or:
 508 ;;;   archive.cis.ohio-state.edu:pub/gnu/emacs/elisp-archive/packages/ange-ftp.tar.Z
 509
 510 ;;; The archives for ange-ftp-lovers can be found via anonymous ftp under:
 511 ;;;
 512 ;;;     ftp.reed.edu:pub/mailing-lists/ange-ftp/
 513 \f
 514 ;;; -----------------------------------------------------------
 515 ;;; Technical information on this package:
 516 ;;; -----------------------------------------------------------
 517
 518 ;;; ange-ftp works by putting a handler on file-name-handler-alist
 519 ;;; which is called by many primitives, and a few non-primitives,
 520 ;;; whenever they see a file name of the appropriate sort.
 521
 522 ;;; Checklist for adding non-UNIX support for TYPE
 523 ;;;
 524 ;;; The following functions may need TYPE versions:
 525 ;;; (not all functions will be needed for every OS)
 526 ;;;
 527 ;;; ange-ftp-fix-name-for-TYPE
 528 ;;; ange-ftp-fix-dir-name-for-TYPE
 529 ;;; ange-ftp-TYPE-host
 530 ;;; ange-ftp-TYPE-add-host
 531 ;;; ange-ftp-parse-TYPE-listing
 532 ;;; ange-ftp-TYPE-delete-file-entry
 533 ;;; ange-ftp-TYPE-add-file-entry
 534 ;;; ange-ftp-TYPE-file-name-as-directory
 535 ;;; ange-ftp-TYPE-make-compressed-filename
 536 ;;; ange-ftp-TYPE-file-name-sans-versions
 537 ;;;
 538 ;;; Variables:
 539 ;;;
 540 ;;; ange-ftp-TYPE-host-regexp
 541 ;;; May need to add TYPE to ange-ftp-dumb-host-types
 542 ;;;
 543 ;;; Check the following functions for OS dependent coding:
 544 ;;;
 545 ;;; ange-ftp-host-type
 546 ;;; ange-ftp-guess-host-type
 547 ;;; ange-ftp-allow-child-lookup
 548
 549 ;;; Host type conventions:
 550 ;;;
 551 ;;; The function ange-ftp-host-type and the variable ange-ftp-dired-host-type
 552 ;;; (mostly) follow the following conventions for remote host types.  At
 553 ;;; least, I think that future code should try to follow these conventions,
 554 ;;; and the current code should eventually be made compliant.
 555 ;;;
 556 ;;; nil = local host type, whatever that is (probably unix).
 557 ;;;       Think nil as in "not a remote host". This value is used by
 558 ;;;       ange-ftp-dired-host-type for local buffers.
 559 ;;;
 560 ;;; t = a remote host of unknown type. Think t is in true, it's remote.
 561 ;;;     Currently, 'unix is used as the default remote host type.
 562 ;;;     Maybe we should use t.
 563 ;;;
 564 ;;; 'type = a remote host of TYPE type.
 565 ;;;
 566 ;;; 'type:list = a remote host of TYPE type, using a specialized ftp listing
 567 ;;;              program called list. This is currently only used for Unix
 568 ;;;              dl (descriptive listings), when ange-ftp-dired-host-type
 569 ;;;              is set to 'unix:dl.
 570
 571 ;;; Bug report codes:
 572 ;;;
 573 ;;; Because of their naive faith in this code, there are certain situations
 574 ;;; which the writers of this program believe could never happen. However,
 575 ;;; being realists they have put calls to `error' in the program at these
 576 ;;; points. These errors provide a code, which is an integer, greater than 1.
 577 ;;; To aid debugging.  the error codes, and the functions in which they reside
 578 ;;; are listed below.
 579 ;;;
 580 ;;; 1: See ange-ftp-ls
 581 ;;;
 582 \f
 583 ;;; -----------------------------------------------------------
 584 ;;; Hall of fame:
 585 ;;; -----------------------------------------------------------
 586 ;;;
 587 ;;; Thanks to Roland McGrath for improving the filename syntax handling,
 588 ;;; for suggesting many enhancements and for numerous cleanups to the code.
 589 ;;;
 590 ;;; Thanks to Jamie Zawinski for bugfixes and for ideas such as gateways.
 591 ;;;
 592 ;;; Thanks to Ken Laprade for improved .netrc parsing, password reading, and
 593 ;;; dired / shell auto-loading.
 594 ;;;
 595 ;;; Thanks to Sebastian Kremer for dired support and for many ideas and
 596 ;;; bugfixes.
 597 ;;;
 598 ;;; Thanks to Joe Wells for bugfixes, the original non-UNIX system support,
 599 ;;; VOS support, and hostname completion.
 600 ;;;
 601 ;;; Thanks to Nakagawa Takayuki for many good ideas, filename-completion, help
 602 ;;; with file-name expansion, efficiency worries, stylistic concerns and many
 603 ;;; bugfixes.
 604 ;;;
 605 ;;; Thanks to Sandy Rutherford who re-wrote most of ange-ftp to support VMS,
 606 ;;; MTS, CMS and UNIX-dls.  Sandy also added dired-support for non-UNIX OS and
 607 ;;; auto-recognition of the host type.
 608 ;;;
 609 ;;; Thanks to Dave Smith who wrote the info file for ange-ftp.
 610 ;;;
 611 ;;; Finally, thanks to Keith Waclena, Mark D. Baushke, Terence Kelleher, Ping
 612 ;;; Zhou, Edward Vielmetti, Jack Repenning, Mike Balenger, Todd Kaufmann,
 613 ;;; Kjetil Svarstad, Tom Wurgler, Linus Tolke, Niko Makila, Carl Edman, Bill
 614 ;;; Trost, Dave Brennan, Dan Jacobson, Andy Scott, Steve Anderson, Sanjay
 615 ;;; Mathur, the folks on the ange-ftp-lovers mailing list and many others
 616 ;;; whose names I've forgotten who have helped to debug and fix problems with
 617 ;;; ange-ftp.el.
 618 \f
 619
 620 ;;; Code:
 621 (require 'comint)
 622
 623 ;;;; ------------------------------------------------------------
 624 ;;;; User customization variables.
 625 ;;;; ------------------------------------------------------------
 626
 627 (defvar ange-ftp-name-format
 628   '("^/\\(\\([^@/:]*\\)@\\)?\\([^@/:]*\\):\\(.*\\)" . (3 2 4))
 629   "*Format of a fully expanded remote file name.
 630 This is a list of the form \(REGEXP HOST USER NAME\),
 631 where REGEXP is a regular expression matching
 632 the full remote name, and HOST, USER, and NAME are the numbers of
 633 parenthesized expressions in REGEXP for the components (in that order).")
 634
 635 ;; ange-ftp-multi-skip-msgs should only match ###-, where ### is one of
 636 ;; the number codes corresponding to ange-ftp-good-msgs or ange-ftp-fatal-msgs.
 637 ;; Otherwise, ange-ftp will go into multi-skip mode, and never come out.
 638
 639 (defvar ange-ftp-multi-msgs
 640   "^220-\\|^230-\\|^226\\|^25.-\\|^221-\\|^200-\\|^331-\\|^4[25]1-\\|^530-"
 641   "*Regular expression matching the start of a multiline ftp reply.")
 642
 643 (defvar ange-ftp-good-msgs
 644   "^220 \\|^230 \\|^226 \\|^25. \\|^221 \\|^200 \\|^[Hh]ash mark"
 645   "*Regular expression matching ftp \"success\" messages.")
 646
 647 ;; CMS and the odd VMS machine say 200 Port rather than 200 PORT.
 648 ;; Also CMS machines use a multiline 550- reply to say that you
 649 ;; don't have write permission. ange-ftp gets into multi-line skip
 650 ;; mode and hangs. Have it ignore 550- instead. It will then barf
 651 ;; when it gets the 550 line, as it should.
 652
 653 (defvar ange-ftp-skip-msgs
 654   (concat "^200 \\(PORT\\|Port\\) \\|^331 \\|^150 \\|^350 \\|^[0-9]+ bytes \\|"
 655           "^Connected \\|^$\\|^Remote system\\|^Using\\|^ \\|Password:\\|"
 656           "^local:\\|^Trying\\|^125 \\|^550-\\|^221 .*oodbye")
 657   "*Regular expression matching ftp messages that can be ignored.")
 658
 659 (defvar ange-ftp-fatal-msgs
 660   (concat "^ftp: \\|^Not connected\\|^530 \\|^4[25]1 \\|rcmd: \\|"
 661           "^No control connection\\|unknown host\\|^lost connection")
 662   "*Regular expression matching ftp messages that indicate serious errors.
 663 These mean that the FTP process should (or already has) been killed.")
 664
 665 (defvar ange-ftp-gateway-fatal-msgs
 666   "No route to host\\|Connection closed\\|No such host\\|Login incorrect"
 667   "*Regular expression matching login failure messages from rlogin/telnet.")
 668
 669 (defvar ange-ftp-xfer-size-msgs
 670   "^150 .* connection for .* (\\([0-9]+\\) bytes)"
 671   "*Regular expression used to determine the number of bytes in a FTP transfer.")
 672
 673 (defvar ange-ftp-tmp-name-template "/tmp/ange-ftp"
 674   "*Template used to create temporary files.")
 675
 676 (defvar ange-ftp-gateway-tmp-name-template "/tmp/ange-ftp"
 677   "*Template used to create temporary files when ftp-ing through a gateway.
 678 Files starting with this prefix need to be accessible from BOTH the local
 679 machine and the gateway machine, and need to have the SAME name on both
 680 machines, that is, /tmp is probably NOT what you want, since that is rarely
 681 cross-mounted.")
 682
 683 (defvar ange-ftp-netrc-filename "~/.netrc"
 684   "*File in .netrc format to search for passwords.")
 685
 686 (defvar ange-ftp-disable-netrc-security-check nil
 687   "*If non-nil avoid checking permissions on the .netrc file.")
 688
 689 (defvar ange-ftp-default-user nil
 690   "*User name to use when none is specied in a file name.
 691 If nil, then the name under which the user is logged in is used.
 692 If non-nil but not a string, the user is prompted for the name.")
 693
 694 (defvar ange-ftp-default-password nil
 695   "*Password to use when the user is the same as ange-ftp-default-user.")
 696
 697 (defvar ange-ftp-default-account nil
 698   "*Account password to use when the user is the same as ange-ftp-default-user.")
 699
 700 (defvar ange-ftp-generate-anonymous-password t
 701   "*If t, use value of `user-mail-address' as password for anonymous ftp.
 702 If a string, then use that string as the password.
 703 If nil, prompt the user for a password.")
 704
 705 (defvar ange-ftp-dumb-unix-host-regexp nil
 706   "*If non-nil, regexp matching hosts on which `dir' command lists directory.")
 707
 708 (defvar ange-ftp-binary-file-name-regexp
 709   (concat "\\.[zZ]$\\|\\.lzh$\\|\\.arc$\\|\\.zip$\\|\\.zoo$\\|\\.tar$\\|"
 710           "\\.dvi$\\|\\.ps$\\|\\.elc$\\|TAGS$\\|\\.gif$\\|"
 711           "\\.EXE\\(;[0-9]+\\)?$\\|\\.[zZ]-part-..$\\|\\.gz$\\|"
 712           "\\.taz$\\|\\.tgz$")
 713   "*If a file matches this regexp then it is transferred in binary mode.")
 714
 715 (defvar ange-ftp-gateway-host nil
 716   "*Name of host to use as gateway machine when local FTP isn't possible.")
 717
 718 (defvar ange-ftp-local-host-regexp ".*"
 719   "*Regexp selecting hosts which can be reached directly with ftp.
 720 For other hosts the FTP process is started on \`ange-ftp-gateway-host\'
 721 instead, and/or reached via \`ange-ftp-gateway-ftp-program-name\'.")
 722
 723 (defvar ange-ftp-gateway-program-interactive nil
 724   "*If non-nil then the gateway program should  give a shell prompt.
 725 Both telnet and rlogin do something like this.")
 726
 727 (defvar ange-ftp-gateway-program remote-shell-program
 728   "*Name of program to spawn a shell on the gateway machine.
 729 Valid candidates are rsh (remsh on some systems), telnet and rlogin.  See
 730 also the gateway variable above.")
 731
 732 (defvar ange-ftp-gateway-prompt-pattern "^[^#$%>;\n]*[#$%>;] *"
 733   "*Regexp matching prompt after complete login sequence on gateway machine.
 734 A match for this means the shell is now awaiting input.  Make this regexp as
 735 strict as possible; it shouldn't match *anything* at all except the user's
 736 initial prompt.  The above string will fail under most SUN-3's since it
 737 matches the login banner.")
 738
 739 (defvar ange-ftp-gateway-setup-term-command
 740   (if (eq system-type 'hpux)
 741       "stty -onlcr -echo\n"
 742     "stty -echo nl\n")
 743   "*Set up terminal after logging in to the gateway machine.
 744 This command should stop the terminal from echoing each command, and
 745 arrange to strip out trailing ^M characters.")
 746
 747 (defvar ange-ftp-smart-gateway nil
 748   "*Non-nil means the ftp gateway and/or the gateway ftp program is smart.
 749 Don't bother telnetting, etc., already connected to desired host transparently,
 750 or just issue a user@host command in case \`ange-ftp-gateway-host\' is non-nil.")
 751
 752 (defvar ange-ftp-smart-gateway-port "21"
 753   "*Port on gateway machine to use when smart gateway is in operation.")
 754
 755 (defvar ange-ftp-send-hash t
 756   "*If non-nil, send the HASH command to the FTP client.")
 757
 758 (defvar ange-ftp-binary-hash-mark-size nil
 759   "*Default size, in bytes, between hash-marks when transferring a binary file.
 760 If NIL, this variable will be locally overridden if the FTP client outputs a
 761 suitable response to the HASH command.  If non-NIL then this value takes
 762 precedence over the local value.")
 763
 764 (defvar ange-ftp-ascii-hash-mark-size 1024
 765   "*Default size, in bytes, between hash-marks when transferring an ASCII file.
 766 This variable is buffer-local and will be locally overridden if the FTP client
 767 outputs a suitable response to the HASH command.")
 768
 769 (defvar ange-ftp-process-verbose t
 770   "*If non-NIL then be chatty about interaction with the FTP process.")
 771
 772 (defvar ange-ftp-ftp-program-name "ftp"
 773   "*Name of FTP program to run.")
 774
 775 (defvar ange-ftp-gateway-ftp-program-name "ftp"
 776   "*Name of FTP program to run when accessing non-local hosts.
 777 Some AT&T folks claim to use something called `pftp' here.")
 778
 779 (defvar ange-ftp-ftp-program-args '("-i" "-n" "-g" "-v")
 780   "*A list of arguments passed to the FTP program when started.")
 781
 782 (defvar ange-ftp-nslookup-program nil
 783   "*If non-NIL then a string naming nslookup program." )
 784
 785 (defvar ange-ftp-make-backup-files ()
 786   "*Non-nil means make backup files for \"magic\" remote files.")
 787
 788 (defvar ange-ftp-retry-time 5
 789   "*Number of seconds to wait before retry if file or listing doesn't arrive.
 790 This might need to be increased for very slow connections.")
 791
 792 (defvar ange-ftp-auto-save 0
 793   "If 1, allows ange-ftp files to be auto-saved.
 794 If 0, suppresses auto-saving of ange-ftp files.
 795 Don't use any other value.")
 796 \f
 797 ;;;; ------------------------------------------------------------
 798 ;;;; Hash table support.
 799 ;;;; ------------------------------------------------------------
 800
 801 (require 'backquote)
 802
 803 (defun ange-ftp-make-hashtable (&optional size)
 804   "Make an obarray suitable for use as a hashtable.
 805 SIZE, if supplied, should be a prime number."
 806   (make-vector (or size 31) 0))
 807
 808 (defun ange-ftp-map-hashtable (fun tbl)
 809   "Call FUNCTION on each key and value in HASHTABLE."
 810   (mapatoms
 811    (function
 812     (lambda (sym)
 813       (funcall fun (get sym 'key) (get sym 'val))))
 814    tbl))
 815
 816 (defmacro ange-ftp-make-hash-key (key)
 817   "Convert KEY into a suitable key for a hashtable."
 818   (` (if (stringp (, key))
 819          (, key)
 820        (prin1-to-string (, key)))))
 821
 822 (defun ange-ftp-get-hash-entry (key tbl)
 823   "Return the value associated with KEY in HASHTABLE."
 824   (let ((sym (intern-soft (ange-ftp-make-hash-key key) tbl)))
 825     (and sym (get sym 'val))))
 826
 827 (defun ange-ftp-put-hash-entry (key val tbl)
 828   "Record an association between KEY and VALUE in HASHTABLE."
 829   (let ((sym (intern (ange-ftp-make-hash-key key) tbl)))
 830     (put sym 'val val)
 831     (put sym 'key key)))
 832
 833 (defun ange-ftp-del-hash-entry (key tbl)
 834   "Copy all symbols except KEY in HASHTABLE and return modified hashtable."
 835   (let* ((len (length tbl))
 836          (new-tbl (ange-ftp-make-hashtable len))
 837          (i (1- len)))
 838     (ange-ftp-map-hashtable
 839      (function
 840       (lambda (k v)
 841         (or (equal k key)
 842             (ange-ftp-put-hash-entry k v new-tbl))))
 843      tbl)
 844     (while (>= i 0)
 845       (aset tbl i (aref new-tbl i))
 846       (setq i (1- i)))
 847     tbl))
 848
 849 (defun ange-ftp-hash-entry-exists-p (key tbl)
 850   "Return whether there is an association for KEY in TABLE."
 851   (intern-soft (ange-ftp-make-hash-key key) tbl))
 852
 853 (defun ange-ftp-hash-table-keys (tbl)
 854   "Return a sorted list of all the active keys in TABLE, as strings."
 855   (sort (all-completions "" tbl)
 856         (function string-lessp)))
 857 \f
 858 ;;;; ------------------------------------------------------------
 859 ;;;; Internal variables.
 860 ;;;; ------------------------------------------------------------
 861
 862 (defvar ange-ftp-data-buffer-name " *ftp data*"
 863   "Buffer name to hold directory listing data received from ftp process.")
 864
 865 (defvar ange-ftp-netrc-modtime nil
 866   "Last modified time of the netrc file from file-attributes.")
 867
 868 (defvar ange-ftp-user-hashtable (ange-ftp-make-hashtable)
 869   "Hash table holding associations between HOST, USER pairs.")
 870
 871 (defvar ange-ftp-passwd-hashtable (ange-ftp-make-hashtable)
 872   "Mapping between a HOST, USER pair and a PASSWORD for them.")
 873
 874 (defvar ange-ftp-account-hashtable (ange-ftp-make-hashtable)
 875   "Mapping between a HOST, USER pair and a ACCOUNT password for them.")
 876
 877 (defvar ange-ftp-files-hashtable (ange-ftp-make-hashtable 97)
 878   "Hash table for storing directories and their respective files.")
 879
 880 (defvar ange-ftp-ls-cache-lsargs nil
 881   "Last set of args used by ange-ftp-ls.")
 882
 883 (defvar ange-ftp-ls-cache-file nil
 884   "Last file passed to ange-ftp-ls.")
 885
 886 (defvar ange-ftp-ls-cache-res nil
 887   "Last result returned from ange-ftp-ls.")
 888
 889 (defconst ange-ftp-expand-dir-hashtable (ange-ftp-make-hashtable))
 890
 891 (defconst ange-ftp-expand-dir-regexp "^5.0 \\([^: ]+\\):")
 892
 893 ;; These are local variables in each FTP process buffer.
 894 (defvar ange-ftp-hash-mark-unit nil)
 895 (defvar ange-ftp-hash-mark-count nil)
 896 (defvar ange-ftp-xfer-size nil)
 897 (defvar ange-ftp-process-string nil)
 898 (defvar ange-ftp-process-result-line nil)
 899 (defvar ange-ftp-process-busy nil)
 900 (defvar ange-ftp-process-result nil)
 901 (defvar ange-ftp-process-multi-skip nil)
 902 (defvar ange-ftp-process-msg nil)
 903 (defvar ange-ftp-process-continue nil)
 904 (defvar ange-ftp-last-percent nil)
 905
 906 ;; These variables are bound by one function and examined by another.
 907 ;; Leave them void globally for error checking.
 908 (defvar ange-ftp-this-file)
 909 (defvar ange-ftp-this-dir)
 910 (defvar ange-ftp-this-user)
 911 (defvar ange-ftp-this-host)
 912 (defvar ange-ftp-this-msg)
 913 (defvar ange-ftp-completion-ignored-pattern)
 914 (defvar ange-ftp-trample-marker)
 915 \f
 916 ;; New error symbols.
 917 (put 'ftp-error 'error-conditions '(ftp-error file-error error))
 918 ;; (put 'ftp-error 'error-message "FTP error")
 919 \f
 920 ;;; ------------------------------------------------------------
 921 ;;; Enhanced message support.
 922 ;;; ------------------------------------------------------------
 923
 924 (defun ange-ftp-message (fmt &rest args)
 925   "Display message in echo area, but indicate if truncated.
 926 Args are as in `message': a format string, plus arguments to be formatted."
 927   (let ((msg (apply (function format) fmt args))
 928         (max (window-width (minibuffer-window))))
 929     (if noninteractive
 930         msg
 931       (if (>= (length msg) max)
 932           ;; Take just the last MAX - 3 chars of the string.
 933           (setq msg (concat "> " (substring msg (- 3 max)))))
 934       (message "%s" msg))))
 935
 936 (defun ange-ftp-abbreviate-filename (file &optional new)
 937   "Abbreviate the file name FILE relative to the default-directory.
 938 If the optional parameter NEW is given and the non-directory parts match,
 939 only return the directory part of FILE."
 940   (save-match-data
 941     (if (and default-directory
 942              (string-match (concat "^"
 943                                    (regexp-quote default-directory)
 944                                    ".") file))
 945         (setq file (substring file (1- (match-end 0)))))
 946     (if (and new
 947              (string-equal (file-name-nondirectory file)
 948                            (file-name-nondirectory new)))
 949         (setq file (file-name-directory file)))
 950     (or file "./")))
 951 \f
 952 ;;;; ------------------------------------------------------------
 953 ;;;; User / Host mapping support.
 954 ;;;; ------------------------------------------------------------
 955
 956 (defun ange-ftp-set-user (host user)
 957   "For a given HOST, set or change the default USER."
 958   (interactive "sHost: \nsUser: ")
 959   (ange-ftp-put-hash-entry host user ange-ftp-user-hashtable))
 960
 961 (defun ange-ftp-get-user (host)
 962   "Given a HOST, return the default USER."
 963   (ange-ftp-parse-netrc)
 964   (let ((user (ange-ftp-get-hash-entry host ange-ftp-user-hashtable)))
 965     (or user
 966         (prog1
 967             (setq user
 968                   (cond ((stringp ange-ftp-default-user)
 969                          ;; We have a default name.  Use it.
 970                          ange-ftp-default-user)
 971                         (ange-ftp-default-user
 972                          ;; Ask the user.
 973                          (let ((enable-recursive-minibuffers t))
 974                            (read-string (format "User for %s: " host)
 975                                         (user-login-name))))
 976                         ;; Default to the user's login name.
 977                         (t
 978                          (user-login-name))))
 979           (ange-ftp-set-user host user)))))
 980 \f
 981 ;;;; ------------------------------------------------------------
 982 ;;;; Password support.
 983 ;;;; ------------------------------------------------------------
 984
 985 (defun ange-ftp-read-passwd (prompt &optional default)
 986   "Read a password, echoing `.' for each character typed.
 987 End with RET, LFD, or ESC.  DEL or C-h rubs out.  C-u kills line.
 988 Optional DEFAULT is password to start with."
 989   (let ((pass (if default default ""))
 990         (c 0)
 991         (echo-keystrokes 0)
 992         (cursor-in-echo-area t))
 993     (while (progn (message "%s%s"
 994                            prompt
 995                            (make-string (length pass) ?.))
 996                   (setq c (read-char))
 997                   (and (/= c ?\r) (/= c ?\n) (/= c ?\e)))
 998       (if (= c ?\C-u)
 999           (setq pass "")
1000         (if (and (/= c ?\b) (/= c ?\177))
1001             (setq pass (concat pass (char-to-string c)))
1002           (if (> (length pass) 0)
1003               (setq pass (substring pass 0 -1))))))
1004     (message "")
1005     (ange-ftp-repaint-minibuffer)
1006     pass))
1007
1008 (defmacro ange-ftp-generate-passwd-key (host user)
1009   (` (concat (, host) "/" (, user))))
1010
1011 (defmacro ange-ftp-lookup-passwd (host user)
1012   (` (ange-ftp-get-hash-entry (ange-ftp-generate-passwd-key (, host) (, user))
1013                               ange-ftp-passwd-hashtable)))
1014
1015 (defun ange-ftp-set-passwd (host user passwd)
1016   "For a given HOST and USER, set or change the associated PASSWORD."
1017   (interactive (list (read-string "Host: ")
1018                      (read-string "User: ")
1019                      (ange-ftp-read-passwd "Password: ")))
1020   (ange-ftp-put-hash-entry (ange-ftp-generate-passwd-key host user)
1021                            passwd
1022                            ange-ftp-passwd-hashtable))
1023
1024 (defun ange-ftp-get-host-with-passwd (user)
1025   "Given a USER, return a host we know the password for."
1026   (ange-ftp-parse-netrc)
1027   (catch 'found-one
1028     (ange-ftp-map-hashtable
1029      (function (lambda (host val)
1030                  (if (ange-ftp-lookup-passwd host user)
1031                      (throw 'found-one host))))
1032      ange-ftp-user-hashtable)
1033     (save-match-data
1034       (ange-ftp-map-hashtable
1035        (function
1036         (lambda (key value)
1037           (if (string-match "^[^/]*\\(/\\).*$" key)
1038               (let ((host (substring key 0 (match-beginning 1))))
1039                 (if (and (string-equal user (substring key (match-end 1)))
1040                          value)
1041                     (throw 'found-one host))))))
1042        ange-ftp-passwd-hashtable))
1043     nil))
1044
1045 (defun ange-ftp-get-passwd (host user)
1046   "Return the password for specified HOST and USER, asking user if necessary."
1047   (ange-ftp-parse-netrc)
1048
1049   ;; look up password in the hash table first; user might have overridden the
1050   ;; defaults.
1051   (cond ((ange-ftp-lookup-passwd host user))
1052
1053         ;; see if default user and password set from the .netrc file.
1054         ((and (stringp ange-ftp-default-user)
1055               ange-ftp-default-password
1056               (string-equal user ange-ftp-default-user))
1057          ange-ftp-default-password)
1058
1059         ;; anonymous ftp password is handled specially since there is an
1060         ;; unwritten rule about how that is used on the Internet.
1061         ((and (or (string-equal user "anonymous")
1062                   (string-equal user "ftp"))
1063               ange-ftp-generate-anonymous-password)
1064          (if (stringp ange-ftp-generate-anonymous-password)
1065              ange-ftp-generate-anonymous-password
1066            user-mail-address))
1067
1068         ;; see if same user has logged in to other hosts; if so then prompt
1069         ;; with the password that was used there.
1070         (t
1071          (let* ((other (ange-ftp-get-host-with-passwd user))
1072                 (passwd (if other
1073
1074                             ;; found another machine with the same user.
1075                             ;; Try that account.
1076                             (ange-ftp-read-passwd
1077                              (format "passwd for %s@%s (same as %s@%s): "
1078                                      user host user other)
1079                              (ange-ftp-lookup-passwd other user))
1080
1081                           ;; I give up.  Ask the user for the password.
1082                           (ange-ftp-read-passwd
1083                            (format "Password for %s@%s: " user host)))))
1084            (ange-ftp-set-passwd host user passwd)
1085            passwd))))
1086 \f
1087 ;;;; ------------------------------------------------------------
1088 ;;;; Account support
1089 ;;;; ------------------------------------------------------------
1090
1091 ;; Account passwords must be either specified in the .netrc file, or set
1092 ;; manually by calling ange-ftp-set-account.  For the moment, ange-ftp doesn't
1093 ;; check to see whether the FTP process is actually prompting for an account
1094 ;; password.
1095
1096 (defun ange-ftp-set-account (host user account)
1097   "For a given HOST and USER, set or change the associated ACCOUNT password."
1098   (interactive (list (read-string "Host: ")
1099                      (read-string "User: ")
1100                      (ange-ftp-read-passwd "Account password: ")))
1101   (ange-ftp-put-hash-entry (ange-ftp-generate-passwd-key host user)
1102                            account
1103                            ange-ftp-account-hashtable))
1104
1105 (defun ange-ftp-get-account (host user)
1106   "Given a HOST and USER, return the FTP account."
1107   (ange-ftp-parse-netrc)
1108   (or (ange-ftp-get-hash-entry (ange-ftp-generate-passwd-key host user)
1109                                ange-ftp-account-hashtable)
1110       (and (stringp ange-ftp-default-user)
1111            (string-equal user ange-ftp-default-user)
1112            ange-ftp-default-account)))
1113 \f
1114 ;;;; ------------------------------------------------------------
1115 ;;;; ~/.netrc support
1116 ;;;; ------------------------------------------------------------
1117
1118 (defun ange-ftp-chase-symlinks (file)
1119   "Return the filename that FILE references, following all symbolic links."
1120   (let (temp)
1121     (while (setq temp (ange-ftp-real-file-symlink-p file))
1122       (setq file
1123             (if (file-name-absolute-p temp)
1124                 temp
1125               (concat (file-name-directory file) temp)))))
1126   file)
1127
1128 ;; Move along current line looking for the value of the TOKEN.
1129 ;; Valid separators between TOKEN and its value are commas and
1130 ;; whitespace.  Second arg LIMIT is a limit for the search.
1131
1132 (defun ange-ftp-parse-netrc-token (token limit)
1133   (if (search-forward token limit t)
1134       (let (beg)
1135         (skip-chars-forward ", \t\r\n" limit)
1136         (if (eq (following-char) ?\")   ;quoted token value
1137             (progn (forward-char 1)
1138                    (setq beg (point))
1139                    (skip-chars-forward "^\"" limit)
1140                    (forward-char 1)
1141                    (buffer-substring beg (1- (point))))
1142           (setq beg (point))
1143           (skip-chars-forward "^, \t\r\n" limit)
1144           (buffer-substring beg (point))))))
1145
1146 ;; Extract the values for the tokens `machine', `login',
1147 ;; `password' and `account' in the current buffer.  If successful,
1148 ;; record the information found.
1149
1150 (defun ange-ftp-parse-netrc-group ()
1151   (let ((start (point))
1152         (end (save-excursion
1153                (if (looking-at "machine\\>")
1154                    ;; Skip `machine' and the machine name that follows.
1155                    (progn
1156                      (skip-chars-forward "^ \t\n")
1157                      (skip-chars-forward " \t\n")
1158                      (skip-chars-forward "^ \t\n"))
1159                  ;; Skip `default'.
1160                  (skip-chars-forward "^ \t\n"))
1161                ;; Find start of the next `machine' or `default'
1162                ;; or the end of the buffer.
1163                (if (re-search-forward "machine\\>\\|default\\>" nil t)
1164                    (match-beginning 0)
1165                  (point-max))))
1166         machine login password account)
1167     (setq machine  (ange-ftp-parse-netrc-token "machine"  end)
1168           login    (ange-ftp-parse-netrc-token "login"    end)
1169           password (ange-ftp-parse-netrc-token "password" end)
1170           account  (ange-ftp-parse-netrc-token "account"  end))
1171     (if (and machine login)
1172         ;; found a `machine` token.
1173         (progn
1174           (ange-ftp-set-user machine login)
1175           (ange-ftp-set-passwd machine login password)
1176           (and account
1177                (ange-ftp-set-account machine login account)))
1178       (goto-char start)
1179       (if (search-forward "default" end t)
1180           ;; found a `default' token
1181           (progn
1182             (setq login    (ange-ftp-parse-netrc-token "login"    end)
1183                   password (ange-ftp-parse-netrc-token "password" end)
1184                   account  (ange-ftp-parse-netrc-token "account"  end))
1185             (and login
1186                  (setq ange-ftp-default-user login))
1187             (and password
1188                  (setq ange-ftp-default-password password))
1189             (and account
1190                  (setq ange-ftp-default-account account)))))
1191     (goto-char end)))
1192
1193 ;; Read in ~/.netrc, if one exists.  If ~/.netrc file exists and has
1194 ;; the correct permissions then extract the \`machine\', \`login\',
1195 ;; \`password\' and \`account\' information from within.
1196
1197 (defun ange-ftp-parse-netrc ()
1198   ;; We set this before actually doing it to avoid the possibility
1199   ;; of an infinite loop if ange-ftp-netrc-filename is an FTP file.
1200   (interactive)
1201   (let (file attr)
1202     (let ((default-directory "/"))
1203       (setq file (ange-ftp-chase-symlinks
1204                   (ange-ftp-real-expand-file-name ange-ftp-netrc-filename)))
1205       (setq attr (ange-ftp-real-file-attributes file)))
1206     (if (and attr                       ; file exists.
1207              (not (equal (nth 5 attr) ange-ftp-netrc-modtime))) ; file changed
1208         (save-match-data
1209           (if (or ange-ftp-disable-netrc-security-check
1210                   (and (eq (nth 2 attr) (user-uid)) ; Same uids.
1211                        (string-match ".r..------" (nth 8 attr))))
1212               (save-excursion
1213                 ;; we are cheating a bit here.  I'm trying to do the equivalent
1214                 ;; of find-file on the .netrc file, but then nuke it afterwards.
1215                 ;; with the bit of logic below we should be able to have
1216                 ;; encrypted .netrc files.
1217                 (set-buffer (generate-new-buffer "*ftp-.netrc*"))
1218                 (ange-ftp-real-insert-file-contents file)
1219                 (setq buffer-file-name file)
1220                 (setq default-directory (file-name-directory file))
1221                 (normal-mode t)
1222                 (mapcar 'funcall find-file-hooks)
1223                 (setq buffer-file-name nil)
1224                 (goto-char (point-min))
1225                 (skip-chars-forward " \t\n")
1226                 (while (not (eobp))
1227                   (ange-ftp-parse-netrc-group))
1228                 (kill-buffer (current-buffer)))
1229             (ange-ftp-message "%s either not owned by you or badly protected."
1230                               ange-ftp-netrc-filename)
1231             (sit-for 1))
1232           (setq ange-ftp-netrc-modtime (nth 5 attr))))))
1233
1234 ;; Return a list of prefixes of the form 'user@host:' to be used when
1235 ;; completion is done in the root directory.
1236
1237 (defun ange-ftp-generate-root-prefixes ()
1238   (ange-ftp-parse-netrc)
1239   (save-match-data
1240     (let (res)
1241       (ange-ftp-map-hashtable
1242        (function
1243         (lambda (key value)
1244           (if (string-match "^[^/]*\\(/\\).*$" key)
1245               (let ((host (substring key 0 (match-beginning 1)))
1246                     (user (substring key (match-end 1))))
1247                 (setq res (cons (list (concat user "@" host ":"))
1248                                 res))))))
1249        ange-ftp-passwd-hashtable)
1250       (ange-ftp-map-hashtable
1251        (function (lambda (host user)
1252                    (setq res (cons (list (concat host ":"))
1253                                    res))))
1254        ange-ftp-user-hashtable)
1255       (or res (list nil)))))
1256 \f
1257 ;;;; ------------------------------------------------------------
1258 ;;;; Remote file name syntax support.
1259 ;;;; ------------------------------------------------------------
1260
1261 (defmacro ange-ftp-ftp-name-component (n ns name)
1262   "Extract the Nth ftp file name component from NS."
1263   (` (let ((elt (nth (, n) (, ns))))
1264        (if (match-beginning elt)
1265            (substring (, name) (match-beginning elt) (match-end elt))))))
1266
1267 (defvar ange-ftp-ftp-name-arg "")
1268 (defvar ange-ftp-ftp-name-res nil)
1269
1270 ;; Parse NAME according to `ange-ftp-name-format' (which see).
1271 ;; Returns a list (HOST USER NAME), or nil if NAME does not match the format.
1272 (defun ange-ftp-ftp-name (name)
1273   (if (string-equal name ange-ftp-ftp-name-arg)
1274       ange-ftp-ftp-name-res
1275     (setq ange-ftp-ftp-name-arg name
1276           ange-ftp-ftp-name-res
1277           (save-match-data
1278             (if (string-match (car ange-ftp-name-format) name)
1279                 (let* ((ns (cdr ange-ftp-name-format))
1280                        (host (ange-ftp-ftp-name-component 0 ns name))
1281                        (user (ange-ftp-ftp-name-component 1 ns name))
1282                        (name (ange-ftp-ftp-name-component 2 ns name)))
1283                   (if (zerop (length user))
1284                       (setq user (ange-ftp-get-user host)))
1285                   (list host user name))
1286               nil)))))
1287
1288 ;; Take a FULLNAME that matches according to ange-ftp-name-format and
1289 ;; replace the name component with NAME.
1290 (defun ange-ftp-replace-name-component (fullname name)
1291   (save-match-data
1292     (if (string-match (car ange-ftp-name-format) fullname)
1293         (let* ((ns (cdr ange-ftp-name-format))
1294                (elt (nth 2 ns)))
1295           (concat (substring fullname 0 (match-beginning elt))
1296                   name
1297                   (substring fullname (match-end elt)))))))
1298 \f
1299 ;;;; ------------------------------------------------------------
1300 ;;;; Miscellaneous utils.
1301 ;;;; ------------------------------------------------------------
1302
1303 ;; (setq ange-ftp-tmp-keymap (make-sparse-keymap))
1304 ;; (define-key ange-ftp-tmp-keymap "\C-m" 'exit-minibuffer)
1305
1306 (defun ange-ftp-repaint-minibuffer ()
1307   "Clear any existing minibuffer message; let the minibuffer contents show."
1308   (message nil))
1309
1310 ;; Return the name of the buffer that collects output from the ftp process
1311 ;; connected to the given HOST and USER pair.
1312 (defun ange-ftp-ftp-process-buffer (host user)
1313   (concat "*ftp " user "@" host "*"))
1314
1315 ;; Display the last chunk of output from the ftp process for the given HOST
1316 ;; USER pair, and signal an error including MSG in the text.
1317 (defun ange-ftp-error (host user msg)
1318   (let ((cur (selected-window))
1319         (pop-up-windows t))
1320     (pop-to-buffer
1321      (get-buffer-create
1322       (ange-ftp-ftp-process-buffer host user)))
1323     (goto-char (point-max))
1324     (select-window cur))
1325   (signal 'ftp-error (list (format "FTP Error: %s" msg))))
1326
1327 (defun ange-ftp-set-buffer-mode ()
1328   "Set correct modes for the current buffer if visiting a remote file."
1329   (if (and (stringp buffer-file-name)
1330            (ange-ftp-ftp-name buffer-file-name))
1331       (auto-save-mode ange-ftp-auto-save)))
1332
1333 (defun ange-ftp-kill-ftp-process (buffer)
1334   "Kill the FTP process associated with BUFFER.
1335 If the BUFFER's visited filename or default-directory is an ftp filename
1336 then kill the related ftp process."
1337   (interactive "bKill FTP process associated with buffer: ")
1338   (if (null buffer)
1339       (setq buffer (current-buffer)))
1340   (let ((file (or (buffer-file-name) default-directory)))
1341     (if file
1342         (let ((parsed (ange-ftp-ftp-name (expand-file-name file))))
1343           (if parsed
1344               (let ((host (nth 0 parsed))
1345                     (user (nth 1 parsed)))
1346                 (kill-buffer (ange-ftp-ftp-process-buffer host user))))))))
1347
1348 (defun ange-ftp-quote-string (string)
1349   "Quote any characters in STRING that may confuse the ftp process."
1350   (apply (function concat)
1351          (mapcar (function
1352                    (lambda (char)
1353                      (if (or (<= char ? )
1354                              (> char ?\~)
1355                              (= char ?\")
1356                              (= char ?\\))
1357                          (vector ?\\ char)
1358                        (vector char))))
1359                  string)))
1360
1361 (defun ange-ftp-barf-if-not-directory (directory)
1362   (or (file-directory-p directory)
1363       (signal 'file-error
1364               (list "Opening directory"
1365                     (if (file-exists-p directory)
1366                         "not a directory"
1367                       "no such file or directory")
1368                     directory))))
1369 \f
1370 ;;;; ------------------------------------------------------------
1371 ;;;; FTP process filter support.
1372 ;;;; ------------------------------------------------------------
1373
1374 (defun ange-ftp-process-handle-line (line proc)
1375   "Look at the given LINE from the ftp process PROC.
1376 Try to categorize it into one of four categories:
1377 good, skip, fatal, or unknown."
1378   (cond ((string-match ange-ftp-xfer-size-msgs line)
1379          (setq ange-ftp-xfer-size
1380                (ash (string-to-int (substring line
1381                                               (match-beginning 1)
1382                                               (match-end 1)))
1383                     -10)))
1384         ((string-match ange-ftp-skip-msgs line)
1385          t)
1386         ((string-match ange-ftp-good-msgs line)
1387          (setq ange-ftp-process-busy nil
1388                ange-ftp-process-result t
1389                ange-ftp-process-result-line line))
1390         ;; Check this before checking for errors.
1391         ;; Otherwise the last line of these three seems to be an error:
1392         ;; 230-see a significant impact from the move.  For those of you who can't
1393         ;; 230-use DNS to resolve hostnames and get an error message like
1394         ;; 230-"ftp.stsci.edu: unknown host", the new IP address will be...
1395         ((string-match ange-ftp-multi-msgs line)
1396          (setq ange-ftp-process-multi-skip t))
1397         ((string-match ange-ftp-fatal-msgs line)
1398          (delete-process proc)
1399          (setq ange-ftp-process-busy nil
1400                ange-ftp-process-result-line line))
1401         (ange-ftp-process-multi-skip
1402          t)
1403         (t
1404          (setq ange-ftp-process-busy nil
1405                ange-ftp-process-result-line line))))
1406
1407 (defun ange-ftp-set-xfer-size (host user bytes)
1408   "Set the size of the next FTP transfer in bytes."
1409   (let ((proc (ange-ftp-get-process host user)))
1410     (if proc
1411         (let ((buf (process-buffer proc)))
1412           (if buf
1413               (save-excursion
1414                 (set-buffer buf)
1415                 (setq ange-ftp-xfer-size (ash bytes -10))))))))
1416
1417 (defun ange-ftp-process-handle-hash (str)
1418   "Remove hash marks from STRING and display count so far."
1419   (setq str (concat (substring str 0 (match-beginning 0))
1420                     (substring str (match-end 0)))
1421         ange-ftp-hash-mark-count (+ (- (match-end 0)
1422                                        (match-beginning 0))
1423                                     ange-ftp-hash-mark-count))
1424   (and ange-ftp-process-msg
1425        ange-ftp-process-verbose
1426        (not (eq (selected-window) (minibuffer-window)))
1427        (not (boundp 'search-message))   ;screws up isearch otherwise
1428        (not cursor-in-echo-area)        ;screws up y-or-n-p otherwise
1429        (let ((kbytes (ash (* ange-ftp-hash-mark-unit
1430                              ange-ftp-hash-mark-count)
1431                           -6)))
1432        (if (zerop ange-ftp-xfer-size)
1433            (ange-ftp-message "%s...%dk" ange-ftp-process-msg kbytes)
1434          (let ((percent (/ (* 100 kbytes) ange-ftp-xfer-size)))
1435            ;; cut out the redisplay of identical %-age messages.
1436            (if (not (eq percent ange-ftp-last-percent))
1437                (progn
1438                  (setq ange-ftp-last-percent percent)
1439                  (ange-ftp-message "%s...%d%%" ange-ftp-process-msg percent)))))))
1440   str)
1441
1442 ;; Call the function specified by CONT.  CONT can be either a function
1443 ;; or a list of a function and some args.  The first two parameters
1444 ;; passed to the function will be RESULT and LINE.  The remaining args
1445 ;; will be taken from CONT if a list was passed.
1446
1447 (defun ange-ftp-call-cont (cont result line)
1448   (if cont
1449       (if (and (listp cont)
1450                (not (eq (car cont) 'lambda)))
1451           (apply (car cont) result line (cdr cont))
1452         (funcall cont result line))))
1453
1454 ;; Build up a complete line of output from the ftp PROCESS and pass it
1455 ;; on to ange-ftp-process-handle-line to deal with.
1456
1457 (defun ange-ftp-process-filter (proc str)
1458   (let ((buffer (process-buffer proc))
1459         (old-buffer (current-buffer)))
1460
1461     ;; see if the buffer is still around... it could have been deleted.
1462     (if (buffer-name buffer)
1463         (unwind-protect
1464             (progn
1465               (set-buffer (process-buffer proc))
1466
1467               ;; handle hash mark printing
1468               (and ange-ftp-hash-mark-unit
1469                    ange-ftp-process-busy
1470                    (string-match "^#+$" str)
1471                    (setq str (ange-ftp-process-handle-hash str)))
1472               (comint-output-filter proc str)
1473               ;; Replace STR by the result of the comint processing.
1474               (setq str (buffer-substring comint-last-output-start
1475                                           (process-mark proc)))
1476               (if ange-ftp-process-busy
1477                   (progn
1478                     (setq ange-ftp-process-string (concat ange-ftp-process-string
1479                                                           str))
1480
1481                     ;; if we gave an empty password to the USER command earlier
1482                     ;; then we should send a null password now.
1483                     (if (string-match "Password: *$" ange-ftp-process-string)
1484                         (send-string proc "\n"))))
1485               (while (and ange-ftp-process-busy
1486                           (string-match "\n" ange-ftp-process-string))
1487                 (let ((line (substring ange-ftp-process-string
1488                                        0
1489                                        (match-beginning 0))))
1490                   (setq ange-ftp-process-string (substring ange-ftp-process-string
1491                                                            (match-end 0)))
1492                   (while (string-match "^ftp> *" line)
1493                     (setq line (substring line (match-end 0))))
1494                   (ange-ftp-process-handle-line line proc)))
1495
1496               ;; has the ftp client finished?  if so then do some clean-up
1497               ;; actions.
1498               (if (not ange-ftp-process-busy)
1499                   (progn
1500                     ;; reset the xfer size
1501                     (setq ange-ftp-xfer-size 0)
1502
1503                     ;; issue the "done" message since we've finished.
1504                     (if (and ange-ftp-process-msg
1505                              ange-ftp-process-verbose
1506                              ange-ftp-process-result)
1507                         (progn
1508                           (ange-ftp-message "%s...done" ange-ftp-process-msg)
1509                           (ange-ftp-repaint-minibuffer)
1510                           (setq ange-ftp-process-msg nil)))
1511
1512                     ;; is there a continuation we should be calling?  if so,
1513                     ;; we'd better call it, making sure we only call it once.
1514                     (if ange-ftp-process-continue
1515                         (let ((cont ange-ftp-process-continue))
1516                           (setq ange-ftp-process-continue nil)
1517                           (ange-ftp-call-cont cont
1518                                               ange-ftp-process-result
1519                                               ange-ftp-process-result-line))))))
1520           (set-buffer old-buffer)))))
1521
1522 (defun ange-ftp-process-sentinel (proc str)
1523   "When ftp process changes state, nuke all file-entries in cache."
1524   (let ((name (process-name proc)))
1525     (if (string-match "\\*ftp \\([^@]+\\)@\\([^*]+\\)*" name)
1526         (let ((user (substring name (match-beginning 1) (match-end 1)))
1527               (host (substring name (match-beginning 2) (match-end 2))))
1528           (ange-ftp-wipe-file-entries host user))))
1529   (setq ange-ftp-ls-cache-file nil))
1530 \f
1531 ;;;; ------------------------------------------------------------
1532 ;;;; Gateway support.
1533 ;;;; ------------------------------------------------------------
1534
1535 (defun ange-ftp-use-gateway-p (host)
1536   "Returns whether to access this host via a normal (non-smart) gateway."
1537   ;; yes, I know that I could simplify the following expression, but it is
1538   ;; clearer (to me at least) this way.
1539   (and (not ange-ftp-smart-gateway)
1540        (save-match-data
1541          (not (string-match ange-ftp-local-host-regexp host)))))
1542
1543 (defun ange-ftp-use-smart-gateway-p (host)
1544   "Returns whether to access this host via a smart gateway."
1545   (and ange-ftp-smart-gateway
1546        (save-match-data
1547          (not (string-match ange-ftp-local-host-regexp host)))))
1548
1549 \f
1550 ;;; ------------------------------------------------------------
1551 ;;; Temporary file location and deletion...
1552 ;;; ------------------------------------------------------------
1553
1554 (defvar ange-ftp-tmp-name-files ())
1555 (defvar ange-ftp-tmp-name-hashtable (ange-ftp-make-hashtable 10))
1556 (defvar ange-ftp-pid nil)
1557
1558 (defun ange-ftp-get-pid ()
1559   "Half-hearted attempt to get the current process's id."
1560   (setq ange-ftp-pid (substring (make-temp-name "") 1)))
1561
1562 (defun ange-ftp-make-tmp-name (host)
1563   "This routine will return the name of a new file."
1564   (let* ((template (if (ange-ftp-use-gateway-p host)
1565                        ange-ftp-gateway-tmp-name-template
1566                      ange-ftp-tmp-name-template))
1567          (pid (or ange-ftp-pid (ange-ftp-get-pid)))
1568          (start ?a)
1569          file entry)
1570     (while
1571         (progn
1572           (setq file (format "%s%c%s" template start pid))
1573           (setq entry (intern file ange-ftp-tmp-name-hashtable))
1574           (or (memq entry ange-ftp-tmp-name-files)
1575               (ange-ftp-real-file-exists-p file)))
1576       (if (> (setq start (1+ start)) ?z)
1577           (progn
1578             (setq template (concat template "X"))
1579             (setq start ?a))))
1580     (setq ange-ftp-tmp-name-files
1581           (cons entry ange-ftp-tmp-name-files))
1582     file))
1583
1584 (defun ange-ftp-del-tmp-name (temp)
1585   (setq ange-ftp-tmp-name-files
1586         (delq (intern temp ange-ftp-tmp-name-hashtable)
1587               ange-ftp-tmp-name-files))
1588   (condition-case ()
1589       (ange-ftp-real-delete-file temp)
1590     (error nil)))
1591 \f
1592 ;;;; ------------------------------------------------------------
1593 ;;;; Interactive gateway program support.
1594 ;;;; ------------------------------------------------------------
1595
1596 (defvar ange-ftp-gwp-running t)
1597 (defvar ange-ftp-gwp-status nil)
1598
1599 (defun ange-ftp-gwp-sentinel (proc str)
1600   (setq ange-ftp-gwp-running nil))
1601
1602 (defun ange-ftp-gwp-filter (proc str)
1603   (comint-output-filter proc str)
1604   ;; Replace STR by the result of the comint processing.
1605   (setq str (buffer-substring comint-last-output-start (process-mark proc)))
1606   (cond ((string-match "login: *$" str)
1607          (send-string proc
1608                       (concat
1609                        (let ((ange-ftp-default-user t))
1610                          (ange-ftp-get-user ange-ftp-gateway-host))
1611                        "\n")))
1612         ((string-match "Password: *$" str)
1613          (send-string proc
1614                       (concat
1615                        (ange-ftp-get-passwd ange-ftp-gateway-host
1616                                             (ange-ftp-get-user
1617                                              ange-ftp-gateway-host))
1618                        "\n")))
1619         ((string-match ange-ftp-gateway-fatal-msgs str)
1620          (delete-process proc)
1621          (setq ange-ftp-gwp-running nil))
1622         ((string-match ange-ftp-gateway-prompt-pattern str)
1623          (setq ange-ftp-gwp-running nil
1624                ange-ftp-gwp-status t))))
1625
1626 (defun ange-ftp-gwp-start (host user name args)
1627   "Login to the gateway machine and fire up an ftp process."
1628   (let* ((gw-user (ange-ftp-get-user ange-ftp-gateway-host))
1629          ;; It would be nice to make process-connection-type nil,
1630          ;; but that doesn't work: ftp never responds.
1631          ;; Can anyone find a fix for that?
1632          (proc (let ((process-connection-type t))
1633                  (start-process name name
1634                                 ange-ftp-gateway-program
1635                                 ange-ftp-gateway-host)))
1636          (ftp (mapconcat (function identity) args " ")))
1637     (process-kill-without-query proc)
1638     (set-process-sentinel proc (function ange-ftp-gwp-sentinel))
1639     (set-process-filter proc (function ange-ftp-gwp-filter))
1640     (save-excursion
1641       (set-buffer (process-buffer proc))
1642       (internal-ange-ftp-mode)
1643       (set-marker (process-mark proc) (point)))
1644     (setq ange-ftp-gwp-running t
1645           ange-ftp-gwp-status nil)
1646     (ange-ftp-message "Connecting to gateway %s..." ange-ftp-gateway-host)
1647     (while ange-ftp-gwp-running         ;perform login sequence
1648       (accept-process-output proc))
1649     (if (not ange-ftp-gwp-status)
1650         (ange-ftp-error host user "unable to login to gateway"))
1651     (ange-ftp-message "Connecting to gateway %s...done" ange-ftp-gateway-host)
1652     (setq ange-ftp-gwp-running t
1653           ange-ftp-gwp-status nil)
1654     (process-send-string proc ange-ftp-gateway-setup-term-command)
1655     (while ange-ftp-gwp-running         ;zap ^M's and double echoing.
1656       (accept-process-output proc))
1657     (if (not ange-ftp-gwp-status)
1658         (ange-ftp-error host user "unable to set terminal modes on gateway"))
1659     (setq ange-ftp-gwp-running t
1660           ange-ftp-gwp-status nil)
1661     (process-send-string proc (concat "exec " ftp "\n")) ;spawn ftp process
1662     proc))
1663 \f
1664 ;;;; ------------------------------------------------------------
1665 ;;;; Support for sending commands to the ftp process.
1666 ;;;; ------------------------------------------------------------
1667
1668 (defun ange-ftp-raw-send-cmd (proc cmd &optional msg cont nowait)
1669   "Low-level routine to send the given ftp CMD to the ftp PROCESS.
1670 MSG is an optional message to output before and after the command.
1671 If CONT is non-NIL then it is either a function or a list of function and
1672 some arguments.  The function will be called when the ftp command has completed.
1673 If CONT is NIL then this routine will return \( RESULT . LINE \) where RESULT
1674 is whether the command was successful, and LINE is the line from the FTP
1675 process that caused the command to complete.
1676 If NOWAIT is given then the routine will return immediately the command has
1677 been queued with no result.  CONT will still be called, however."
1678   (if (memq (process-status proc) '(run open))
1679       (save-excursion
1680         (set-buffer (process-buffer proc))
1681         (while ange-ftp-process-busy
1682           ;; This is a kludge to let user quit in case ftp gets hung.
1683           ;; It matters because this function can be called from the filter.
1684           ;; It is bad to allow quitting in a filter, but getting hung
1685           ;; is worse.  By binding quit-flag to nil, we might avoid
1686           ;; most of the probability of getting screwed because the user
1687           ;; wants to quit some command.
1688           (let ((quit-flag nil)
1689                 (inhibit-quit nil))
1690             (accept-process-output)))
1691         (setq ange-ftp-process-string ""
1692               ange-ftp-process-result-line ""
1693               ange-ftp-process-busy t
1694               ange-ftp-process-result nil
1695               ange-ftp-process-multi-skip nil
1696               ange-ftp-process-msg msg
1697               ange-ftp-process-continue cont
1698               ange-ftp-hash-mark-count 0
1699               ange-ftp-last-percent -1
1700               cmd (concat cmd "\n"))
1701         (and msg ange-ftp-process-verbose (ange-ftp-message "%s..." msg))
1702         (goto-char (point-max))
1703         (move-marker comint-last-input-start (point))
1704         ;; don't insert the password into the buffer on the USER command.
1705         (save-match-data
1706           (if (string-match "^user \"[^\"]*\"" cmd)
1707               (insert (substring cmd 0 (match-end 0)) " Turtle Power!\n")
1708             (insert cmd)))
1709         (move-marker comint-last-input-end (point))
1710         (send-string proc cmd)
1711         (set-marker (process-mark proc) (point))
1712         (if nowait
1713             nil
1714           ;; hang around for command to complete
1715           (while ange-ftp-process-busy
1716             ;; This is a kludge to let user quit in case ftp gets hung.
1717             ;; It matters because this function can be called from the filter.
1718             (let ((quit-flag nil)
1719                   (inhibit-quit nil))
1720               (accept-process-output proc)))
1721           (if cont
1722               nil                       ;cont has already been called
1723             (cons ange-ftp-process-result ange-ftp-process-result-line))))))
1724
1725 (defun ange-ftp-nslookup-host (host)
1726   "Attempt to resolve the given HOSTNAME using nslookup if possible."
1727   (interactive "sHost:  ")
1728   (if ange-ftp-nslookup-program
1729       (let ((default-directory
1730               (if (file-accessible-directory-p default-directory)
1731                   default-directory
1732                 exec-directory))
1733             ;; It would be nice to make process-connection-type nil,
1734             ;; but that doesn't work: ftp never responds.
1735             ;; Can anyone find a fix for that?
1736             (proc (let ((process-connection-type t))
1737                     (start-process " *nslookup*" " *nslookup*"
1738                                    ange-ftp-nslookup-program host)))
1739             (res host))
1740         (process-kill-without-query proc)
1741         (save-excursion
1742           (set-buffer (process-buffer proc))
1743           (while (memq (process-status proc) '(run open))
1744             (accept-process-output proc))
1745           (goto-char (point-min))
1746           (if (re-search-forward "Name:.*\nAddress: *\\(.*\\)$" nil t)
1747               (setq res (buffer-substring (match-beginning 1)
1748                                           (match-end 1))))
1749           (kill-buffer (current-buffer)))
1750         res)
1751     host))
1752
1753 (defun ange-ftp-start-process (host user name)
1754   "Spawn a new ftp process ready to connect to machine HOST and give it NAME.
1755 If HOST is only ftp-able through a gateway machine then spawn a shell
1756 on the gateway machine to do the ftp instead."
1757   (let* ((use-gateway (ange-ftp-use-gateway-p host))
1758          (use-smart-ftp (and (not ange-ftp-gateway-host)
1759                              (ange-ftp-use-smart-gateway-p host)))
1760          (ftp-prog (if (or use-gateway
1761                            use-smart-ftp)
1762                        ange-ftp-gateway-ftp-program-name
1763                      ange-ftp-ftp-program-name))
1764          (args (append (list ftp-prog) ange-ftp-ftp-program-args))
1765          ;; Without the following binding, ange-ftp-start-process
1766          ;; recurses on file-accessible-directory-p, since it needs to
1767          ;; restart its process in order to determine anything about
1768          ;; default-directory.
1769          (file-name-handler-alist)
1770          (default-directory
1771            (if (file-accessible-directory-p default-directory)
1772                default-directory
1773              exec-directory))
1774          proc)
1775     ;; It would be nice to make process-connection-type nil,
1776     ;; but that doesn't work: ftp never responds.
1777     ;; Can anyone find a fix for that?
1778     (let ((process-connection-type t))
1779       (if use-gateway
1780           (if ange-ftp-gateway-program-interactive
1781               (setq proc (ange-ftp-gwp-start host user name args))
1782             (setq proc (apply 'start-process name name
1783                               (append (list ange-ftp-gateway-program
1784                                             ange-ftp-gateway-host)
1785                                       args))))
1786         (setq proc (apply 'start-process name name args))))
1787     (process-kill-without-query proc)
1788     (save-excursion
1789       (set-buffer (process-buffer proc))
1790       (internal-ange-ftp-mode))
1791     (set-process-sentinel proc (function ange-ftp-process-sentinel))
1792     (set-process-filter proc (function ange-ftp-process-filter))
1793     (accept-process-output proc)        ;wait for ftp startup message
1794     proc))
1795
1796 (defun internal-ange-ftp-mode ()
1797   "Major mode for interacting with the FTP process.
1798
1799 \\{comint-mode-map}"
1800   (interactive)
1801   (comint-mode)
1802   (setq major-mode 'internal-ange-ftp-mode)
1803   (setq mode-name "Internal Ange-ftp")
1804   (let ((proc (get-buffer-process (current-buffer))))
1805     (goto-char (point-max))
1806     (set-marker (process-mark proc) (point))
1807     (make-local-variable 'ange-ftp-process-string)
1808     (setq ange-ftp-process-string "")
1809     (make-local-variable 'ange-ftp-process-busy)
1810     (make-local-variable 'ange-ftp-process-result)
1811     (make-local-variable 'ange-ftp-process-msg)
1812     (make-local-variable 'ange-ftp-process-multi-skip)
1813     (make-local-variable 'ange-ftp-process-result-line)
1814     (make-local-variable 'ange-ftp-process-continue)
1815     (make-local-variable 'ange-ftp-hash-mark-count)
1816     (make-local-variable 'ange-ftp-binary-hash-mark-size)
1817     (make-local-variable 'ange-ftp-ascii-hash-mark-size)
1818     (make-local-variable 'ange-ftp-hash-mark-unit)
1819     (make-local-variable 'ange-ftp-xfer-size)
1820     (make-local-variable 'ange-ftp-last-percent)
1821     (setq ange-ftp-hash-mark-count 0)
1822     (setq ange-ftp-xfer-size 0)
1823     (setq ange-ftp-process-result-line "")
1824
1825     (setq comint-prompt-regexp "^ftp> ")
1826     (make-local-variable 'paragraph-start)
1827     (setq paragraph-start comint-prompt-regexp)))
1828
1829 (defun ange-ftp-smart-login (host user pass account proc)
1830   "Connect to the FTP-server on HOST as USER using PASSWORD and ACCOUNT.
1831 PROC is the FTP-client's process.  This routine uses the smart-gateway
1832 host specified in ``ange-ftp-gateway-host''."
1833   (let ((result (ange-ftp-raw-send-cmd
1834                  proc
1835                  (format "open %s %s"
1836                          (ange-ftp-nslookup-host ange-ftp-gateway-host)
1837                          ange-ftp-smart-gateway-port)
1838                  (format "Opening FTP connection to %s via %s"
1839                          host
1840                          ange-ftp-gateway-host))))
1841     (or (car result)
1842         (ange-ftp-error host user
1843                         (concat "OPEN request failed: "
1844                                 (cdr result))))
1845     (setq result (ange-ftp-raw-send-cmd
1846                   proc (format "user \"%s\"@%s %s %s"
1847                                user
1848                                (ange-ftp-nslookup-host host)
1849                                pass
1850                                account)
1851                   (format "Logging in as user %s@%s"
1852                           user host)))
1853     (or (car result)
1854         (progn
1855           (ange-ftp-set-passwd host user nil) ; reset password
1856           (ange-ftp-set-account host user nil) ; reset account
1857           (ange-ftp-error host user
1858                           (concat "USER request failed: "
1859                                   (cdr result)))))))
1860
1861 (defun ange-ftp-normal-login (host user pass account proc)
1862   "Connect to the FTP-server on HOST as USER using PASSWORD and ACCOUNT.
1863 PROC is the process to the FTP-client."
1864   (let* ((nshost (ange-ftp-nslookup-host host))
1865          (result (ange-ftp-raw-send-cmd
1866                  proc
1867                  (format "open %s" nshost)
1868                  (format "Opening FTP connection to %s" host))))
1869     (or (car result)
1870         (ange-ftp-error host user
1871                         (concat "OPEN request failed: "
1872                                 (cdr result))))
1873     (setq result (ange-ftp-raw-send-cmd
1874                   proc
1875                   (if (ange-ftp-use-smart-gateway-p host)
1876                       (format "user \"%s\"@%s %s %s" user nshost pass account)
1877                     (format "user \"%s\" %s %s" user pass account))
1878                   (format "Logging in as user %s@%s" user host)))
1879     (or (car result)
1880         (progn
1881           (ange-ftp-set-passwd host user nil) ;reset password.
1882           (ange-ftp-set-account host user nil) ;reset account.
1883           (ange-ftp-error host user
1884                           (concat "USER request failed: "
1885                                   (cdr result)))))))
1886
1887 ;; ange@hplb.hpl.hp.com says this should not be changed.
1888 (defvar ange-ftp-hash-mark-msgs
1889   "[hH]ash mark [^0-9]*\\([0-9]+\\)"
1890   "*Regexp matching the FTP client's output upon doing a HASH command.")
1891
1892 (defun ange-ftp-guess-hash-mark-size (proc)
1893   (if ange-ftp-send-hash
1894       (save-excursion
1895         (set-buffer (process-buffer proc))
1896         (let* ((status (ange-ftp-raw-send-cmd proc "hash"))
1897                (result (car status))
1898                (line (cdr status)))
1899           (save-match-data
1900             (if (string-match ange-ftp-hash-mark-msgs line)
1901                 (let ((size (string-to-int
1902                             (substring line
1903                                        (match-beginning 1)
1904                                        (match-end 1)))))
1905                   (setq ange-ftp-ascii-hash-mark-size size
1906                         ange-ftp-hash-mark-unit (ash size -4))
1907
1908                   ;; if a default value for this is set, use that value.
1909                   (or ange-ftp-binary-hash-mark-size
1910                       (setq ange-ftp-binary-hash-mark-size size)))))))))
1911
1912 (defun ange-ftp-get-process (host user)
1913   "Return an FTP subprocess connected to HOST and logged in as USER.
1914 Create a new process if needed."
1915   (let* ((name (ange-ftp-ftp-process-buffer host user))
1916          (proc (get-process name)))
1917     (if (and proc (memq (process-status proc) '(run open)))
1918         proc
1919       (let ((pass (ange-ftp-quote-string
1920                    (ange-ftp-get-passwd host user)))
1921             (account (ange-ftp-quote-string
1922                       (ange-ftp-get-account host user))))
1923         ;; grab a suitable process.
1924         (setq proc (ange-ftp-start-process host user name))
1925
1926         ;; login to FTP server.
1927         (if (and (ange-ftp-use-smart-gateway-p host)
1928                  ange-ftp-gateway-host)
1929             (ange-ftp-smart-login host user pass account proc)
1930           (ange-ftp-normal-login host user pass account proc))
1931
1932         ;; Tell client to send back hash-marks as progress.  It isn't usually
1933         ;; fatal if this command fails.
1934         (ange-ftp-guess-hash-mark-size proc)
1935
1936         ;; Guess at the host type.
1937         (ange-ftp-guess-host-type host user)
1938
1939         ;; Run any user-specified hooks.  Note that proc, host and user are
1940         ;; dynamically bound at this point.
1941         (run-hooks 'ange-ftp-process-startup-hook))
1942       proc)))
1943
1944 ;; Variables for caching host and host-type
1945 (defvar ange-ftp-host-cache nil)
1946 (defvar ange-ftp-host-type-cache nil)
1947
1948 ;; If ange-ftp-host-type is called with the optional user
1949 ;; argument, it will attempt to guess the host type by connecting
1950 ;; as user, if necessary. For efficiency, I have tried to give this
1951 ;; optional second argument only when necessary. Have I missed any calls
1952 ;; to ange-ftp-host-type where it should have been supplied?
1953
1954 (defun ange-ftp-host-type (host &optional user)
1955   "Return a symbol which represents the type of the HOST given.
1956 If the optional argument USER is given, attempts to guess the
1957 host-type by logging in as USER."
1958   (if (eq host ange-ftp-host-cache)
1959       ange-ftp-host-type-cache
1960     ;; Trigger an ftp connection, in case we need to guess at the host type.
1961     (if (and user (ange-ftp-get-process host user) (eq host ange-ftp-host-cache))
1962         ange-ftp-host-type-cache
1963       (setq ange-ftp-host-cache host
1964             ange-ftp-host-type-cache
1965             (cond ((ange-ftp-dumb-unix-host host)
1966                    'dumb-unix)
1967 ;;                ((and (fboundp 'ange-ftp-vos-host)
1968 ;;                      (ange-ftp-vos-host host))
1969 ;;                 'vos)
1970                   ((and (fboundp 'ange-ftp-vms-host)
1971                         (ange-ftp-vms-host host))
1972                    'vms)
1973                   ((and (fboundp 'ange-ftp-mts-host)
1974                         (ange-ftp-mts-host host))
1975                    'mts)
1976                   ((and (fboundp 'ange-ftp-cms-host)
1977                         (ange-ftp-cms-host host))
1978                    'cms)
1979                   (t
1980                    'unix))))))
1981
1982 ;; It would be nice to abstract the functions ange-ftp-TYPE-host and
1983 ;; ange-ftp-add-TYPE-host. The trick is to abstract these functions
1984 ;; without sacrificing speed. Also, having separate variables
1985 ;; ange-ftp-TYPE-regexp is more user friendly then requiring the user to
1986 ;; set an alist to indicate that a host is of a given type. Even with
1987 ;; automatic host type recognition, setting a regexp is still a good idea
1988 ;; (for efficiency) if you log into a particular non-UNIX host frequently.
1989
1990 (defvar ange-ftp-fix-name-func-alist nil
1991   "Alist saying how to convert file name to the host's syntax.
1992 Association list of \( TYPE \. FUNC \) pairs, where FUNC is a routine
1993 which can change a UNIX file name into a name more suitable for a host of type
1994 TYPE.")
1995
1996 (defvar ange-ftp-fix-dir-name-func-alist nil
1997   "Alist saying how to convert directory name to the host's syntax.
1998 Association list of \( TYPE \. FUNC \) pairs, where FUNC is a routine
1999 which can change UNIX directory name into a directory name more suitable
2000 for a host of type TYPE.")
2001
2002 ;; *** Perhaps the sense of this variable should be inverted, since there
2003 ;; *** is only 1 host type that can take ls-style listing options.
2004 (defvar ange-ftp-dumb-host-types '(dumb-unix)
2005   "List of host types that can't take UNIX ls-style listing options.")
2006
2007 (defun ange-ftp-send-cmd (host user cmd &optional msg cont nowait)
2008   "Find an ftp process connected to HOST logged in as USER and send it CMD.
2009 MSG is an optional status message to be output before and after issuing the
2010 command.
2011 See the documentation for ange-ftp-raw-send-cmd for a description of CONT
2012 and NOWAIT."
2013   ;; Handle conversion to remote file name syntax and remote ls option
2014   ;; capability.
2015   (let ((cmd0 (car cmd))
2016         (cmd1 (nth 1 cmd))
2017         (ange-ftp-this-user user)
2018         (ange-ftp-this-host host)
2019         (ange-ftp-this-msg msg)
2020         cmd2 cmd3 host-type fix-name-func)
2021
2022     (cond
2023
2024      ;; pwd case (We don't care what host-type.)
2025      ((null cmd1))
2026
2027      ;; cmd == 'dir "remote-name" "local-name" "ls-switches"
2028      ((progn
2029        (setq cmd2 (nth 2 cmd)
2030              host-type (ange-ftp-host-type host user))
2031        ;; This will trigger an FTP login, if one doesn't exist
2032        (eq cmd0 'dir))
2033       (setq cmd1 (funcall
2034                   (or (cdr (assq host-type ange-ftp-fix-dir-name-func-alist))
2035                       'identity)
2036                   cmd1)
2037             cmd3 (nth 3 cmd))
2038       ;; Need to deal with the HP-UX ftp bug. This should also allow
2039       ;; us to resolve symlinks to directories on SysV machines. (Sebastian will
2040       ;; be happy.)
2041       (and (eq host-type 'unix)
2042            (string-match "/$" cmd1)
2043            (not (string-match "R" cmd3))
2044            (setq cmd1 (concat cmd1 ".")))
2045       ;; If the remote ls can take switches, put them in
2046       (or (memq host-type ange-ftp-dumb-host-types)
2047           (setq cmd0 'ls
2048                 cmd1 (format "\"%s %s\"" cmd3 cmd1))))
2049
2050      ;; First argument is the remote name
2051      ((progn
2052         (setq fix-name-func (or (cdr (assq host-type
2053                                            ange-ftp-fix-name-func-alist))
2054                                 'identity))
2055         (memq cmd0 '(get delete mkdir rmdir cd)))
2056       (setq cmd1 (funcall fix-name-func cmd1)))
2057
2058      ;; Second argument is the remote name
2059      ((memq cmd0 '(append put chmod))
2060       (setq cmd2 (funcall fix-name-func cmd2)))
2061
2062      ;; Both arguments are remote names
2063      ((eq cmd0 'rename)
2064       (setq cmd1 (funcall fix-name-func cmd1)
2065             cmd2 (funcall fix-name-func cmd2))))
2066
2067     ;; Turn the command into one long string
2068     (setq cmd0 (symbol-name cmd0))
2069     (setq cmd (concat cmd0
2070                       (and cmd1 (concat " " cmd1))
2071                       (and cmd2 (concat " " cmd2))))
2072
2073     ;; Actually send the resulting command.
2074     (let (afsc-result
2075           afsc-line)
2076       (ange-ftp-raw-send-cmd
2077        (ange-ftp-get-process host user)
2078        cmd
2079        msg
2080        (list
2081         (function (lambda (result line host user
2082                                   cmd msg cont nowait)
2083                     (or cont
2084                         (setq afsc-result result
2085                               afsc-line line))
2086                     (if result
2087                         (ange-ftp-call-cont cont result line)
2088                       (ange-ftp-raw-send-cmd
2089                        (ange-ftp-get-process host user)
2090                        cmd
2091                        msg
2092                        (list
2093                         (function (lambda (result line cont)
2094                                     (or cont
2095                                         (setq afsc-result result
2096                                               afsc-line line))
2097                                     (ange-ftp-call-cont cont result line)))
2098                         cont)
2099                        nowait))))
2100         host user cmd msg cont nowait)
2101        nowait)
2102
2103       (if nowait
2104           nil
2105         (if cont
2106             nil
2107           (cons afsc-result afsc-line))))))
2108
2109 ;; It might be nice to message users about the host type identified,
2110 ;; but there is so much other messaging going on, it would not be
2111 ;; seen. No point in slowing things down just so users can read
2112 ;; a host type message.
2113
2114 (defconst ange-ftp-cms-name-template
2115   (concat
2116    "^[-A-Z0-9$*][-A-Z0-9$*]?[-A-Z0-9$*]?[-A-Z0-9$*]?[-A-Z0-9$*]?"
2117    "[-A-Z0-9$*]?[-A-Z0-9$*]?[-A-Z0-9$*]?\\.[0-9][0-9][0-9A-Z]$"))
2118 (defconst ange-ftp-vms-name-template
2119   "^[-A-Z0-9_$]+:\\[[-A-Z0-9_$]+\\(\\.[-A-Z0-9_$]+\\)*\\]$")
2120 (defconst ange-ftp-mts-name-template
2121   "^[A-Z0-9._][A-Z0-9._][A-Z0-9._][A-Z0-9._]:$")
2122
2123 (defun ange-ftp-guess-host-type (host user)
2124   "Guess at the the host type of HOST.
2125 Works by doing a pwd and examining the directory syntax."
2126   (let ((host-type (ange-ftp-host-type host))
2127         (key (concat host "/" user "/~")))
2128     (if (eq host-type 'unix)
2129         ;; Note that ange-ftp-host-type returns unix as the default value.
2130         (save-match-data
2131           (let* ((result (ange-ftp-get-pwd host user))
2132                  (dir (car result))
2133                  fix-name-func)
2134             (cond ((null dir)
2135                    (message "Warning! Unable to get home directory")
2136                    (sit-for 1)
2137                    (if (string-match
2138                         "^450 No current working directory defined$"
2139                         (cdr result))
2140
2141                        ;; We'll assume that if pwd bombs with this
2142                        ;; error message, then it's CMS.
2143                        (progn
2144                          (ange-ftp-add-cms-host host)
2145                          (setq ange-ftp-host-cache host
2146                                ange-ftp-host-type-cache 'cms))))
2147
2148                   ;; try for VMS
2149                   ((string-match ange-ftp-vms-name-template dir)
2150                    (ange-ftp-add-vms-host host)
2151                    ;; The add-host functions clear the host type cache.
2152                    ;; Therefore, need to set the cache afterwards.
2153                    (setq ange-ftp-host-cache host
2154                          ange-ftp-host-type-cache 'vms))
2155
2156                   ;; try for MTS
2157                   ((string-match ange-ftp-mts-name-template dir)
2158                    (ange-ftp-add-mts-host host)
2159                    (setq ange-ftp-host-cache host
2160                          ange-ftp-host-type-cache 'mts))
2161
2162                   ;; try for CMS
2163                   ((string-match ange-ftp-cms-name-template dir)
2164                    (ange-ftp-add-cms-host host)
2165                    (setq ange-ftp-host-cache host
2166                          ange-ftp-host-type-cache 'cms))
2167
2168                   ;; assume UN*X
2169                   (t
2170                    (setq ange-ftp-host-cache host
2171                          ange-ftp-host-type-cache 'unix)))
2172
2173             ;; Now that we have done a pwd, might as well put it in
2174             ;; the expand-dir hashtable.
2175             (let ((ange-ftp-this-user user)
2176                   (ange-ftp-this-host host))
2177               (setq fix-name-func (cdr (assq ange-ftp-host-type-cache
2178                                              ange-ftp-fix-name-func-alist)))
2179               (if fix-name-func
2180                   (setq dir (funcall fix-name-func dir 'reverse))))
2181             (ange-ftp-put-hash-entry key dir
2182                                      ange-ftp-expand-dir-hashtable))))
2183
2184     ;; In the special case of CMS make sure that know the
2185     ;; expansion of the home minidisk now, because we will
2186     ;; be doing a lot of cd's.
2187     (if (and (eq host-type 'cms)
2188              (not (ange-ftp-hash-entry-exists-p
2189                    key ange-ftp-expand-dir-hashtable)))
2190         (let ((dir (car (ange-ftp-get-pwd host user))))
2191           (if dir
2192               (ange-ftp-put-hash-entry key (concat "/" dir)
2193                                        ange-ftp-expand-dir-hashtable)
2194             (message "Warning! Unable to get home directory")
2195             (sit-for 1))))))
2196
2197 \f
2198 ;;;; ------------------------------------------------------------
2199 ;;;; Remote file and directory listing support.
2200 ;;;; ------------------------------------------------------------
2201
2202 ;; Returns whether HOST's FTP server doesn't like \'ls\' or \'dir\' commands
2203 ;; to take switch arguments.
2204 (defun ange-ftp-dumb-unix-host (host)
2205   (and ange-ftp-dumb-unix-host-regexp
2206        (save-match-data
2207          (string-match ange-ftp-dumb-unix-host-regexp host))))
2208
2209 (defun ange-ftp-add-dumb-unix-host (host)
2210   "Interactively adds a given HOST to ange-ftp-dumb-unix-host-regexp."
2211   (interactive
2212    (list (read-string "Host: "
2213                       (let ((name (or (buffer-file-name) default-directory)))
2214                         (and name (car (ange-ftp-ftp-name name)))))))
2215   (if (not (ange-ftp-dumb-unix-host host))
2216       (setq ange-ftp-dumb-unix-host-regexp
2217             (concat "^" (regexp-quote host) "$"
2218                     (and ange-ftp-dumb-unix-host-regexp "\\|")
2219                     ange-ftp-dumb-unix-host-regexp)
2220             ange-ftp-host-cache nil)))
2221
2222 (defvar ange-ftp-parse-list-func-alist nil
2223   "Alist saying how to parse directory listings for certain OS types.
2224 Association list of \( TYPE \. FUNC \) pairs.  The FUNC is a routine
2225 which can parse the output from a DIR listing for a host of type TYPE.")
2226
2227 ;; With no-error nil, this function returns:
2228 ;; an error if file is not an ange-ftp-name
2229 ;;                      (This should never happen.)
2230 ;; an error if either the listing is unreadable or there is an ftp error.
2231 ;; the listing (a string), if everything works.
2232 ;;
2233 ;; With no-error t, it returns:
2234 ;; an error if not an ange-ftp-name
2235 ;; error if listing is unreable (most likely caused by a slow connection)
2236 ;; nil if ftp error (this is because although asking to list a nonexistent
2237 ;;                   directory on a remote unix machine usually (except
2238 ;;                   maybe for dumb hosts) returns an ls error, but no
2239 ;;                   ftp error, if the same is done on a VMS machine,
2240 ;;                   an ftp error is returned. Need to trap the error
2241 ;;                   so we can go on and try to list the parent.)
2242 ;; the listing, if everything works.
2243
2244 ;; If WILDCARD is non-nil, then this implements the guts of insert-directory
2245 ;; in the wildcard case.  Then we make a relative directory listing
2246 ;; of FILE within the directory specified by `default-directory'.
2247
2248 (defun ange-ftp-ls (file lsargs parse &optional no-error wildcard)
2249   "Return the output of an `DIR' or `ls' command done over ftp.
2250 FILE is the full name of the remote file, LSARGS is any args to pass to the
2251 `ls' command, and PARSE specifies that the output should be parsed and stored
2252 away in the internal cache."
2253   ;; If parse is t, we assume that file is a directory. i.e. we only parse
2254   ;; full directory listings.
2255   (let* ((ange-ftp-this-file (ange-ftp-expand-file-name file))
2256          (parsed (ange-ftp-ftp-name ange-ftp-this-file)))
2257     (if parsed
2258         (let* ((host (nth 0 parsed))
2259                (user (nth 1 parsed))
2260                (name (ange-ftp-quote-string (nth 2 parsed)))
2261                (key (directory-file-name ange-ftp-this-file))
2262                (host-type (ange-ftp-host-type host user))
2263                (dumb (memq host-type ange-ftp-dumb-host-types))
2264                result
2265                temp
2266                lscmd parse-func)
2267           (if (string-equal name "")
2268               (setq name
2269                     (ange-ftp-real-file-name-as-directory
2270                           (ange-ftp-expand-dir host user "~"))))
2271           (if (and ange-ftp-ls-cache-file
2272                    (string-equal key ange-ftp-ls-cache-file)
2273                    ;; Don't care about lsargs for dumb hosts.
2274                    (or dumb (string-equal lsargs ange-ftp-ls-cache-lsargs)))
2275               ange-ftp-ls-cache-res
2276             (setq temp (ange-ftp-make-tmp-name host))
2277             (if wildcard
2278                 (progn
2279                   (ange-ftp-cd host user (file-name-directory name))
2280                   (setq lscmd (list 'dir file temp lsargs)))
2281               (setq lscmd (list 'dir name temp lsargs)))
2282             (unwind-protect
2283                 (if (car (setq result (ange-ftp-send-cmd
2284                                        host
2285                                        user
2286                                        lscmd
2287                                        (format "Listing %s"
2288                                                (ange-ftp-abbreviate-filename
2289                                                 ange-ftp-this-file)))))
2290                     (save-excursion
2291                       (set-buffer (get-buffer-create
2292                                    ange-ftp-data-buffer-name))
2293                       (erase-buffer)
2294                       (if (ange-ftp-real-file-readable-p temp)
2295                           (ange-ftp-real-insert-file-contents temp)
2296                         (sleep-for ange-ftp-retry-time)
2297                                         ;wait for file to possibly appear
2298                         (if (ange-ftp-real-file-readable-p temp)
2299                             ;; Try again.
2300                             (ange-ftp-real-insert-file-contents temp)
2301                           (ange-ftp-error host user
2302                                           (format
2303                                            "list data file %s not readable"
2304                                            temp))))
2305                       (if parse
2306                           (ange-ftp-set-files
2307                            ange-ftp-this-file
2308                            (if (setq
2309                                 parse-func
2310                                 (cdr (assq host-type
2311                                            ange-ftp-parse-list-func-alist)))
2312                                (funcall parse-func)
2313                              (ange-ftp-parse-dired-listing lsargs))))
2314                       (setq ange-ftp-ls-cache-file key
2315                             ange-ftp-ls-cache-lsargs lsargs
2316                                         ; For dumb hosts-types this is
2317                                         ; meaningless but harmless.
2318                             ange-ftp-ls-cache-res (buffer-string))
2319                       ;; (kill-buffer (current-buffer))
2320                       ange-ftp-ls-cache-res)
2321                   (if no-error
2322                       nil
2323                     (ange-ftp-error host user
2324                                     (concat "DIR failed: " (cdr result)))))
2325               (ange-ftp-del-tmp-name temp))))
2326       (error "Should never happen. Please report. Bug ref. no.: 1"))))
2327 \f
2328 ;;;; ------------------------------------------------------------
2329 ;;;; Directory information caching support.
2330 ;;;; ------------------------------------------------------------
2331
2332 (defconst ange-ftp-date-regexp
2333   (concat
2334    " \\(Jan\\|Feb\\|Mar\\|Apr\\|May\\|Jun\\|Jul\\|Aug\\|Sep\\|Oct"
2335    "\\|Nov\\|Dec\\) +[0-3]?[0-9] "))
2336
2337 (defvar ange-ftp-add-file-entry-alist nil
2338   "Alist saying how to add file entries on certain OS types.
2339 Association list of pairs \( TYPE \. FUNC \), where FUNC
2340 is a function to be used to add a file entry for the OS TYPE. The
2341 main reason for this alist is to deal with file versions in VMS.")
2342
2343 (defvar ange-ftp-delete-file-entry-alist nil
2344   "Alist saying how to delete files on certain OS types.
2345 Association list of pairs \( TYPE \. FUNC \), where FUNC
2346 is a function to be used to delete a file entry for the OS TYPE.
2347 The main reason for this alist is to deal with file versions in VMS.")
2348
2349 (defun ange-ftp-add-file-entry (name &optional dir-p)
2350   "Add a file entry for file NAME, if its directory info exists."
2351   (funcall (or (cdr (assq (ange-ftp-host-type
2352                            (car (ange-ftp-ftp-name name)))
2353                           ange-ftp-add-file-entry-alist))
2354                'ange-ftp-internal-add-file-entry)
2355            name dir-p)
2356   (setq ange-ftp-ls-cache-file nil))
2357
2358 (defun ange-ftp-delete-file-entry (name &optional dir-p)
2359   "Delete the file entry for file NAME, if its directory info exists."
2360   (funcall (or (cdr (assq (ange-ftp-host-type
2361                            (car (ange-ftp-ftp-name name)))
2362                           ange-ftp-delete-file-entry-alist))
2363                'ange-ftp-internal-delete-file-entry)
2364            name dir-p)
2365   (setq ange-ftp-ls-cache-file nil))
2366
2367 (defmacro ange-ftp-parse-filename ()
2368   ;;Extract the filename from the current line of a dired-like listing.
2369   (` (let ((eol (progn (end-of-line) (point))))
2370        (beginning-of-line)
2371        (if (re-search-forward ange-ftp-date-regexp eol t)
2372            (progn
2373              (skip-chars-forward " ")
2374              (skip-chars-forward "^ " eol)
2375              (skip-chars-forward " " eol)
2376              ;; We bomb on filenames starting with a space.
2377              (buffer-substring (point) eol))))))
2378
2379 ;; This deals with the F switch. Should also do something about
2380 ;; unquoting names obtained with the SysV b switch and the GNU Q
2381 ;; switch. See Sebastian's dired-get-filename.
2382
2383 (defmacro ange-ftp-ls-parser ()
2384   ;; Note that switches is dynamically bound.
2385   ;; Meant to be called by ange-ftp-parse-dired-listing
2386   (` (let ((tbl (ange-ftp-make-hashtable))
2387            (used-F (and (stringp switches)
2388                         (string-match "F" switches)))
2389            file-type symlink directory file)
2390        (while (setq file (ange-ftp-parse-filename))
2391          (beginning-of-line)
2392          (skip-chars-forward "\t 0-9")
2393          (setq file-type (following-char)
2394                directory (eq file-type ?d))
2395          (if (eq file-type ?l)
2396              (if (string-match " -> " file)
2397                  (setq symlink (substring file (match-end 0))
2398                        file (substring file 0 (match-beginning 0)))
2399                ;; Shouldn't happen
2400                (setq symlink ""))
2401            (setq symlink nil))
2402          ;; Only do a costly regexp search if the F switch was used.
2403          (if (and used-F
2404                   (not (string-equal file ""))
2405                   (looking-at
2406                    ".[-r][-w]\\([^ ]\\)[-r][-w]\\([^ ]\\)[-r][-w]\\([^ ]\\)"))
2407              (let ((socket (eq file-type ?s))
2408                    (executable
2409                     (and (not symlink) ; x bits don't mean a thing for symlinks
2410                          (string-match "[xst]"
2411                                        (concat
2412                                         (buffer-substring
2413                                          (match-beginning 1)
2414                                          (match-end 1))
2415                                         (buffer-substring
2416                                          (match-beginning 2)
2417                                          (match-end 2))
2418                                         (buffer-substring
2419                                          (match-beginning 3)
2420                                          (match-end 3)))))))
2421                ;; Some ls's with the F switch mark symlinks with an @ (ULTRIX)
2422                ;; and others don't. (sigh...) Beware, that some Unix's don't
2423                ;; seem to believe in the F-switch
2424                (if (or (and symlink (string-match "@$" file))
2425                        (and directory (string-match "/$" file))
2426                        (and executable (string-match "*$" file))
2427                        (and socket (string-match "=$" file)))
2428                    (setq file (substring file 0 -1)))))
2429          (ange-ftp-put-hash-entry file (or symlink directory) tbl)
2430          (forward-line 1))
2431        (ange-ftp-put-hash-entry "." t tbl)
2432        (ange-ftp-put-hash-entry ".." t tbl)
2433        tbl)))
2434
2435 ;;; The dl stuff for descriptive listings
2436
2437 (defvar ange-ftp-dl-dir-regexp nil
2438   "Regexp matching directories which are listed in dl format.
2439 This regexp should not be anchored with a trailing `$', because it should
2440 match subdirectories as well.")
2441
2442 (defun ange-ftp-add-dl-dir (dir)
2443   "Interactively adds a DIR to ange-ftp-dl-dir-regexp."
2444   (interactive
2445    (list (read-string "Directory: "
2446                       (let ((name (or (buffer-file-name) default-directory)))
2447                         (and name (ange-ftp-ftp-name name)
2448                              (file-name-directory name))))))
2449   (if (not (and ange-ftp-dl-dir-regexp
2450                 (string-match ange-ftp-dl-dir-regexp dir)))
2451       (setq ange-ftp-dl-dir-regexp
2452             (concat "^" (regexp-quote dir)
2453                     (and ange-ftp-dl-dir-regexp "\\|")
2454                     ange-ftp-dl-dir-regexp))))
2455
2456 (defmacro ange-ftp-dl-parser ()
2457   ;; Parse the current buffer, which is assumed to be a descriptive
2458   ;; listing, and return a hashtable.
2459   (` (let ((tbl (ange-ftp-make-hashtable)))
2460        (while (not (eobp))
2461          (ange-ftp-put-hash-entry
2462           (buffer-substring (point)
2463                             (progn
2464                               (skip-chars-forward "^ /\n")
2465                               (point)))
2466           (eq (following-char) ?/)
2467           tbl)
2468          (forward-line 1))
2469        (ange-ftp-put-hash-entry "." t tbl)
2470        (ange-ftp-put-hash-entry ".." t tbl)
2471        tbl)))
2472
2473 ;; Parse the current buffer which is assumed to be in a dired-like listing
2474 ;; format, and return a hashtable as the result. If the listing is not really
2475 ;; a listing, then return nil.
2476
2477 (defun ange-ftp-parse-dired-listing (&optional switches)
2478   (save-match-data
2479     (cond
2480      ((looking-at "^total [0-9]+$")
2481       (forward-line 1)
2482       ;; Some systems put in a blank line here.
2483       (if (eolp) (forward-line 1))
2484       (ange-ftp-ls-parser))
2485      ((looking-at "[^\n]+\\( not found\\|: Not a directory\\)\n\\'")
2486       ;; It's an ls error message.
2487       nil)
2488      ((eobp) ; i.e. (zerop (buffer-size))
2489       ;; This could be one of:
2490       ;; (1) An Ultrix ls error message
2491       ;; (2) A listing with the A switch of an empty directory
2492       ;;     on a machine which doesn't give a total line.
2493       ;; (3) The twilight zone.
2494       ;; We'll assume (1) for now.
2495       nil)
2496      ((re-search-forward ange-ftp-date-regexp nil t)
2497       (beginning-of-line)
2498       (ange-ftp-ls-parser))
2499      ((re-search-forward "^[^ \n\t]+ +\\([0-9]+\\|-\\|=\\) " nil t)
2500       ;; It's a dl listing (I hope).
2501       ;; file is bound by the call to ange-ftp-ls
2502       (ange-ftp-add-dl-dir ange-ftp-this-file)
2503       (beginning-of-line)
2504       (ange-ftp-dl-parser))
2505      (t nil))))
2506
2507 (defun ange-ftp-set-files (directory files)
2508   "For a given DIRECTORY, set or change the associated FILES hashtable."
2509   (and files (ange-ftp-put-hash-entry (file-name-as-directory directory)
2510                                       files ange-ftp-files-hashtable)))
2511
2512 (defun ange-ftp-get-files (directory &optional no-error)
2513   "Given a given DIRECTORY, return a hashtable of file entries.
2514 This will give an error or return nil, depending on the value of
2515 NO-ERROR, if a listing for DIRECTORY cannot be obtained."
2516   (setq directory (file-name-as-directory directory)) ;normalize
2517   (or (ange-ftp-get-hash-entry directory ange-ftp-files-hashtable)
2518       (save-match-data
2519         (and (ange-ftp-ls directory
2520                           ;; This is an efficiency hack. We try to
2521                           ;; anticipate what sort of listing dired
2522                           ;; might want, and cache just such a listing.
2523                           (if (and (boundp 'dired-actual-switches)
2524                                    (stringp dired-actual-switches)
2525                                    ;; We allow the A switch, which lists
2526                                    ;; all files except "." and "..".
2527                                    ;; This is OK because we manually
2528                                    ;; insert these entries
2529                                    ;; in the hash table.
2530                                    (string-match
2531                                     "[aA]" dired-actual-switches)
2532                                    (string-match
2533                                     "l" dired-actual-switches)
2534                                    (not (string-match
2535                                          "R" dired-actual-switches)))
2536                               dired-actual-switches
2537                             (if (and (boundp 'dired-listing-switches)
2538                                      (stringp dired-listing-switches)
2539                                      (string-match
2540                                       "[aA]" dired-listing-switches)
2541                                      (string-match
2542                                       "l" dired-listing-switches)
2543                                      (not (string-match
2544                                            "R" dired-listing-switches)))
2545                                 dired-listing-switches
2546                               "-al"))
2547                           t no-error)
2548              (ange-ftp-get-hash-entry
2549               directory ange-ftp-files-hashtable)))))
2550
2551 ;; Given NAME, return the file part that can be used for looking up the
2552 ;; file's entry in a hashtable.
2553 (defmacro ange-ftp-get-file-part (name)
2554   (` (let ((file (file-name-nondirectory (, name))))
2555        (if (string-equal file "")
2556            "."
2557          file))))
2558
2559 ;; Return whether ange-ftp-file-entry-p and ange-ftp-get-file-entry are
2560 ;; allowed to determine if NAME is a sub-directory by listing it directly,
2561 ;; rather than listing its parent directory. This is used for efficiency so
2562 ;; that a wasted listing is not done:
2563 ;; 1. When looking for a .dired file in dired-x.el.
2564 ;; 2. The syntax of FILE and DIR make it impossible that FILE could be a valid
2565 ;;     subdirectory. This is of course an OS dependent judgement.
2566
2567 (defmacro ange-ftp-allow-child-lookup (dir file)
2568   (` (not
2569       (let* ((efile (, file)) ; expand once.
2570              (edir (, dir))
2571              (parsed (ange-ftp-ftp-name edir))
2572              (host-type (ange-ftp-host-type
2573                          (car parsed))))
2574         (or
2575 ;;; This variable seems not to exist in Emacs 19 -- rms.
2576 ;;;      ;; Deal with dired
2577 ;;;      (and (boundp 'dired-local-variables-file)
2578 ;;;           (stringp dired-local-variables-file)
2579 ;;;           (string-equal dired-local-variables-file efile))
2580          ;; No dots in dir names in vms.
2581          (and (eq host-type 'vms)
2582               (string-match "\\." efile))
2583          ;; No subdirs in mts of cms.
2584          (and (memq host-type '(mts cms))
2585               (not (string-equal "/" (nth 2 parsed)))))))))
2586
2587 (defun ange-ftp-file-entry-p (name)
2588   "Given NAME, return whether there is a file entry for it."
2589   (let* ((name (directory-file-name name))
2590          (dir (file-name-directory name))
2591          (ent (ange-ftp-get-hash-entry dir ange-ftp-files-hashtable))
2592          (file (ange-ftp-get-file-part name)))
2593     (if ent
2594         (ange-ftp-hash-entry-exists-p file ent)
2595       (or (and (ange-ftp-allow-child-lookup dir file)
2596                (setq ent (ange-ftp-get-files name t))
2597                ;; Try a child lookup. i.e. try to list file as a
2598                ;; subdirectory of dir. This is a good idea because
2599                ;; we may not have read permission for file's parent. Also,
2600                ;; people tend to work down directory trees anyway. We use
2601                ;; no-error ;; because if file does not exist as a subdir.,
2602                ;; then dumb hosts will give an ftp error. Smart unix hosts
2603                ;; will simply send back the ls
2604                ;; error message.
2605                (ange-ftp-get-hash-entry "." ent))
2606           ;; Child lookup failed. Try the parent. If this bombs,
2607           ;; we are at wits end -- signal an error.
2608           ;; Problem: If this signals an error, the error message
2609           ;; may  not have a lot to do with what went wrong.
2610           (ange-ftp-hash-entry-exists-p file
2611                                         (ange-ftp-get-files dir))))))
2612
2613 (defun ange-ftp-get-file-entry (name)
2614   "Given NAME, return the given file entry.
2615 The entry will be either t for a directory, nil for a normal file,
2616 or a string for a symlink. If the file isn't in the hashtable,
2617 this also returns nil."
2618   (let* ((name (directory-file-name name))
2619          (dir (file-name-directory name))
2620          (ent (ange-ftp-get-hash-entry dir ange-ftp-files-hashtable))
2621          (file (ange-ftp-get-file-part name)))
2622     (if ent
2623         (ange-ftp-get-hash-entry file ent)
2624       (or (and (ange-ftp-allow-child-lookup dir file)
2625                (setq ent (ange-ftp-get-files name t))
2626                (ange-ftp-get-hash-entry "." ent))
2627                ;; i.e. it's a directory by child lookup
2628           (ange-ftp-get-hash-entry file
2629                                    (ange-ftp-get-files dir))))))
2630
2631 (defun ange-ftp-internal-delete-file-entry (name &optional dir-p)
2632   (if dir-p
2633       (progn
2634         (setq name (file-name-as-directory name))
2635         (ange-ftp-del-hash-entry name ange-ftp-files-hashtable)
2636         (setq name (directory-file-name name))))
2637   ;; Note that file-name-as-directory followed by directory-file-name
2638   ;; serves to canonicalize directory file names to their unix form.
2639   ;; i.e. in VMS, FOO.DIR -> FOO/ -> FOO
2640   (let ((files (ange-ftp-get-hash-entry (file-name-directory name)
2641                                         ange-ftp-files-hashtable)))
2642     (if files
2643         (ange-ftp-del-hash-entry (ange-ftp-get-file-part name)
2644                                  files))))
2645
2646 (defun ange-ftp-internal-add-file-entry (name &optional dir-p)
2647   (and dir-p
2648        (setq name (directory-file-name name)))
2649   (let ((files (ange-ftp-get-hash-entry (file-name-directory name)
2650                                         ange-ftp-files-hashtable)))
2651     (if files
2652         (ange-ftp-put-hash-entry (ange-ftp-get-file-part name)
2653                                  dir-p
2654                                  files))))
2655
2656 (defun ange-ftp-wipe-file-entries (host user)
2657   "Get rid of entry for HOST, USER pair from file entry information hashtable."
2658   (let ((new-tbl (ange-ftp-make-hashtable (length ange-ftp-files-hashtable))))
2659     (ange-ftp-map-hashtable
2660      (function
2661       (lambda (key val)
2662         (let ((parsed (ange-ftp-ftp-name key)))
2663           (if parsed
2664               (let ((h (nth 0 parsed))
2665                     (u (nth 1 parsed)))
2666                 (or (and (equal host h) (equal user u))
2667                     (ange-ftp-put-hash-entry key val new-tbl)))))))
2668      ange-ftp-files-hashtable)
2669     (setq ange-ftp-files-hashtable new-tbl)))
2670 \f
2671 ;;;; ------------------------------------------------------------
2672 ;;;; File transfer mode support.
2673 ;;;; ------------------------------------------------------------
2674
2675 (defun ange-ftp-set-binary-mode (host user)
2676   "Tell the ftp process for the given HOST & USER to switch to binary mode."
2677   (let ((result (ange-ftp-send-cmd host user '(type "binary"))))
2678     (if (not (car result))
2679         (ange-ftp-error host user (concat "BINARY failed: " (cdr result)))
2680       (save-excursion
2681         (set-buffer (process-buffer (ange-ftp-get-process host user)))
2682         (and ange-ftp-binary-hash-mark-size
2683              (setq ange-ftp-hash-mark-unit
2684                    (ash ange-ftp-binary-hash-mark-size -4)))))))
2685
2686 (defun ange-ftp-set-ascii-mode (host user)
2687   "Tell the ftp process for the given HOST & USER to switch to ascii mode."
2688   (let ((result (ange-ftp-send-cmd host user '(type "ascii"))))
2689     (if (not (car result))
2690         (ange-ftp-error host user (concat "ASCII failed: " (cdr result)))
2691       (save-excursion
2692         (set-buffer (process-buffer (ange-ftp-get-process host user)))
2693         (and ange-ftp-ascii-hash-mark-size
2694              (setq ange-ftp-hash-mark-unit
2695                    (ash ange-ftp-ascii-hash-mark-size -4)))))))
2696 \f
2697 (defun ange-ftp-cd (host user dir)
2698   (let ((result (ange-ftp-send-cmd host user (list 'cd dir) "Doing CD")))
2699     (or (car result)
2700         (ange-ftp-error host user (concat "CD failed: " (cdr result))))))
2701
2702 (defun ange-ftp-get-pwd (host user)
2703   "Attempts to get the current working directory for the given HOST/USER pair.
2704 Returns \( DIR . LINE \) where DIR is either the directory or NIL if not found,
2705 and LINE is the relevant success or fail line from the FTP-client."
2706   (let* ((result (ange-ftp-send-cmd host user '(pwd) "Getting PWD"))
2707          (line (cdr result))
2708          dir)
2709     (if (car result)
2710         (save-match-data
2711           (and (or (string-match "\"\\([^\"]*\\)\"" line)
2712                    (string-match " \\([^ ]+\\) " line)) ; stone-age VMS servers!
2713                (setq dir (substring line
2714                                     (match-beginning 1)
2715                                     (match-end 1))))))
2716     (cons dir line)))
2717 \f
2718 ;;; ------------------------------------------------------------
2719 ;;; expand-file-name and friends...which currently don't work
2720 ;;; ------------------------------------------------------------
2721
2722 (defun ange-ftp-expand-dir (host user dir)
2723   "Return the result of doing a PWD in the current FTP session.
2724 Use the connection to machine HOST
2725 logged in as user USER and cd'd to directory DIR."
2726   (let* ((host-type (ange-ftp-host-type host user))
2727          ;; It is more efficient to call ange-ftp-host-type
2728          ;; before binding res, because ange-ftp-host-type sometimes
2729          ;; adds to the info in the expand-dir-hashtable.
2730          (fix-name-func
2731           (cdr (assq host-type ange-ftp-fix-name-func-alist)))
2732          (key (concat host "/" user "/" dir))
2733          (res (ange-ftp-get-hash-entry key ange-ftp-expand-dir-hashtable)))
2734     (or res
2735         (progn
2736           (or
2737            (string-equal user "anonymous")
2738            (string-equal user "ftp")
2739            (not (eq host-type 'unix))
2740            (let* ((ange-ftp-good-msgs (concat ange-ftp-expand-dir-regexp
2741                                               "\\|"
2742                                               ange-ftp-good-msgs))
2743                   (result (ange-ftp-send-cmd host user
2744                                              (list 'get dir "/dev/null")
2745                                              (format "expanding %s" dir)))
2746                   (line (cdr result)))
2747              (setq res
2748                    (if (string-match ange-ftp-expand-dir-regexp line)
2749                        (substring line
2750                                   (match-beginning 1)
2751                                   (match-end 1))))))
2752           (or res
2753               (if (string-equal dir "~")
2754                   (setq res (car (ange-ftp-get-pwd host user)))
2755                 (let ((home (ange-ftp-expand-dir host user "~")))
2756                   (unwind-protect
2757                       (and (ange-ftp-cd host user dir)
2758                            (setq res (car (ange-ftp-get-pwd host user))))
2759                     (ange-ftp-cd host user home)))))
2760           (if res
2761               (let ((ange-ftp-this-user user)
2762                     (ange-ftp-this-host host))
2763                 (if fix-name-func
2764                     (setq res (funcall fix-name-func res 'reverse)))
2765                 (ange-ftp-put-hash-entry
2766                  key res ange-ftp-expand-dir-hashtable)))
2767           res))))
2768
2769 (defun ange-ftp-canonize-filename (n)
2770   "Take a string and short-circuit //, /. and /.."
2771   (if (string-match "[^:]+//" n)                ;don't upset Apollo users
2772       (setq n (substring n (1- (match-end 0)))))
2773   (let ((parsed (ange-ftp-ftp-name n)))
2774     (if parsed
2775         (let ((host (car parsed))
2776               (user (nth 1 parsed))
2777               (name (nth 2 parsed)))
2778
2779           ;; See if remote name is absolute.  If so then just expand it and
2780           ;; replace the name component of the overall name.
2781           (cond ((string-match "^/" name)
2782                  name)
2783
2784                 ;; Name starts with ~ or ~user.  Resolve that part of the name
2785                 ;; making it absolute then re-expand it.
2786                 ((string-match "^~[^/]*" name)
2787                  (let* ((tilda (substring name
2788                                           (match-beginning 0)
2789                                           (match-end 0)))
2790                         (rest (substring name (match-end 0)))
2791                         (dir (ange-ftp-expand-dir host user tilda)))
2792                    (if dir
2793                        (setq name (concat dir rest))
2794                      (error "User \"%s\" is not known"
2795                             (substring tilda 1)))))
2796
2797                 ;; relative name.  Tack on homedir and re-expand.
2798                 (t
2799                  (let ((dir (ange-ftp-expand-dir host user "~")))
2800                    (if dir
2801                        (setq name (concat
2802                                    (ange-ftp-real-file-name-as-directory dir)
2803                                    name))
2804                      (error "Unable to obtain CWD")))))
2805
2806           ;; If name starts with //, preserve that, for apollo system.
2807           (if (not (string-match "^//" name))
2808               (progn
2809                 (setq name (ange-ftp-real-expand-file-name name))
2810
2811                 (if (string-match "^//" name)
2812                     (setq name (substring name 1)))))
2813
2814           ;; Now substitute the expanded name back into the overall filename.
2815           (ange-ftp-replace-name-component n name))
2816
2817       ;; non-ange-ftp name.  Just expand normally.
2818       (if (eq (string-to-char n) ?/)
2819           (ange-ftp-real-expand-file-name n)
2820         (ange-ftp-real-expand-file-name
2821          (ange-ftp-real-file-name-nondirectory n)
2822          (ange-ftp-real-file-name-directory n))))))
2823
2824 (defun ange-ftp-expand-file-name (name &optional default)
2825   "Documented as original."
2826   (save-match-data
2827     (if (eq (string-to-char name) ?/)
2828         (while (cond ((string-match "[^:]+//" name) ;don't upset Apollo users
2829                       (setq name (substring name (1- (match-end 0)))))
2830                      ((string-match "/~" name)
2831                       (setq name (substring name (1- (match-end 0))))))))
2832     (cond ((eq (string-to-char name) ?~)
2833            (ange-ftp-real-expand-file-name name))
2834           ((eq (string-to-char name) ?/)
2835            (ange-ftp-canonize-filename name))
2836           ((zerop (length name))
2837            (ange-ftp-canonize-filename (or default default-directory)))
2838           ((ange-ftp-canonize-filename
2839             (concat (file-name-as-directory (or default default-directory))
2840                     name))))))
2841 \f
2842 ;;; These are problems--they are currently not enabled.
2843
2844 (defvar ange-ftp-file-name-as-directory-alist nil
2845   "Association list of \( TYPE \. FUNC \) pairs.
2846 FUNC converts a filename to a directory name for the operating
2847 system TYPE.")
2848
2849 (defun ange-ftp-file-name-as-directory (name)
2850   "Documented as original."
2851   (let ((parsed (ange-ftp-ftp-name name)))
2852     (if parsed
2853         (if (string-equal (nth 2 parsed) "")
2854             name
2855           (funcall (or (cdr (assq
2856                              (ange-ftp-host-type (car parsed))
2857                              ange-ftp-file-name-as-directory-alist))
2858                        'ange-ftp-real-file-name-as-directory)
2859                    name))
2860       (ange-ftp-real-file-name-as-directory name))))
2861
2862 (defun ange-ftp-file-name-directory (name)
2863   "Documented as original."
2864   (let ((parsed (ange-ftp-ftp-name name)))
2865     (if parsed
2866         (let ((filename (nth 2 parsed)))
2867           (if (save-match-data
2868                 (string-match "^~[^/]*$" filename))
2869               name
2870             (ange-ftp-replace-name-component
2871              name
2872              (ange-ftp-real-file-name-directory filename))))
2873       (ange-ftp-real-file-name-directory name))))
2874
2875 (defun ange-ftp-file-name-nondirectory (name)
2876   "Documented as original."
2877   (let ((parsed (ange-ftp-ftp-name name)))
2878     (if parsed
2879         (let ((filename (nth 2 parsed)))
2880           (if (save-match-data
2881                 (string-match "^~[^/]*$" filename))
2882               ""
2883             (ange-ftp-real-file-name-nondirectory name)))
2884       (ange-ftp-real-file-name-nondirectory name))))
2885
2886 (defun ange-ftp-directory-file-name (dir)
2887   "Documented as original."
2888   (let ((parsed (ange-ftp-ftp-name dir)))
2889     (if parsed
2890         (ange-ftp-replace-name-component
2891            dir
2892            (ange-ftp-real-directory-file-name (nth 2 parsed)))
2893       (ange-ftp-real-directory-file-name dir))))
2894
2895 \f
2896 ;;; Hooks that handle Emacs primitives.
2897
2898 ;; Returns non-nil if should transfer FILE in binary mode.
2899 (defun ange-ftp-binary-file (file)
2900   (save-match-data
2901     (string-match ange-ftp-binary-file-name-regexp file)))
2902
2903 (defun ange-ftp-write-region (start end filename &optional append visit)
2904   (setq filename (expand-file-name filename))
2905   (let ((parsed (ange-ftp-ftp-name filename)))
2906     (if parsed
2907         (let* ((host (nth 0 parsed))
2908                (user (nth 1 parsed))
2909                (name (ange-ftp-quote-string (nth 2 parsed)))
2910                (temp (ange-ftp-make-tmp-name host))
2911                (binary (or (ange-ftp-binary-file filename)
2912                            (eq (ange-ftp-host-type host user) 'unix)))
2913                (cmd (if append 'append 'put))
2914                (abbr (ange-ftp-abbreviate-filename filename)))
2915           (unwind-protect
2916               (progn
2917                 (let ((executing-macro t)
2918                       (filename (buffer-file-name))
2919                       (mod-p (buffer-modified-p)))
2920                   (unwind-protect
2921                       (ange-ftp-real-write-region start end temp nil visit)
2922                     ;; cleanup forms
2923                     (setq buffer-file-name filename)
2924                     (set-buffer-modified-p mod-p)))
2925                 (if binary
2926                     (ange-ftp-set-binary-mode host user))
2927
2928                 ;; tell the process filter what size the transfer will be.
2929                 (let ((attr (file-attributes temp)))
2930                   (if attr
2931                       (ange-ftp-set-xfer-size host user (nth 7 attr))))
2932
2933                 ;; put or append the file.
2934                 (let ((result (ange-ftp-send-cmd host user
2935                                                  (list cmd temp name)
2936                                                  (format "Writing %s" abbr))))
2937                   (or (car result)
2938                       (signal 'ftp-error
2939                               (list
2940                                "Opening output file"
2941                                (format "FTP Error: \"%s\"" (cdr result))
2942                                filename)))))
2943             (ange-ftp-del-tmp-name temp)
2944             (if binary
2945                 (ange-ftp-set-ascii-mode host user)))
2946           (if (eq visit t)
2947               (progn
2948                 (set-visited-file-modtime '(0 0))
2949                 (ange-ftp-set-buffer-mode)
2950                 (setq buffer-file-name filename)
2951                 (set-buffer-modified-p nil)))
2952           (ange-ftp-message "Wrote %s" abbr)
2953           (ange-ftp-add-file-entry filename))
2954       (ange-ftp-real-write-region start end filename append visit))))
2955
2956 (defun ange-ftp-insert-file-contents (filename &optional visit beg end replace)
2957   (barf-if-buffer-read-only)
2958   (setq filename (expand-file-name filename))
2959   (let ((parsed (ange-ftp-ftp-name filename)))
2960     (if parsed
2961         (progn
2962           (if visit
2963               (setq buffer-file-name filename))
2964           (if (or (file-exists-p filename)
2965                   (progn
2966                     (setq ange-ftp-ls-cache-file nil)
2967                     (ange-ftp-del-hash-entry (file-name-directory filename)
2968                                              ange-ftp-files-hashtable)
2969                     (file-exists-p filename)))
2970               (let* ((host (nth 0 parsed))
2971                      (user (nth 1 parsed))
2972                      (name (ange-ftp-quote-string (nth 2 parsed)))
2973                      (temp (ange-ftp-make-tmp-name host))
2974                      (binary (or (ange-ftp-binary-file filename)
2975                                  (eq (ange-ftp-host-type host user) 'unix)))
2976                      (abbr (ange-ftp-abbreviate-filename filename))
2977                      size)
2978                 (unwind-protect
2979                     (progn
2980                       (if binary
2981                           (ange-ftp-set-binary-mode host user))
2982                       (let ((result (ange-ftp-send-cmd host user
2983                                               (list 'get name temp)
2984                                               (format "Retrieving %s" abbr))))
2985                         (or (car result)
2986                             (signal 'ftp-error
2987                                     (list
2988                                      "Opening input file"
2989                                      (format "FTP Error: \"%s\"" (cdr result))
2990                                      filename))))
2991                       (if (or (ange-ftp-real-file-readable-p temp)
2992                               (sleep-for ange-ftp-retry-time)
2993                               ;; Wait for file to hopefully appear.
2994                               (ange-ftp-real-file-readable-p temp))
2995                           (setq
2996                            size
2997                            (nth 1 (ange-ftp-real-insert-file-contents
2998                                    temp visit beg end replace)))
2999                         (signal 'ftp-error
3000                                 (list
3001                                  "Opening input file:"
3002                                  (format
3003                                   "FTP Error: %s not arrived or readable"
3004                                   filename)))))
3005                   (if binary
3006                       (ange-ftp-set-ascii-mode host user))
3007                   (ange-ftp-del-tmp-name temp))
3008                 (if visit
3009                     (progn
3010                       (set-visited-file-modtime '(0 0))
3011                       (setq buffer-file-name filename)))
3012                 (list filename size))
3013             (signal 'file-error
3014                     (list
3015                      "Opening input file"
3016                      filename))))
3017       (ange-ftp-real-insert-file-contents filename visit beg end replace))))
3018
3019 (defun ange-ftp-expand-symlink (file dir)
3020   (if (file-name-absolute-p file)
3021       (ange-ftp-replace-name-component dir file)
3022     (expand-file-name file dir)))
3023
3024 (defun ange-ftp-file-symlink-p (file)
3025   ;; call ange-ftp-expand-file-name rather than the normal
3026   ;; expand-file-name to stop loops when using a package that
3027   ;; redefines both file-symlink-p and expand-file-name.
3028   (setq file (ange-ftp-expand-file-name file))
3029   (if (ange-ftp-ftp-name file)
3030       (let ((file-ent
3031              (ange-ftp-get-hash-entry
3032               (ange-ftp-get-file-part file)
3033               (ange-ftp-get-files (file-name-directory file)))))
3034         (if (stringp file-ent)
3035             (if (file-name-absolute-p file-ent)
3036                 (ange-ftp-replace-name-component
3037                       (file-name-directory file) file-ent)
3038               file-ent)))
3039     (ange-ftp-real-file-symlink-p file)))
3040
3041 (defun ange-ftp-file-exists-p (name)
3042   (setq name (expand-file-name name))
3043   (if (ange-ftp-ftp-name name)
3044       (if (ange-ftp-file-entry-p name)
3045           (let ((file-ent (ange-ftp-get-file-entry name)))
3046             (if (stringp file-ent)
3047                 (file-exists-p
3048                  (ange-ftp-expand-symlink file-ent
3049                                           (file-name-directory
3050                                            (directory-file-name name))))
3051               t)))
3052     (ange-ftp-real-file-exists-p name)))
3053
3054 (defun ange-ftp-file-directory-p (name)
3055   (setq name (expand-file-name name))
3056   (if (ange-ftp-ftp-name name)
3057       ;; We do a file-name-as-directory on name here because some
3058       ;; machines (VMS) use a .DIR to indicate the filename associated
3059       ;; with a directory. This needs to be canonicalized.
3060       (let ((file-ent (ange-ftp-get-file-entry
3061                        (ange-ftp-file-name-as-directory name))))
3062         (if (stringp file-ent)
3063             (file-directory-p
3064              (ange-ftp-expand-symlink file-ent
3065                                       (file-name-directory
3066                                        (directory-file-name name))))
3067           file-ent))
3068     (ange-ftp-real-file-directory-p name)))
3069
3070 (defun ange-ftp-directory-files (directory &optional full match
3071                                            &rest v19-args)
3072   (setq directory (expand-file-name directory))
3073   (if (ange-ftp-ftp-name directory)
3074       (progn
3075         (ange-ftp-barf-if-not-directory directory)
3076         (let ((tail (ange-ftp-hash-table-keys
3077                      (ange-ftp-get-files directory)))
3078               files f)
3079           (setq directory (file-name-as-directory directory))
3080           (save-match-data
3081             (while tail
3082               (setq f (car tail)
3083                     tail (cdr tail))
3084               (if (or (not match) (string-match match f))
3085                   (setq files
3086                         (cons (if full (concat directory f) f) files)))))
3087           (nreverse files)))
3088     (apply 'ange-ftp-real-directory-files directory full match v19-args)))
3089
3090 (defun ange-ftp-file-attributes (file)
3091   (setq file (expand-file-name file))
3092   (let ((parsed (ange-ftp-ftp-name file)))
3093     (if parsed
3094         (let ((part (ange-ftp-get-file-part file))
3095               (files (ange-ftp-get-files (file-name-directory file))))
3096           (if (ange-ftp-hash-entry-exists-p part files)
3097               (let ((host (nth 0 parsed))
3098                     (user (nth 1 parsed))
3099                     (name (nth 2 parsed))
3100                     (dirp (ange-ftp-get-hash-entry part files)))
3101                 (list (if (and (stringp dirp) (file-name-absolute-p dirp))
3102                           (ange-ftp-expand-symlink dirp
3103                                                    (file-name-directory file))
3104                         dirp)           ;0 file type
3105                       -1                ;1 link count
3106                       -1                ;2 uid
3107                       -1                ;3 gid
3108                       '(0 0)            ;4 atime
3109                       '(0 0)            ;5 mtime
3110                       '(0 0)            ;6 ctime
3111                       -1                ;7 size
3112                       (concat (if (stringp dirp) "l" (if dirp "d" "-"))
3113                               "?????????") ;8 mode
3114                       nil               ;9 gid weird
3115                       ;; Hack to give remote files a unique "inode number".
3116                       ;; It's actually the sum of the characters in its name.
3117                       (apply '+ (nconc (mapcar 'identity host)
3118                                        (mapcar 'identity user)
3119                                        (mapcar 'identity
3120                                                (directory-file-name name))))
3121                       -1                ;11 device number [v19 only]
3122                       ))))
3123       (ange-ftp-real-file-attributes file))))
3124
3125 (defun ange-ftp-file-writable-p (file)
3126   (setq file (expand-file-name file))
3127   (if (ange-ftp-ftp-name file)
3128       (or (file-exists-p file)          ;guess here for speed
3129           (file-directory-p (file-name-directory file)))
3130     (ange-ftp-real-file-writable-p file)))
3131
3132 (defun ange-ftp-file-readable-p (file)
3133   (setq file (expand-file-name file))
3134   (if (ange-ftp-ftp-name file)
3135       (file-exists-p file)
3136     (ange-ftp-real-file-readable-p file)))
3137
3138 (defun ange-ftp-file-executable-p (file)
3139   (setq file (expand-file-name file))
3140   (if (ange-ftp-ftp-name file)
3141       (file-exists-p file)
3142     (ange-ftp-real-file-executable-p file)))
3143
3144 (defun ange-ftp-delete-file (file)
3145   (interactive "fDelete file: ")
3146   (setq file (expand-file-name file))
3147   (let ((parsed (ange-ftp-ftp-name file)))
3148     (if parsed
3149         (let* ((host (nth 0 parsed))
3150                (user (nth 1 parsed))
3151                (name (ange-ftp-quote-string (nth 2 parsed)))
3152                (abbr (ange-ftp-abbreviate-filename file))
3153                (result (ange-ftp-send-cmd host user
3154                                           (list 'delete name)
3155                                           (format "Deleting %s" abbr))))
3156           (or (car result)
3157               (signal 'ftp-error
3158                       (list
3159                        "Removing old name"
3160                        (format "FTP Error: \"%s\"" (cdr result))
3161                        file)))
3162           (ange-ftp-delete-file-entry file))
3163       (ange-ftp-real-delete-file file))))
3164
3165 (defun ange-ftp-verify-visited-file-modtime (buf)
3166   (let ((name (buffer-file-name buf)))
3167     (if (and (stringp name) (ange-ftp-ftp-name name))
3168         t
3169       (ange-ftp-real-verify-visited-file-modtime buf))))
3170 \f
3171 ;;;; ------------------------------------------------------------
3172 ;;;; File copying support... totally re-written 6/24/92.
3173 ;;;; ------------------------------------------------------------
3174
3175 (defun ange-ftp-barf-or-query-if-file-exists (absname querystring interactive)
3176   (if (file-exists-p absname)
3177       (if (not interactive)
3178           (signal 'file-already-exists (list absname))
3179         (if (not (yes-or-no-p (format "File %s already exists; %s anyway? "
3180                                       absname querystring)))
3181             (signal 'file-already-exists (list absname))))))
3182
3183 ;; async local copy commented out for now since I don't seem to get
3184 ;; the process sentinel called for some processes.
3185 ;;
3186 ;; (defun ange-ftp-copy-file-locally (filename newname ok-if-already-exists
3187 ;;                                          keep-date cont)
3188 ;;   "Kludge to copy a local file and call a continuation when the copy
3189 ;; finishes."
3190 ;;   ;; check to see if we can overwrite
3191 ;;   (if (or (not ok-if-already-exists)
3192 ;;        (numberp ok-if-already-exists))
3193 ;;       (ange-ftp-barf-or-query-if-file-exists newname "copy to it"
3194 ;;                                           (numberp ok-if-already-exists)))
3195 ;;   (let ((proc (start-process " *copy*"
3196 ;;                           (generate-new-buffer "*copy*")
3197 ;;                           "cp"
3198 ;;                           filename
3199 ;;                           newname))
3200 ;;      res)
3201 ;;     (set-process-sentinel proc (function ange-ftp-copy-file-locally-sentinel))
3202 ;;     (process-kill-without-query proc)
3203 ;;     (save-excursion
3204 ;;       (set-buffer (process-buffer proc))
3205 ;;       (make-variable-buffer-local 'copy-cont)
3206 ;;       (setq copy-cont cont))))
3207 ;;
3208 ;; (defun ange-ftp-copy-file-locally-sentinel (proc status)
3209 ;;   (save-excursion
3210 ;;     (set-buffer (process-buffer proc))
3211 ;;     (let ((cont copy-cont)
3212 ;;        (result (buffer-string)))
3213 ;;       (unwind-protect
3214 ;;        (if (and (string-equal status "finished\n")
3215 ;;                 (zerop (length result)))
3216 ;;            (ange-ftp-call-cont cont t nil)
3217 ;;          (ange-ftp-call-cont cont
3218 ;;                              nil
3219 ;;                              (if (zerop (length result))
3220 ;;                                  (substring status 0 -1)
3221 ;;                                (substring result 0 -1))))
3222 ;;      (kill-buffer (current-buffer))))))
3223
3224 ;; this is the extended version of ange-ftp-copy-file-internal that works
3225 ;; asynchronously if asked nicely.
3226 (defun ange-ftp-copy-file-internal (filename newname ok-if-already-exists
3227                                              keep-date &optional msg cont nowait)
3228   (setq filename (expand-file-name filename)
3229         newname (expand-file-name newname))
3230
3231   ;; canonicalize newname if a directory.
3232   (if (file-directory-p newname)
3233       (setq newname (expand-file-name (file-name-nondirectory filename) newname)))
3234
3235   (let ((f-parsed (ange-ftp-ftp-name filename))
3236         (t-parsed (ange-ftp-ftp-name newname)))
3237
3238     ;; local file to local file copy?
3239     (if (and (not f-parsed) (not t-parsed))
3240         (progn
3241           (ange-ftp-real-copy-file filename newname ok-if-already-exists
3242                                    keep-date)
3243           (if cont
3244               (ange-ftp-call-cont cont t "Copied locally")))
3245       ;; one or both files are remote.
3246       (let* ((f-host (and f-parsed (nth 0 f-parsed)))
3247              (f-user (and f-parsed (nth 1 f-parsed)))
3248              (f-name (and f-parsed (ange-ftp-quote-string (nth 2 f-parsed))))
3249              (f-abbr (ange-ftp-abbreviate-filename filename))
3250              (t-host (and t-parsed (nth 0 t-parsed)))
3251              (t-user (and t-parsed (nth 1 t-parsed)))
3252              (t-name (and t-parsed (ange-ftp-quote-string (nth 2 t-parsed))))
3253              (t-abbr (ange-ftp-abbreviate-filename newname filename))
3254              (binary (or (ange-ftp-binary-file filename)
3255                          (ange-ftp-binary-file newname)
3256                          (and (eq (ange-ftp-host-type f-host f-user) 'unix)
3257                               (eq (ange-ftp-host-type t-host t-user) 'unix))))
3258              temp1
3259              temp2)
3260
3261         ;; check to see if we can overwrite
3262         (if (or (not ok-if-already-exists)
3263                 (numberp ok-if-already-exists))
3264             (ange-ftp-barf-or-query-if-file-exists newname "copy to it"
3265                                                    (numberp ok-if-already-exists)))
3266
3267         ;; do the copying.
3268         (if f-parsed
3269
3270             ;; filename was remote.
3271             (progn
3272               (if (or (ange-ftp-use-gateway-p f-host)
3273                       t-parsed)
3274                   ;; have to use intermediate file if we are getting via
3275                   ;; gateway machine or we are doing a remote to remote copy.
3276                   (setq temp1 (ange-ftp-make-tmp-name f-host)))
3277
3278               (if binary
3279                   (ange-ftp-set-binary-mode f-host f-user))
3280
3281               (ange-ftp-send-cmd
3282                f-host
3283                f-user
3284                (list 'get f-name (or temp1 newname))
3285                (or msg
3286                    (if (and temp1 t-parsed)
3287                        (format "Getting %s" f-abbr)
3288                      (format "Copying %s to %s" f-abbr t-abbr)))
3289                (list (function ange-ftp-cf1)
3290                      filename newname binary msg
3291                      f-parsed f-host f-user f-name f-abbr
3292                      t-parsed t-host t-user t-name t-abbr
3293                      temp1 temp2 cont nowait)
3294                nowait))
3295
3296           ;; filename wasn't remote.  newname must be remote.  call the
3297           ;; function which does the remainder of the copying work.
3298           (ange-ftp-cf1 t nil
3299                         filename newname binary msg
3300                         f-parsed f-host f-user f-name f-abbr
3301                         t-parsed t-host t-user t-name t-abbr
3302                         nil nil cont nowait))))))
3303
3304 ;; next part of copying routine.
3305 (defun ange-ftp-cf1 (result line
3306                             filename newname binary msg
3307                             f-parsed f-host f-user f-name f-abbr
3308                             t-parsed t-host t-user t-name t-abbr
3309                             temp1 temp2 cont nowait)
3310   (if line
3311       ;; filename must have been remote, and we must have just done a GET.
3312       (unwind-protect
3313           (or result
3314               ;; GET failed for some reason.  Clean up and get out.
3315               (progn
3316                 (and temp1 (ange-ftp-del-tmp-name temp1))
3317                 (or cont
3318                     (signal 'ftp-error (list "Opening input file"
3319                                              (format "FTP Error: \"%s\"" line)
3320                                              filename)))))
3321         ;; cleanup
3322         (if binary
3323             (ange-ftp-set-ascii-mode f-host f-user))))
3324
3325   (if result
3326       ;; We now have to copy either temp1 or filename to newname.
3327       (if t-parsed
3328
3329           ;; newname was remote.
3330           (progn
3331             (if (ange-ftp-use-gateway-p t-host)
3332                 (setq temp2 (ange-ftp-make-tmp-name t-host)))
3333
3334             ;; make sure data is moved into the right place for the
3335             ;; outgoing transfer.  gateway temporary files complicate
3336             ;; things nicely.
3337             (if temp1
3338                 (if temp2
3339                     (if (string-equal temp1 temp2)
3340                         (setq temp1 nil)
3341                       (ange-ftp-real-copy-file temp1 temp2 t))
3342                   (setq temp2 temp1 temp1 nil))
3343               (if temp2
3344                   (ange-ftp-real-copy-file filename temp2 t)))
3345
3346             (if binary
3347                 (ange-ftp-set-binary-mode t-host t-user))
3348
3349             ;; tell the process filter what size the file is.
3350             (let ((attr (file-attributes (or temp2 filename))))
3351               (if attr
3352                   (ange-ftp-set-xfer-size t-host t-user (nth 7 attr))))
3353
3354             (ange-ftp-send-cmd
3355              t-host
3356              t-user
3357              (list 'put (or temp2 filename) t-name)
3358              (or msg
3359                  (if (and temp2 f-parsed)
3360                      (format "Putting %s" newname)
3361                    (format "Copying %s to %s" f-abbr t-abbr)))
3362              (list (function ange-ftp-cf2)
3363                    newname t-host t-user binary temp1 temp2 cont)
3364              nowait))
3365
3366         ;; newname wasn't remote.
3367         (ange-ftp-cf2 t nil newname t-host t-user binary temp1 temp2 cont))
3368
3369     ;; first copy failed, tell caller
3370     (ange-ftp-call-cont cont result line)))
3371
3372 ;; last part of copying routine.
3373 (defun ange-ftp-cf2 (result line newname t-host t-user binary temp1 temp2 cont)
3374   (unwind-protect
3375       (if line
3376           ;; result from doing a local to remote copy.
3377           (unwind-protect
3378               (progn
3379                 (or result
3380                     (or cont
3381                         (signal 'ftp-error
3382                                 (list "Opening output file"
3383                                       (format "FTP Error: \"%s\"" line)
3384                                       newname))))
3385
3386                 (ange-ftp-add-file-entry newname))
3387
3388             ;; cleanup.
3389             (if binary
3390                 (ange-ftp-set-ascii-mode t-host t-user)))
3391
3392         ;; newname was local.
3393         (if temp1
3394             (ange-ftp-real-copy-file temp1 newname t)))
3395
3396     ;; clean up
3397     (and temp1 (ange-ftp-del-tmp-name temp1))
3398     (and temp2 (ange-ftp-del-tmp-name temp2))
3399     (ange-ftp-call-cont cont result line)))
3400
3401 (defun ange-ftp-copy-file (filename newname &optional ok-if-already-exists
3402                                     keep-date)
3403   (interactive "fCopy file: \nFCopy %s to file: \np")
3404   (ange-ftp-copy-file-internal filename
3405                                newname
3406                                ok-if-already-exists
3407                                keep-date
3408                                nil
3409                                nil
3410                                (interactive-p)))
3411 \f
3412 ;;;; ------------------------------------------------------------
3413 ;;;; File renaming support.
3414 ;;;; ------------------------------------------------------------
3415
3416 (defun ange-ftp-rename-remote-to-remote (filename newname f-parsed t-parsed)
3417   "Rename remote file FILE to remote file NEWNAME."
3418   (let ((f-host (nth 0 f-parsed))
3419         (f-user (nth 1 f-parsed))
3420         (t-host (nth 0 t-parsed))
3421         (t-user (nth 1 t-parsed)))
3422     (if (and (string-equal f-host t-host)
3423              (string-equal f-user t-user))
3424         (let* ((f-name (ange-ftp-quote-string (nth 2 f-parsed)))
3425                (t-name (ange-ftp-quote-string (nth 2 t-parsed)))
3426                (cmd (list 'rename f-name t-name))
3427                (fabbr (ange-ftp-abbreviate-filename filename))
3428                (nabbr (ange-ftp-abbreviate-filename newname filename))
3429                (result (ange-ftp-send-cmd f-host f-user cmd
3430                                           (format "Renaming %s to %s"
3431                                                   fabbr
3432                                                   nabbr))))
3433           (or (car result)
3434               (signal 'ftp-error
3435                       (list
3436                        "Renaming"
3437                        (format "FTP Error: \"%s\"" (cdr result))
3438                        filename
3439                        newname)))
3440           (ange-ftp-add-file-entry newname)
3441           (ange-ftp-delete-file-entry filename))
3442       (ange-ftp-copy-file-internal filename newname t nil)
3443       (delete-file filename))))
3444
3445 (defun ange-ftp-rename-local-to-remote (filename newname)
3446   "Rename local FILENAME to remote file NEWNAME."
3447   (let* ((fabbr (ange-ftp-abbreviate-filename filename))
3448          (nabbr (ange-ftp-abbreviate-filename newname filename))
3449          (msg (format "Renaming %s to %s" fabbr nabbr)))
3450     (ange-ftp-copy-file-internal filename newname t nil msg)
3451     (let (ange-ftp-process-verbose)
3452       (delete-file filename))))
3453
3454 (defun ange-ftp-rename-remote-to-local (filename newname)
3455   "Rename remote file FILENAME to local file NEWNAME."
3456   (let* ((fabbr (ange-ftp-abbreviate-filename filename))
3457          (nabbr (ange-ftp-abbreviate-filename newname filename))
3458          (msg (format "Renaming %s to %s" fabbr nabbr)))
3459     (ange-ftp-copy-file-internal filename newname t nil msg)
3460     (let (ange-ftp-process-verbose)
3461       (delete-file filename))))
3462
3463 (defun ange-ftp-rename-file (filename newname &optional ok-if-already-exists)
3464   (interactive "fRename file: \nFRename %s to file: \np")
3465   (setq filename (expand-file-name filename))
3466   (setq newname (expand-file-name newname))
3467   (let* ((f-parsed (ange-ftp-ftp-name filename))
3468          (t-parsed (ange-ftp-ftp-name newname)))
3469     (if (and (or f-parsed t-parsed)
3470              (or (not ok-if-already-exists)
3471                  (numberp ok-if-already-exists)))
3472         (ange-ftp-barf-or-query-if-file-exists
3473          newname
3474          "rename to it"
3475          (numberp ok-if-already-exists)))
3476     (if f-parsed
3477         (if t-parsed
3478             (ange-ftp-rename-remote-to-remote filename newname f-parsed
3479                                               t-parsed)
3480           (ange-ftp-rename-remote-to-local filename newname))
3481       (if t-parsed
3482           (ange-ftp-rename-local-to-remote filename newname)
3483         (ange-ftp-real-rename-file filename newname ok-if-already-exists)))))
3484 \f
3485 ;;;; ------------------------------------------------------------
3486 ;;;; File name completion support.
3487 ;;;; ------------------------------------------------------------
3488
3489 ;; If the file entry SYM is a symlink, returns whether its file exists.
3490 ;; Note that `ange-ftp-this-dir' is used as a free variable.
3491 (defun ange-ftp-file-entry-active-p (sym)
3492   (let ((val (get sym 'val)))
3493     (or (not (stringp val))
3494         (file-exists-p (ange-ftp-expand-symlink val ange-ftp-this-dir)))))
3495
3496 ;; If the file entry is not a directory (nor a symlink pointing to a directory)
3497 ;; returns whether the file (or file pointed to by the symlink) is ignored
3498 ;; by completion-ignored-extensions.
3499 ;; Note that `ange-ftp-this-dir' and `ange-ftp-completion-ignored-pattern'
3500 ;; are used as free variables.
3501 (defun ange-ftp-file-entry-not-ignored-p (sym)
3502   (let ((val (get sym 'val))
3503         (symname (symbol-name sym)))
3504     (if (stringp val)
3505         (let ((file (ange-ftp-expand-symlink val ange-ftp-this-dir)))
3506           (or (file-directory-p file)
3507               (and (file-exists-p file)
3508                    (not (string-match ange-ftp-completion-ignored-pattern
3509                                       symname)))))
3510       (or val ; is a directory name
3511           (not (string-match ange-ftp-completion-ignored-pattern symname))))))
3512
3513 (defun ange-ftp-file-name-all-completions (file dir)
3514   (let ((ange-ftp-this-dir (expand-file-name dir)))
3515     (if (ange-ftp-ftp-name ange-ftp-this-dir)
3516         (progn
3517           (ange-ftp-barf-if-not-directory ange-ftp-this-dir)
3518           (setq ange-ftp-this-dir
3519                 (ange-ftp-real-file-name-as-directory ange-ftp-this-dir))
3520           (let* ((tbl (ange-ftp-get-files ange-ftp-this-dir))
3521                  (completions
3522                   (all-completions file tbl
3523                                    (function ange-ftp-file-entry-active-p))))
3524
3525             ;; see whether each matching file is a directory or not...
3526             (mapcar
3527              (function
3528               (lambda (file)
3529                 (let ((ent (ange-ftp-get-hash-entry file tbl)))
3530                   (if (and ent
3531                            (or (not (stringp ent))
3532                                (file-directory-p
3533                                 (ange-ftp-expand-symlink ent
3534                                                          ange-ftp-this-dir))))
3535                       (concat file "/")
3536                     file))))
3537              completions)))
3538
3539       (if (string-equal "/" ange-ftp-this-dir)
3540           (nconc (all-completions file (ange-ftp-generate-root-prefixes))
3541                  (ange-ftp-real-file-name-all-completions file
3542                                                           ange-ftp-this-dir))
3543         (ange-ftp-real-file-name-all-completions file ange-ftp-this-dir)))))
3544
3545 (defun ange-ftp-file-name-completion (file dir)
3546   (let ((ange-ftp-this-dir (expand-file-name dir)))
3547     (if (ange-ftp-ftp-name ange-ftp-this-dir)
3548         (progn
3549           (ange-ftp-barf-if-not-directory ange-ftp-this-dir)
3550           (if (equal file "")
3551               ""
3552             (setq ange-ftp-this-dir
3553                   (ange-ftp-real-file-name-as-directory ange-ftp-this-dir))     ;real?
3554             (let* ((tbl (ange-ftp-get-files ange-ftp-this-dir))
3555                    (ange-ftp-completion-ignored-pattern
3556                     (mapconcat (function
3557                                 (lambda (s) (if (stringp s)
3558                                                 (concat (regexp-quote s) "$")
3559                                               "/"))) ; / never in filename
3560                                completion-ignored-extensions
3561                                "\\|")))
3562               (save-match-data
3563                 (or (ange-ftp-file-name-completion-1
3564                      file tbl ange-ftp-this-dir
3565                      (function ange-ftp-file-entry-not-ignored-p))
3566                     (ange-ftp-file-name-completion-1
3567                      file tbl ange-ftp-this-dir
3568                      (function ange-ftp-file-entry-active-p)))))))
3569
3570       (if (string-equal "/" ange-ftp-this-dir)
3571           (try-completion
3572            file
3573            (nconc (ange-ftp-generate-root-prefixes)
3574                   (mapcar 'list
3575                           (ange-ftp-real-file-name-all-completions file "/"))))
3576         (ange-ftp-real-file-name-completion file ange-ftp-this-dir)))))
3577
3578
3579 (defun ange-ftp-file-name-completion-1 (file tbl dir predicate)
3580   (let ((bestmatch (try-completion file tbl predicate)))
3581     (if bestmatch
3582         (if (eq bestmatch t)
3583             (if (file-directory-p (expand-file-name file dir))
3584                 (concat file "/")
3585               t)
3586           (if (and (eq (try-completion bestmatch tbl predicate) t)
3587                    (file-directory-p
3588                     (expand-file-name bestmatch dir)))
3589               (concat bestmatch "/")
3590             bestmatch)))))
3591
3592 ;; Put these lines uncommmented in your .emacs if you want C-r to refresh
3593 ;; ange-ftp's cache whilst doing filename completion.
3594 ;;
3595 ;;(define-key minibuffer-local-completion-map "\C-r" 'ange-ftp-re-read-dir)
3596 ;;(define-key minibuffer-local-must-match-map "\C-r" 'ange-ftp-re-read-dir)
3597
3598 ;; Force a re-read of the directory DIR.  If DIR is omitted then it defaults
3599 ;; to the directory part of the contents of the current buffer.
3600 (defun ange-ftp-re-read-dir (&optional dir)
3601   (interactive)
3602   (if dir
3603       (setq dir (expand-file-name dir))
3604     (setq dir (file-name-directory (expand-file-name (buffer-string)))))
3605   (if (ange-ftp-ftp-name dir)
3606       (progn
3607         (setq ange-ftp-ls-cache-file nil)
3608         (ange-ftp-del-hash-entry dir ange-ftp-files-hashtable)
3609         (ange-ftp-get-files dir t))))
3610 \f
3611 (defun ange-ftp-make-directory (dir &optional parents)
3612   (interactive (list (expand-file-name (read-file-name "Make directory: "))))
3613   (if parents
3614       (let ((parent (file-name-directory (directory-file-name dir))))
3615         (or (file-exists-p parent)
3616             (ange-ftp-make-directory parent parents))))
3617   (if (file-exists-p dir)
3618       (error "Cannot make directory %s: file already exists" dir)
3619     (let ((parsed (ange-ftp-ftp-name dir)))
3620       (if parsed
3621           (let* ((host (nth 0 parsed))
3622                  (user (nth 1 parsed))
3623                  ;; Some ftp's on unix machines (at least on Suns)
3624                  ;; insist that mkdir take a filename, and not a
3625                  ;; directory-name name as an arg. Argh!! This is a bug.
3626                  ;; Non-unix machines will probably always insist
3627                  ;; that mkdir takes a directory-name as an arg
3628                  ;; (as the ftp man page says it should).
3629                  (name (ange-ftp-quote-string
3630                         (if (eq (ange-ftp-host-type host) 'unix)
3631                             (ange-ftp-real-directory-file-name (nth 2 parsed))
3632                           (ange-ftp-real-file-name-as-directory
3633                            (nth 2 parsed)))))
3634                  (abbr (ange-ftp-abbreviate-filename dir))
3635                  (result (ange-ftp-send-cmd host user
3636                                             (list 'mkdir name)
3637                                             (format "Making directory %s"
3638                                                     abbr))))
3639             (or (car result)
3640                 (ange-ftp-error host user
3641                                 (format "Could not make directory %s: %s"
3642                                         dir
3643                                         (cdr result))))
3644             (ange-ftp-add-file-entry dir t))
3645         (ange-ftp-real-make-directory dir)))))
3646
3647 (defun ange-ftp-delete-directory (dir)
3648   (if (file-directory-p dir)
3649       (let ((parsed (ange-ftp-ftp-name dir)))
3650         (if parsed
3651             (let* ((host (nth 0 parsed))
3652                    (user (nth 1 parsed))
3653                    ;; Some ftp's on unix machines (at least on Suns)
3654                    ;; insist that rmdir take a filename, and not a
3655                    ;; directory-name name as an arg. Argh!! This is a bug.
3656                    ;; Non-unix machines will probably always insist
3657                    ;; that rmdir takes a directory-name as an arg
3658                    ;; (as the ftp man page says it should).
3659                    (name (ange-ftp-quote-string
3660                           (if (eq (ange-ftp-host-type host) 'unix)
3661                               (ange-ftp-real-directory-file-name
3662                                (nth 2 parsed))
3663                             (ange-ftp-real-file-name-as-directory
3664                              (nth 2 parsed)))))
3665                   (abbr (ange-ftp-abbreviate-filename dir))
3666                   (result (ange-ftp-send-cmd host user
3667                                              (list 'rmdir name)
3668                                              (format "Removing directory %s"
3669                                                      abbr))))
3670               (or (car result)
3671                   (ange-ftp-error host user
3672                                   (format "Could not remove directory %s: %s"
3673                                           dir
3674                                           (cdr result))))
3675               (ange-ftp-delete-file-entry dir t))
3676           (ange-ftp-real-delete-directory dir)))
3677     (error "Not a directory: %s" dir)))
3678 \f
3679 ;; Make a local copy of FILE and return its name.
3680
3681 (defun ange-ftp-file-local-copy (file)
3682   (let* ((fn1 (expand-file-name file))
3683          (pa1 (ange-ftp-ftp-name fn1)))
3684     (if pa1
3685         (let ((tmp1 (ange-ftp-make-tmp-name (car pa1))))
3686           (ange-ftp-copy-file-internal fn1 tmp1 t nil
3687                                        (format "Getting %s" fn1))
3688           tmp1))))
3689
3690 (defun ange-ftp-load (file &optional noerror nomessage nosuffix)
3691   (if (ange-ftp-ftp-name file)
3692       (let ((tryfiles (if nosuffix
3693                           (list file)
3694                         (list (concat file ".elc") (concat file ".el") file)))
3695             copy)
3696         (while (and tryfiles (not copy))
3697           (condition-case error
3698               (setq copy (ange-ftp-file-local-copy (car tryfiles)))
3699             (ftp-error nil)))
3700         (if copy
3701             (unwind-protect
3702                 (funcall 'load copy noerror nomessage nosuffix)
3703               (delete-file copy))
3704           (or noerror
3705               (signal 'file-error (list "Cannot open load file" file)))))
3706     (ange-ftp-real-load file noerror nomessage nosuffix)))
3707
3708 ;; Calculate default-unhandled-directory for a given ange-ftp buffer.
3709 (defun ange-ftp-unhandled-file-name-directory (filename)
3710   (file-name-directory ange-ftp-tmp-name-template))
3711
3712 \f
3713 ;; Need the following functions for making filenames of compressed
3714 ;; files, because some OS's (unlike UNIX) do not allow a filename to
3715 ;; have two extensions.
3716
3717 (defvar ange-ftp-make-compressed-filename-alist nil
3718   "Alist of host-type-specific functions to process file names for compression.
3719 Each element has the form (TYPE . FUNC).
3720 FUNC should take one argument, a file name, and return a list
3721 of the form (COMPRESSING NEWNAME).
3722 COMPRESSING should be t if the specified file should be compressed,
3723 and nil if it should be uncompressed (that is, if it is a compressed file).
3724 NEWNAME should be the name to give the new compressed or uncompressed file.")
3725
3726 (defun ange-ftp-dired-compress-file (name)
3727   (let ((parsed (ange-ftp-ftp-name name))
3728         conversion-func)
3729     (if (and parsed
3730              (setq conversion-func
3731                    (cdr (assq (ange-ftp-host-type (car parsed))
3732                               ange-ftp-make-compressed-filename-alist))))
3733         (let* ((decision
3734                 (save-match-data (funcall conversion-func name)))
3735                (compressing (car decision))
3736                (newfile (nth 1 decision)))
3737           (if compressing
3738               (ange-ftp-compress name newfile)
3739             (ange-ftp-uncompress name newfile)))
3740       (let (file-name-handler-alist)
3741         (dired-compress-file name)))))
3742
3743 ;; Copy FILE to this machine, compress it, and copy out to NFILE.
3744 (defun ange-ftp-compress (file nfile)
3745   (let* ((parsed (ange-ftp-ftp-name file))
3746          (tmp1 (ange-ftp-make-tmp-name (car parsed)))
3747          (tmp2 (ange-ftp-make-tmp-name (car parsed)))
3748          (abbr (ange-ftp-abbreviate-filename file))
3749          (nabbr (ange-ftp-abbreviate-filename nfile))
3750          (msg1 (format "Getting %s" abbr))
3751          (msg2 (format "Putting %s" nabbr)))
3752     (unwind-protect
3753         (progn
3754           (ange-ftp-copy-file-internal file tmp1 t nil msg1)
3755           (and ange-ftp-process-verbose
3756                (ange-ftp-message "Compressing %s..." abbr))
3757           (call-process-region (point)
3758                                (point)
3759                                shell-file-name
3760                                nil
3761                                t
3762                                nil
3763                                "-c"
3764                                (format "compress -f -c < %s > %s" tmp1 tmp2))
3765           (and ange-ftp-process-verbose
3766                (ange-ftp-message "Compressing %s...done" abbr))
3767           (if (zerop (buffer-size))
3768               (progn
3769                 (let (ange-ftp-process-verbose)
3770                   (delete-file file))
3771                 (ange-ftp-copy-file-internal tmp2 nfile t nil msg2))))
3772       (ange-ftp-del-tmp-name tmp1)
3773       (ange-ftp-del-tmp-name tmp2))))
3774
3775 ;; Copy FILE to this machine, uncompress it, and copy out to NFILE.
3776 (defun ange-ftp-uncompress (file nfile)
3777   (let* ((parsed (ange-ftp-ftp-name file))
3778          (tmp1 (ange-ftp-make-tmp-name (car parsed)))
3779          (tmp2 (ange-ftp-make-tmp-name (car parsed)))
3780          (abbr (ange-ftp-abbreviate-filename file))
3781          (nabbr (ange-ftp-abbreviate-filename nfile))
3782          (msg1 (format "Getting %s" abbr))
3783          (msg2 (format "Putting %s" nabbr))
3784 ;;       ;; Cheap hack because of problems with binary file transfers from
3785 ;;       ;; VMS hosts.
3786 ;;       (gbinary (not (eq 'vms (ange-ftp-host-type (car parsed)))))
3787          )
3788     (unwind-protect
3789         (progn
3790           (ange-ftp-copy-file-internal file tmp1 t nil msg1)
3791           (and ange-ftp-process-verbose
3792                (ange-ftp-message "Uncompressing %s..." abbr))
3793           (call-process-region (point)
3794                                (point)
3795                                shell-file-name
3796                                nil
3797                                t
3798                                nil
3799                                "-c"
3800                                (format "uncompress -c < %s > %s" tmp1 tmp2))
3801           (and ange-ftp-process-verbose
3802                (ange-ftp-message "Uncompressing %s...done" abbr))
3803           (if (zerop (buffer-size))
3804               (progn
3805                 (let (ange-ftp-process-verbose)
3806                   (delete-file file))
3807                 (ange-ftp-copy-file-internal tmp2 nfile t nil msg2))))
3808       (ange-ftp-del-tmp-name tmp1)
3809       (ange-ftp-del-tmp-name tmp2))))
3810
3811 (defun ange-ftp-find-backup-file-name (fn)
3812   ;; Either return the ordinary backup name, etc.,
3813   ;; or return nil meaning don't make a backup.
3814   (if ange-ftp-make-backup-files
3815       (ange-ftp-real-find-backup-file-name fn)))
3816 \f
3817 ;;; Define the handler for special file names
3818 ;;; that causes ange-ftp to be invoked.
3819
3820 ;;;###autoload
3821 (defun ange-ftp-hook-function (operation &rest args)
3822   (let ((fn (get operation 'ange-ftp)))
3823     (if fn (apply fn args)
3824       (ange-ftp-run-real-handler operation args))))
3825
3826
3827 ;;; This regexp takes care of real ange-ftp file names (with a slash
3828 ;;; and colon).
3829 ;;; Don't allow the host name to end in a period--some systems use /.:
3830 ;;;###autoload
3831 (or (assoc "^/[^/:]*[^/:.]:" file-name-handler-alist)
3832     (setq file-name-handler-alist
3833           (cons '("^/[^/:]*[^/:.]:" . ange-ftp-hook-function)
3834                 file-name-handler-alist)))
3835
3836 ;;; This regexp recognizes and absolute filenames with only one component,
3837 ;;; for the sake of hostname completion.
3838 ;;;###autoload
3839 (or (assoc "^/[^/:]*\\'" file-name-handler-alist)
3840     (setq file-name-handler-alist
3841           (cons '("^/[^/:]*\\'" . ange-ftp-completion-hook-function)
3842                 file-name-handler-alist)))
3843
3844 ;;; The above two forms are sufficient to cause this file to be loaded
3845 ;;; if the user ever uses a file name with a colon in it.
3846
3847 ;;; This sets the mode
3848 (or (memq 'ange-ftp-set-buffer-mode find-file-hooks)
3849     (setq find-file-hooks
3850           (cons 'ange-ftp-set-buffer-mode find-file-hooks)))
3851
3852 ;;; Now say where to find the handlers for particular operations.
3853
3854 (put 'file-name-directory 'ange-ftp 'ange-ftp-file-name-directory)
3855 (put 'file-name-nondirectory 'ange-ftp 'ange-ftp-file-name-nondirectory)
3856 (put 'file-name-as-directory 'ange-ftp 'ange-ftp-file-name-as-directory)
3857 (put 'directory-file-name 'ange-ftp 'ange-ftp-directory-file-name)
3858 (put 'expand-file-name 'ange-ftp 'ange-ftp-expand-file-name)
3859 (put 'make-directory 'ange-ftp 'ange-ftp-make-directory)
3860 (put 'delete-directory 'ange-ftp 'ange-ftp-delete-directory)
3861 (put 'insert-file-contents 'ange-ftp 'ange-ftp-insert-file-contents)
3862 (put 'directory-files 'ange-ftp 'ange-ftp-directory-files)
3863 (put 'file-directory-p 'ange-ftp 'ange-ftp-file-directory-p)
3864 (put 'file-writable-p 'ange-ftp 'ange-ftp-file-writable-p)
3865 (put 'file-readable-p 'ange-ftp 'ange-ftp-file-readable-p)
3866 (put 'file-executable-p 'ange-ftp 'ange-ftp-file-executable-p)
3867 (put 'file-symlink-p 'ange-ftp 'ange-ftp-file-symlink-p)
3868 (put 'delete-file 'ange-ftp 'ange-ftp-delete-file)
3869 (put 'read-file-name-internal 'ange-ftp 'ange-ftp-read-file-name-internal)
3870 (put 'verify-visited-file-modtime 'ange-ftp
3871      'ange-ftp-verify-visited-file-modtime)
3872 (put 'file-exists-p 'ange-ftp 'ange-ftp-file-exists-p)
3873 (put 'write-region 'ange-ftp 'ange-ftp-write-region)
3874 (put 'backup-buffer 'ange-ftp 'ange-ftp-backup-buffer)
3875 (put 'copy-file 'ange-ftp 'ange-ftp-copy-file)
3876 (put 'rename-file 'ange-ftp 'ange-ftp-rename-file)
3877 (put 'file-attributes 'ange-ftp 'ange-ftp-file-attributes)
3878 (put 'file-name-all-completions 'ange-ftp 'ange-ftp-file-name-all-completions)
3879 (put 'file-name-completion 'ange-ftp 'ange-ftp-file-name-completion)
3880 (put 'insert-directory 'ange-ftp 'ange-ftp-insert-directory)
3881 (put 'file-local-copy 'ange-ftp 'ange-ftp-file-local-copy)
3882 (put 'unhandled-file-name-directory 'ange-ftp
3883      'ange-ftp-unhandled-file-name-directory)
3884 (put 'file-name-sans-versions 'ange-ftp 'ange-ftp-file-name-sans-versions)
3885 (put 'dired-uncache 'ange-ftp 'ange-ftp-dired-uncache)
3886 (put 'dired-compress-file 'ange-ftp 'ange-ftp-dired-compress-file)
3887 (put 'load 'ange-ftp 'ange-ftp-load)
3888 (put 'find-backup-file-name 'ange-ftp 'ange-ftp-find-backup-file-name)
3889
3890 ;; Turn off truename processing to save time.
3891 ;; Treat each name as its own truename.
3892 (put 'file-truename 'ange-ftp 'identity)
3893
3894 ;; Turn off RCS/SCCS processing to save time.
3895 ;; This returns nil for any file name as argument.
3896 (put 'vc-registered 'ange-ftp 'null)
3897 \f
3898 ;;; Define ways of getting at unmodified Emacs primitives,
3899 ;;; turning off our handler.
3900
3901 (defun ange-ftp-run-real-handler (operation args)
3902   (let ((inhibit-file-name-handlers
3903          (cons 'ange-ftp-hook-function
3904                (cons 'ange-ftp-completion-hook-function
3905                      (and (eq inhibit-file-name-operation operation)
3906                           inhibit-file-name-handlers))))
3907         (inhibit-file-name-operation operation))
3908     (apply operation args)))
3909
3910 (defun ange-ftp-real-file-name-directory (&rest args)
3911   (ange-ftp-run-real-handler 'file-name-directory args))
3912 (defun ange-ftp-real-file-name-nondirectory (&rest args)
3913   (ange-ftp-run-real-handler 'file-name-nondirectory args))
3914 (defun ange-ftp-real-file-name-as-directory (&rest args)
3915   (ange-ftp-run-real-handler 'file-name-as-directory args))
3916 (defun ange-ftp-real-directory-file-name (&rest args)
3917   (ange-ftp-run-real-handler 'directory-file-name args))
3918 (defun ange-ftp-real-expand-file-name (&rest args)
3919   (ange-ftp-run-real-handler 'expand-file-name args))
3920 (defun ange-ftp-real-make-directory (&rest args)
3921   (ange-ftp-run-real-handler 'make-directory args))
3922 (defun ange-ftp-real-delete-directory (&rest args)
3923   (ange-ftp-run-real-handler 'delete-directory args))
3924 (defun ange-ftp-real-insert-file-contents (&rest args)
3925   (ange-ftp-run-real-handler 'insert-file-contents args))
3926 (defun ange-ftp-real-directory-files (&rest args)
3927   (ange-ftp-run-real-handler 'directory-files args))
3928 (defun ange-ftp-real-file-directory-p (&rest args)
3929   (ange-ftp-run-real-handler 'file-directory-p args))
3930 (defun ange-ftp-real-file-writable-p (&rest args)
3931   (ange-ftp-run-real-handler 'file-writable-p args))
3932 (defun ange-ftp-real-file-readable-p (&rest args)
3933   (ange-ftp-run-real-handler 'file-readable-p args))
3934 (defun ange-ftp-real-file-executable-p (&rest args)
3935   (ange-ftp-run-real-handler 'file-executable-p args))
3936 (defun ange-ftp-real-file-symlink-p (&rest args)
3937   (ange-ftp-run-real-handler 'file-symlink-p args))
3938 (defun ange-ftp-real-delete-file (&rest args)
3939   (ange-ftp-run-real-handler 'delete-file args))
3940 (defun ange-ftp-real-read-file-name-internal (&rest args)
3941   (ange-ftp-run-real-handler 'read-file-name-internal args))
3942 (defun ange-ftp-real-verify-visited-file-modtime (&rest args)
3943   (ange-ftp-run-real-handler 'verify-visited-file-modtime args))
3944 (defun ange-ftp-real-file-exists-p (&rest args)
3945   (ange-ftp-run-real-handler 'file-exists-p args))
3946 (defun ange-ftp-real-write-region (&rest args)
3947   (ange-ftp-run-real-handler 'write-region args))
3948 (defun ange-ftp-real-backup-buffer (&rest args)
3949   (ange-ftp-run-real-handler 'backup-buffer args))
3950 (defun ange-ftp-real-copy-file (&rest args)
3951   (ange-ftp-run-real-handler 'copy-file args))
3952 (defun ange-ftp-real-rename-file (&rest args)
3953   (ange-ftp-run-real-handler 'rename-file args))
3954 (defun ange-ftp-real-file-attributes (&rest args)
3955   (ange-ftp-run-real-handler 'file-attributes args))
3956 (defun ange-ftp-real-file-name-all-completions (&rest args)
3957   (ange-ftp-run-real-handler 'file-name-all-completions args))
3958 (defun ange-ftp-real-file-name-completion (&rest args)
3959   (ange-ftp-run-real-handler 'file-name-completion args))
3960 (defun ange-ftp-real-insert-directory (&rest args)
3961   (ange-ftp-run-real-handler 'insert-directory args))
3962 (defun ange-ftp-real-file-name-sans-versions (&rest args)
3963   (ange-ftp-run-real-handler 'file-name-sans-versions args))
3964 (defun ange-ftp-real-shell-command (&rest args)
3965   (ange-ftp-run-real-handler 'shell-command args))
3966 (defun ange-ftp-real-load (&rest args)
3967   (ange-ftp-run-real-handler 'load args))
3968 (defun ange-ftp-real-find-backup-file-name (&rest args)
3969   (ange-ftp-run-real-handler 'find-backup-file-name args))
3970 \f
3971 ;; Here we support using dired on remote hosts.
3972 ;; I have turned off the support for using dired on foreign directory formats.
3973 ;; That involves too many unclean hooks.
3974 ;; It would be cleaner to support such operations by
3975 ;; converting the foreign directory format to something dired can understand;
3976 ;; something close to ls -l output.
3977 ;; The logical place to do this is in the functions ange-ftp-parse-...-listing.
3978
3979 ;; Some of the old dired hooks would still be needed even if this is done.
3980 ;; I have preserved (and modernized) those hooks.
3981 ;; So the format conversion should be all that is needed.
3982
3983 (defun ange-ftp-insert-directory (file switches &optional wildcard full)
3984   (let ((short (ange-ftp-abbreviate-filename file))
3985         (parsed (ange-ftp-ftp-name (expand-file-name file))))
3986     (if parsed
3987         (insert
3988          (if wildcard
3989              (let ((default-directory (file-name-directory file)))
3990                (ange-ftp-ls (file-name-nondirectory file) switches nil nil t))
3991            (ange-ftp-ls file switches full)))
3992       (ange-ftp-real-insert-directory file switches wildcard full))))
3993
3994 (defun ange-ftp-dired-uncache (dir)
3995   (if (ange-ftp-ftp-name (expand-file-name dir))
3996       (setq ange-ftp-ls-cache-file nil)))
3997
3998 (defvar ange-ftp-sans-version-alist nil
3999   "Alist of mapping host type into function to remove file version numbers.")
4000
4001 (defun ange-ftp-file-name-sans-versions (file keep-backup-version)
4002   (setq file (ange-ftp-abbreviate-filename file))
4003   (let ((parsed (ange-ftp-ftp-name file))
4004         host-type func)
4005     (if parsed
4006         (setq host-type (ange-ftp-host-type (car parsed))
4007               func (cdr (assq (ange-ftp-host-type (car parsed))
4008                               ange-ftp-sans-version-alist))))
4009     (if func (funcall func file keep-backup-version)
4010       (ange-ftp-real-file-name-sans-versions file keep-backup-version))))
4011
4012 ;;; This doesn't work yet; a new hook needs to be created.
4013 ;;; Maybe the new hook should be in call-process.
4014 (defun ange-ftp-shell-command (command)
4015   (let* ((parsed (ange-ftp-ftp-name default-directory))
4016          (host (nth 0 parsed))
4017          (user (nth 1 parsed))
4018          (name (nth 2 parsed)))
4019     (if (not parsed)
4020         (ange-ftp-real-shell-command command)
4021       (if (> (length name) 0)           ; else it's $HOME
4022           (setq command (concat "cd " name "; " command)))
4023       (setq command
4024             (format  "%s %s \"%s\""     ; remsh -l USER does not work well
4025                                         ; on a hp-ux machine I tried
4026                      remote-shell-program host command))
4027       (ange-ftp-message "Remote command '%s' ..." command)
4028       ;; Cannot call ange-ftp-real-dired-run-shell-command here as it
4029       ;; would prepend "cd default-directory" --- which bombs because
4030       ;; default-directory is in ange-ftp syntax for remote file names.
4031       (ange-ftp-real-shell-command command))))
4032
4033 ;;; Thisis not hooked up yet.
4034 (defun ange-ftp-dired-call-process (program discard &rest arguments)
4035   ;; PROGRAM is always one of those below in the cond in dired.el.
4036   ;; The ARGUMENTS are (nearly) always files.
4037   (if (ange-ftp-ftp-name default-directory)
4038       ;; Can't use ange-ftp-dired-host-type here because the current
4039       ;; buffer is *dired-check-process output*
4040       (condition-case oops
4041           (cond ((equal "chmod" program)
4042                  (ange-ftp-call-chmod arguments))
4043                 ;; ((equal "chgrp" program))
4044                 ;; ((equal dired-chown-program program))
4045                 (t (error "Unknown remote command: %s" program)))
4046         (ftp-error (insert (format "%s: %s, %s\n"
4047                                     (nth 1 oops)
4048                                     (nth 2 oops)
4049                                     (nth 3 oops))))
4050         (error (insert (format "%s\n" (nth 1 oops)))))
4051     (apply 'call-process program nil (not discard) nil arguments)))
4052
4053 ;;; This currently does not work; it is never called.
4054 (defun ange-ftp-call-chmod (args)
4055   (if (< (length args) 2)
4056       (error "ange-ftp-call-chmod: missing mode and/or filename: %s" args))
4057   (let ((mode (car args)))
4058     (mapcar
4059      (function
4060       (lambda (file)
4061         (setq file (expand-file-name file))
4062         (let ((parsed (ange-ftp-ftp-name file)))
4063           (if parsed
4064               (let* ((host (nth 0 parsed))
4065                      (user (nth 1 parsed))
4066                      (name (ange-ftp-quote-string (nth 2 parsed)))
4067                      (abbr (ange-ftp-abbreviate-filename file))
4068                      (result (ange-ftp-send-cmd host user
4069                                                 (list 'chmod mode name)
4070                                                 (format "doing chmod %s"
4071                                                         abbr))))
4072                 (or (car result)
4073                     (ange-ftp-error host user
4074                                     (format "chmod: %s: \"%s\""
4075                                             file
4076                                             (cdr result)))))))))
4077      (cdr args)))
4078   (setq ange-ftp-ls-cache-file nil))    ;stop confusing dired
4079 \f
4080 ;;; This is turned off because it has nothing properly to do
4081 ;;; with dired.  It could be reasonable to adapt this to
4082 ;;; replace ange-ftp-copy-file.
4083
4084 ;;;;; ------------------------------------------------------------
4085 ;;;;; Noddy support for async copy-file within dired.
4086 ;;;;; ------------------------------------------------------------
4087
4088 ;;(defun ange-ftp-dired-copy-file (from to ok-flag &optional cont nowait)
4089 ;;  "Documented as original."
4090 ;;  (dired-handle-overwrite to)
4091 ;;  (ange-ftp-copy-file-internal from to ok-flag dired-copy-preserve-time nil
4092 ;;                             cont nowait))
4093
4094 ;;(defun ange-ftp-dired-do-create-files (op-symbol file-creator operation arg
4095 ;;                                               &optional marker-char op1
4096 ;;                                               how-to)
4097 ;;  "Documented as original."
4098 ;;  ;; we need to let ange-ftp-dired-create-files know that we indirectly
4099 ;;  ;; called it rather than somebody else.
4100 ;;  (let ((ange-ftp-dired-do-create-files t)) ; tell who caller is
4101 ;;    (ange-ftp-real-dired-do-create-files op-symbol file-creator operation
4102 ;;                                       arg marker-char op1 how-to)))
4103
4104 ;;(defun ange-ftp-dired-create-files (file-creator operation fn-list name-constructor
4105 ;;                                               &optional marker-char)
4106 ;;  "Documented as original."
4107 ;;  (if (and (boundp 'ange-ftp-dired-do-create-files)
4108 ;;         ;; called from ange-ftp-dired-do-create-files?
4109 ;;         ange-ftp-dired-do-create-files
4110 ;;         ;; any files worth copying?
4111 ;;         fn-list
4112 ;;         ;; we only support async copy-file at the mo.
4113 ;;         (eq file-creator 'dired-copy-file)
4114 ;;         ;; it is only worth calling the alternative function for remote files
4115 ;;         ;; as we tie ourself in recursive knots otherwise.
4116 ;;         (or (ange-ftp-ftp-name (car fn-list))
4117 ;;             ;; we can only call the name constructor for dired-do-create-files
4118 ;;             ;; since the one for regexps starts prompting here, there and
4119 ;;             ;; everywhere.
4120 ;;             (ange-ftp-ftp-name (funcall name-constructor (car fn-list)))))
4121 ;;      ;; use the process-filter driven routine rather than the iterative one.
4122 ;;      (ange-ftp-dcf-1 file-creator
4123 ;;                    operation
4124 ;;                    fn-list
4125 ;;                    name-constructor
4126 ;;                    (and (boundp 'target) target)     ;dynamically bound
4127 ;;                    marker-char
4128 ;;                    (current-buffer)
4129 ;;                    nil       ;overwrite-query
4130 ;;                    nil       ;overwrite-backup-query
4131 ;;                    nil       ;failures
4132 ;;                    nil       ;skipped
4133 ;;                    0         ;success-count
4134 ;;                    (length fn-list) ;total
4135 ;;                    )
4136 ;;    ;; normal case... use the interactive routine... much cheaper.
4137 ;;    (ange-ftp-real-dired-create-files file-creator operation fn-list
4138 ;;                                    name-constructor marker-char)))
4139
4140 ;;(defun ange-ftp-dcf-1 (file-creator operation fn-list name-constructor
4141 ;;                     target marker-char buffer overwrite-query
4142 ;;                     overwrite-backup-query failures skipped
4143 ;;                     success-count total)
4144 ;;  (let ((old-buf (current-buffer)))
4145 ;;    (unwind-protect
4146 ;;      (progn
4147 ;;        (set-buffer buffer)
4148 ;;        (if (null fn-list)
4149 ;;            (ange-ftp-dcf-3 failures operation total skipped
4150 ;;                            success-count buffer)
4151
4152 ;;          (let* ((from (car fn-list))
4153 ;;                 (to (funcall name-constructor from)))
4154 ;;            (if (equal to from)
4155 ;;                (progn
4156 ;;                  (setq to nil)
4157 ;;                  (dired-log "Cannot %s to same file: %s\n"
4158 ;;                             (downcase operation) from)))
4159 ;;            (if (not to)
4160 ;;                (ange-ftp-dcf-1 file-creator
4161 ;;                                operation
4162 ;;                                (cdr fn-list)
4163 ;;                                name-constructor
4164 ;;                                target
4165 ;;                                marker-char
4166 ;;                                buffer
4167 ;;                                overwrite-query
4168 ;;                                overwrite-backup-query
4169 ;;                                failures
4170 ;;                                (cons (dired-make-relative from) skipped)
4171 ;;                                success-count
4172 ;;                                total)
4173 ;;              (let* ((overwrite (file-exists-p to))
4174 ;;                     (overwrite-confirmed     ; for dired-handle-overwrite
4175 ;;                      (and overwrite
4176 ;;                           (let ((help-form '(format "\
4177 ;;Type SPC or `y' to overwrite file `%s',
4178 ;;DEL or `n' to skip to next,
4179 ;;ESC or `q' to not overwrite any of the remaining files,
4180 ;;`!' to overwrite all remaining files with no more questions." to)))
4181 ;;                             (dired-query 'overwrite-query
4182 ;;                                          "Overwrite `%s'?" to))))
4183 ;;                     ;; must determine if FROM is marked before file-creator
4184 ;;                     ;; gets a chance to delete it (in case of a move).
4185 ;;                     (actual-marker-char
4186 ;;                      (cond  ((integerp marker-char) marker-char)
4187 ;;                             (marker-char (dired-file-marker from)) ; slow
4188 ;;                             (t nil))))
4189 ;;                (condition-case err
4190 ;;                    (funcall file-creator from to overwrite-confirmed
4191 ;;                             (list (function ange-ftp-dcf-2)
4192 ;;                                   nil        ;err
4193 ;;                                   file-creator operation fn-list
4194 ;;                                   name-constructor
4195 ;;                                   target
4196 ;;                                   marker-char actual-marker-char
4197 ;;                                   buffer to from
4198 ;;                                   overwrite
4199 ;;                                   overwrite-confirmed
4200 ;;                                   overwrite-query
4201 ;;                                   overwrite-backup-query
4202 ;;                                   failures skipped success-count
4203 ;;                                   total)
4204 ;;                             t)
4205 ;;                  (file-error         ; FILE-CREATOR aborted
4206 ;;                   (ange-ftp-dcf-2 nil ;result
4207 ;;                                   nil ;line
4208 ;;                                   err
4209 ;;                                   file-creator operation fn-list
4210 ;;                                   name-constructor
4211 ;;                                   target
4212 ;;                                   marker-char actual-marker-char
4213 ;;                                   buffer to from
4214 ;;                                   overwrite
4215 ;;                                   overwrite-confirmed
4216 ;;                                   overwrite-query
4217 ;;                                   overwrite-backup-query
4218 ;;                                   failures skipped success-count
4219 ;;                                   total))))))))
4220 ;;      (set-buffer old-buf))))
4221
4222 ;;(defun ange-ftp-dcf-2 (result line err
4223 ;;                            file-creator operation fn-list
4224 ;;                            name-constructor
4225 ;;                            target
4226 ;;                            marker-char actual-marker-char
4227 ;;                            buffer to from
4228 ;;                            overwrite
4229 ;;                            overwrite-confirmed
4230 ;;                            overwrite-query
4231 ;;                            overwrite-backup-query
4232 ;;                            failures skipped success-count
4233 ;;                            total)
4234 ;;  (let ((old-buf (current-buffer)))
4235 ;;    (unwind-protect
4236 ;;      (progn
4237 ;;        (set-buffer buffer)
4238 ;;        (if (or err (not result))
4239 ;;            (progn
4240 ;;              (setq failures (cons (dired-make-relative from) failures))
4241 ;;              (dired-log "%s `%s' to `%s' failed:\n%s\n"
4242 ;;                         operation from to (or err line)))
4243 ;;          (if overwrite
4244 ;;              ;; If we get here, file-creator hasn't been aborted
4245 ;;              ;; and the old entry (if any) has to be deleted
4246 ;;              ;; before adding the new entry.
4247 ;;              (dired-remove-file to))
4248 ;;          (setq success-count (1+ success-count))
4249 ;;          (message "%s: %d of %d" operation success-count total)
4250 ;;          (dired-add-file to actual-marker-char))
4251
4252 ;;        (ange-ftp-dcf-1 file-creator operation (cdr fn-list)
4253 ;;                        name-constructor
4254 ;;                        target
4255 ;;                        marker-char
4256 ;;                        buffer
4257 ;;                        overwrite-query
4258 ;;                        overwrite-backup-query
4259 ;;                        failures skipped success-count
4260 ;;                        total))
4261 ;;      (set-buffer old-buf))))
4262
4263 ;;(defun ange-ftp-dcf-3 (failures operation total skipped success-count
4264 ;;                              buffer)
4265 ;;  (let ((old-buf (current-buffer)))
4266 ;;    (unwind-protect
4267 ;;      (progn
4268 ;;        (set-buffer buffer)
4269 ;;        (cond
4270 ;;         (failures
4271 ;;          (dired-log-summary
4272 ;;           (message "%s failed for %d of %d file%s %s"
4273 ;;                    operation (length failures) total
4274 ;;                    (dired-plural-s total) failures)))
4275 ;;         (skipped
4276 ;;          (dired-log-summary
4277 ;;           (message "%s: %d of %d file%s skipped %s"
4278 ;;                    operation (length skipped) total
4279 ;;                    (dired-plural-s total) skipped)))
4280 ;;         (t
4281 ;;          (message "%s: %s file%s."
4282 ;;                   operation success-count (dired-plural-s success-count))))
4283 ;;        (dired-move-to-filename))
4284 ;;      (set-buffer old-buf))))
4285 \f
4286 ;;;; -----------------------------------------------
4287 ;;;; Unix Descriptive Listing (dl) Support
4288 ;;;; -----------------------------------------------
4289
4290 ;; This is turned off because nothing uses it currently
4291 ;; and because I don't understand what it's supposed to be for. --rms.
4292
4293 ;;(defconst ange-ftp-dired-dl-re-dir
4294 ;;  "^. [^ /]+/[ \n]"
4295 ;;  "Regular expression to use to search for dl directories.")
4296
4297 ;;(or (assq 'unix:dl ange-ftp-dired-re-dir-alist)
4298 ;;    (setq ange-ftp-dired-re-dir-alist
4299 ;;        (cons (cons 'unix:dl  ange-ftp-dired-dl-re-dir)
4300 ;;              ange-ftp-dired-re-dir-alist)))
4301
4302 ;;(defun ange-ftp-dired-dl-move-to-filename (&optional raise-error eol)
4303 ;;  "In dired, move to the first character of the filename on this line."
4304 ;;  ;; This is the Unix dl version.
4305 ;;  (or eol (setq eol (progn (end-of-line) (point))))
4306 ;;  (let (case-fold-search)
4307 ;;    (beginning-of-line)
4308 ;;    (if (looking-at ". [^ ]+ +\\([0-9]+\\|-\\|=\\) ")
4309 ;;      (goto-char (+ (point) 2))
4310 ;;      (if raise-error
4311 ;;        (error "No file on this line")
4312 ;;      nil))))
4313
4314 ;;(or (assq 'unix:dl ange-ftp-dired-move-to-filename-alist)
4315 ;;    (setq ange-ftp-dired-move-to-filename-alist
4316 ;;        (cons '(unix:dl . ange-ftp-dired-dl-move-to-filename)
4317 ;;              ange-ftp-dired-move-to-filename-alist)))
4318
4319 ;;(defun ange-ftp-dired-dl-move-to-end-of-filename (&optional no-error eol)
4320 ;;  ;; Assumes point is at beginning of filename.
4321 ;;  ;; So, it should be called only after (dired-move-to-filename t).
4322 ;;  ;; On failure, signals an error or returns nil.
4323 ;;  ;; This is the Unix dl version.
4324 ;;  (let ((opoint (point))
4325 ;;      case-fold-search hidden)
4326 ;;    (or eol (setq eol (save-excursion (end-of-line) (point))))
4327 ;;    (setq hidden (and selective-display
4328 ;;                     (save-excursion
4329 ;;                       (search-forward "\r" eol t))))
4330 ;;    (if hidden
4331 ;;      (if no-error
4332 ;;          nil
4333 ;;        (error
4334 ;;         (substitute-command-keys
4335 ;;          "File line is hidden, type \\[dired-hide-subdir] to unhide")))
4336 ;;      (skip-chars-forward "^ /" eol)
4337 ;;      (if (eq opoint (point))
4338 ;;        (if no-error
4339 ;;            nil
4340 ;;          (error "No file on this line"))
4341 ;;      (point)))))
4342
4343 ;;(or (assq 'unix:dl ange-ftp-dired-move-to-end-of-filename-alist)
4344 ;;    (setq ange-ftp-dired-move-to-end-of-filename-alist
4345 ;;        (cons '(unix:dl . ange-ftp-dired-dl-move-to-end-of-filename)
4346 ;;              ange-ftp-dired-move-to-end-of-filename-alist)))
4347 \f
4348 ;;;; ------------------------------------------------------------
4349 ;;;; VOS support (VOS support is probably broken,
4350 ;;;; but I don't know anything about VOS.)
4351 ;;;; ------------------------------------------------------------
4352 ;
4353 ;(defun ange-ftp-fix-name-for-vos (name &optional reverse)
4354 ;  (setq name (copy-sequence name))
4355 ;  (let ((from (if reverse ?\> ?\/))
4356 ;       (to (if reverse ?\/ ?\>))
4357 ;       (i (1- (length name))))
4358 ;    (while (>= i 0)
4359 ;      (if (= (aref name i) from)
4360 ;         (aset name i to))
4361 ;      (setq i (1- i)))
4362 ;    name))
4363 ;
4364 ;(or (assq 'vos ange-ftp-fix-name-func-alist)
4365 ;    (setq ange-ftp-fix-name-func-alist
4366 ;         (cons '(vos . ange-ftp-fix-name-for-vos)
4367 ;               ange-ftp-fix-name-func-alist)))
4368 ;
4369 ;(or (memq 'vos ange-ftp-dumb-host-types)
4370 ;    (setq ange-ftp-dumb-host-types
4371 ;         (cons 'vos ange-ftp-dumb-host-types)))
4372 ;
4373 ;(defun ange-ftp-fix-dir-name-for-vos (dir-name)
4374 ;  (ange-ftp-fix-name-for-vos
4375 ;   (concat dir-name
4376 ;          (if (eq ?/ (aref dir-name (1- (length dir-name))))
4377 ;              "" "/")
4378 ;          "*")))
4379 ;
4380 ;(or (assq 'vos ange-ftp-fix-dir-name-func-alist)
4381 ;    (setq ange-ftp-fix-dir-name-func-alist
4382 ;         (cons '(vos . ange-ftp-fix-dir-name-for-vos)
4383 ;               ange-ftp-fix-dir-name-func-alist)))
4384 ;
4385 ;(defvar ange-ftp-vos-host-regexp nil
4386 ;  "If a host matches this regexp then it is assumed to be running VOS.")
4387 ;
4388 ;(defun ange-ftp-vos-host (host)
4389 ;  (and ange-ftp-vos-host-regexp
4390 ;       (save-match-data
4391 ;        (string-match ange-ftp-vos-host-regexp host))))
4392 ;
4393 ;(defun ange-ftp-parse-vos-listing ()
4394 ;  "Parse the current buffer which is assumed to be in VOS list -all
4395 ;format, and return a hashtable as the result."
4396 ;  (let ((tbl (ange-ftp-make-hashtable))
4397 ;       (type-list
4398 ;        '(("^Files: [0-9]+ +Blocks: [0-9]+\n+" nil 40)
4399 ;          ("^Dirs: [0-9]+\n+" t 30)))
4400 ;       type-regexp type-is-dir type-col file)
4401 ;    (goto-char (point-min))
4402 ;    (save-match-data
4403 ;      (while type-list
4404 ;       (setq type-regexp (car (car type-list))
4405 ;             type-is-dir (nth 1 (car type-list))
4406 ;             type-col (nth 2 (car type-list))
4407 ;             type-list (cdr type-list))
4408 ;       (if (re-search-forward type-regexp nil t)
4409 ;           (while (eq (char-after (point)) ? )
4410 ;             (move-to-column type-col)
4411 ;             (setq file (buffer-substring (point)
4412 ;                                          (progn
4413 ;                                            (end-of-line 1)
4414 ;                                            (point))))
4415 ;             (ange-ftp-put-hash-entry file type-is-dir tbl)
4416 ;             (forward-line 1))))
4417 ;      (ange-ftp-put-hash-entry "." 'vosdir tbl)
4418 ;      (ange-ftp-put-hash-entry ".." 'vosdir tbl))
4419 ;    tbl))
4420 ;
4421 ;(or (assq 'vos ange-ftp-parse-list-func-alist)
4422 ;    (setq ange-ftp-parse-list-func-alist
4423 ;         (cons '(vos . ange-ftp-parse-vos-listing)
4424 ;               ange-ftp-parse-list-func-alist)))
4425 \f
4426 ;;;; ------------------------------------------------------------
4427 ;;;; VMS support.
4428 ;;;; ------------------------------------------------------------
4429
4430 ;; Convert NAME from UNIX-ish to VMS.  If REVERSE given then convert from VMS
4431 ;; to UNIX-ish.
4432 (defun ange-ftp-fix-name-for-vms (name &optional reverse)
4433   (save-match-data
4434     (if reverse
4435         (if (string-match "^\\([^:]+:\\)?\\(\\[.*\\]\\)?\\([^][]*\\)$" name)
4436             (let (drive dir file)
4437               (if (match-beginning 1)
4438                   (setq drive (substring name
4439                                          (match-beginning 1)
4440                                          (match-end 1))))
4441               (if (match-beginning 2)
4442                   (setq dir
4443                         (substring name (match-beginning 2) (match-end 2))))
4444               (if (match-beginning 3)
4445                   (setq file
4446                         (substring name (match-beginning 3) (match-end 3))))
4447               (and dir
4448                    (setq dir (apply (function concat)
4449                                     (mapcar (function
4450                                              (lambda (char)
4451                                                (if (= char ?.)
4452                                                    (vector ?/)
4453                                                  (vector char))))
4454                                             (substring dir 1 -1)))))
4455               (concat (and drive
4456                            (concat "/" drive "/"))
4457                       dir (and dir "/")
4458                       file))
4459           (error "name %s didn't match" name))
4460       (let (drive dir file tmp)
4461         (if (string-match "^/[^:]+:/" name)
4462             (setq drive (substring name 1
4463                                    (1- (match-end 0)))
4464                   name (substring name (match-end 0))))
4465         (setq tmp (file-name-directory name))
4466         (if tmp
4467             (setq dir (apply (function concat)
4468                              (mapcar (function
4469                                       (lambda (char)
4470                                         (if (= char ?/)
4471                                             (vector ?.)
4472                                           (vector char))))
4473                                      (substring tmp 0 -1)))))
4474         (setq file (file-name-nondirectory name))
4475         (concat drive
4476                 (and dir (concat "[" (if drive nil ".") dir "]"))
4477                 file)))))
4478
4479 ;; (ange-ftp-fix-name-for-vms "/PUB$:/ANONYMOUS/SDSCPUB/NEXT/Readme.txt;1")
4480 ;; (ange-ftp-fix-name-for-vms "/PUB$:[ANONYMOUS.SDSCPUB.NEXT]Readme.txt;1" t)
4481
4482 (or (assq 'vms ange-ftp-fix-name-func-alist)
4483     (setq ange-ftp-fix-name-func-alist
4484           (cons '(vms . ange-ftp-fix-name-for-vms)
4485                 ange-ftp-fix-name-func-alist)))
4486
4487 (or (memq 'vms ange-ftp-dumb-host-types)
4488     (setq ange-ftp-dumb-host-types
4489           (cons 'vms ange-ftp-dumb-host-types)))
4490
4491 ;; It is important that this function barf for directories for which we know
4492 ;; that we cannot possibly get a directory listing, such as "/" and "/DEV:/".
4493 ;; This is because it saves an unnecessary FTP error, or possibly the listing
4494 ;; might succeed, but give erroneous info. This last case is particularly
4495 ;; likely for OS's (like MTS) for which we need to use a wildcard in order
4496 ;; to list a directory.
4497
4498 ;; Convert name from UNIX-ish to VMS ready for a DIRectory listing.
4499 (defun ange-ftp-fix-dir-name-for-vms (dir-name)
4500   ;; Should there be entries for .. -> [-] and . -> [] below. Don't
4501   ;; think so, because expand-filename should have already short-circuited
4502   ;; them.
4503   (cond ((string-equal dir-name "/")
4504          (error "Cannot get listing for fictitious \"/\" directory."))
4505         ((string-match "^/[-A-Z0-9_$]+:/$" dir-name)
4506          (error "Cannot get listing for device."))
4507         ((ange-ftp-fix-name-for-vms dir-name))))
4508
4509 (or (assq 'vms ange-ftp-fix-dir-name-func-alist)
4510     (setq ange-ftp-fix-dir-name-func-alist
4511           (cons '(vms . ange-ftp-fix-dir-name-for-vms)
4512                 ange-ftp-fix-dir-name-func-alist)))
4513
4514 (defvar ange-ftp-vms-host-regexp nil)
4515
4516 ;; Return non-nil if HOST is running VMS.
4517 (defun ange-ftp-vms-host (host)
4518   (and ange-ftp-vms-host-regexp
4519        (save-match-data
4520          (string-match ange-ftp-vms-host-regexp host))))
4521
4522 ;; Because some VMS ftp servers convert filenames to lower case
4523 ;; we allow a-z in the filename regexp. I'm not too happy about this.
4524
4525 (defconst ange-ftp-vms-filename-regexp
4526   (concat
4527    "\\(\\([_A-Za-z0-9$]?\\|[_A-Za-z0-9$][-_A-Za-z0-9$]*\\)\\."
4528    "[-_A-Za-z0-9$]*;+[0-9]*\\)")
4529   "Regular expression to match for a valid VMS file name in Dired buffer.
4530 Stupid freaking bug! Position of _ and $ shouldn't matter but they do.
4531 Having [A-Z0-9$_] bombs on filename _$$CHANGE_LOG$.TXT$ and $CHANGE_LOG$.TX
4532 Other orders of $ and _ seem to all work just fine.")
4533
4534 ;; These parsing functions are as general as possible because the syntax
4535 ;; of ftp listings from VMS hosts is a bit erratic. What saves us is that
4536 ;; the VMS filename syntax is so rigid. If they bomb on a listing in the
4537 ;; standard VMS Multinet format, then this is a bug. If they bomb on a listing
4538 ;; from vms.weird.net, then too bad.
4539
4540 ;; Extract the next filename from a VMS dired-like listing.
4541 (defun ange-ftp-parse-vms-filename ()
4542   (if (re-search-forward
4543          ange-ftp-vms-filename-regexp
4544          nil t)
4545         (buffer-substring (match-beginning 0) (match-end 0))))
4546
4547 ;; Parse the current buffer which is assumed to be in MultiNet FTP dir
4548 ;; format, and return a hashtable as the result.
4549 (defun ange-ftp-parse-vms-listing ()
4550   (let ((tbl (ange-ftp-make-hashtable))
4551         file)
4552     (goto-char (point-min))
4553     (save-match-data
4554       (while (setq file (ange-ftp-parse-vms-filename))
4555         (if (string-match "\\.\\(DIR\\|dir\\);[0-9]+" file)
4556             ;; deal with directories
4557             (ange-ftp-put-hash-entry
4558              (substring file 0 (match-beginning 0)) t tbl)
4559           (ange-ftp-put-hash-entry file nil tbl)
4560           (if (string-match ";[0-9]+$" file) ; deal with extension
4561               ;; sans extension
4562               (ange-ftp-put-hash-entry
4563                (substring file 0 (match-beginning 0)) nil tbl)))
4564         (forward-line 1))
4565       ;; Would like to look for a "Total" line, or a "Directory" line to
4566       ;; make sure that the listing isn't complete garbage before putting
4567       ;; in "." and "..", but we can't even count on all VAX's giving us
4568       ;; either of these.
4569            (ange-ftp-put-hash-entry "." t tbl)
4570            (ange-ftp-put-hash-entry ".." t tbl))
4571     tbl))
4572
4573 (or (assq 'vms ange-ftp-parse-list-func-alist)
4574     (setq ange-ftp-parse-list-func-alist
4575           (cons '(vms . ange-ftp-parse-vms-listing)
4576                 ange-ftp-parse-list-func-alist)))
4577
4578 ;; This version only deletes file entries which have
4579 ;; explicit version numbers, because that is all VMS allows.
4580
4581 ;; Can the following two functions be speeded up using file
4582 ;; completion functions?
4583
4584 (defun ange-ftp-vms-delete-file-entry (name &optional dir-p)
4585   (if dir-p
4586       (ange-ftp-internal-delete-file-entry name t)
4587     (save-match-data
4588       (let ((file (ange-ftp-get-file-part name)))
4589         (if (string-match ";[0-9]+$" file)
4590             ;; In VMS you can't delete a file without an explicit
4591             ;; version number, or wild-card (e.g. FOO;*)
4592             ;; For now, we give up on wildcards.
4593             (let ((files (ange-ftp-get-hash-entry
4594                           (file-name-directory name)
4595                           ange-ftp-files-hashtable)))
4596               (if files
4597                   (let* ((root (substring file 0
4598                                           (match-beginning 0)))
4599                          (regexp (concat "^"
4600                                          (regexp-quote root)
4601                                          ";[0-9]+$"))
4602                          versions)
4603                     (ange-ftp-del-hash-entry file files)
4604                     ;; Now we need to check if there are any
4605                     ;; versions left. If not, then delete the
4606                     ;; root entry.
4607                     (mapatoms
4608                      '(lambda (sym)
4609                         (and (string-match regexp (get sym 'key))
4610                              (setq versions t)))
4611                      files)
4612                     (or versions
4613                         (ange-ftp-del-hash-entry root files))))))))))
4614
4615 (or (assq 'vms ange-ftp-delete-file-entry-alist)
4616     (setq ange-ftp-delete-file-entry-alist
4617           (cons '(vms . ange-ftp-vms-delete-file-entry)
4618                 ange-ftp-delete-file-entry-alist)))
4619
4620 (defun ange-ftp-vms-add-file-entry (name &optional dir-p)
4621   (if dir-p
4622       (ange-ftp-internal-add-file-entry name t)
4623     (let ((files (ange-ftp-get-hash-entry
4624                   (file-name-directory name)
4625                   ange-ftp-files-hashtable)))
4626       (if files
4627           (let ((file (ange-ftp-get-file-part name)))
4628             (save-match-data
4629               (if (string-match ";[0-9]+$" file)
4630                   (ange-ftp-put-hash-entry
4631                    (substring file 0 (match-beginning 0))
4632                    nil files)
4633                 ;; Need to figure out what version of the file
4634                 ;; is being added.
4635                 (let ((regexp (concat "^"
4636                                       (regexp-quote file)
4637                                       ";\\([0-9]+\\)$"))
4638                       (version 0))
4639                   (mapatoms
4640                    '(lambda (sym)
4641                       (let ((name (get sym 'key)))
4642                         (and (string-match regexp name)
4643                              (setq version
4644                                    (max version
4645                                         (string-to-int
4646                                          (substring name
4647                                                     (match-beginning 1)
4648                                                     (match-end 1))))))))
4649                    files)
4650                   (setq version (1+ version))
4651                   (ange-ftp-put-hash-entry
4652                    (concat file ";" (int-to-string version))
4653                    nil files))))
4654             (ange-ftp-put-hash-entry file nil files))))))
4655
4656 (or (assq 'vms ange-ftp-add-file-entry-alist)
4657     (setq ange-ftp-add-file-entry-alist
4658           (cons '(vms . ange-ftp-vms-add-file-entry)
4659                 ange-ftp-add-file-entry-alist)))
4660
4661
4662 (defun ange-ftp-add-vms-host (host)
4663   "Mark HOST as the name of a machine running VMS."
4664   (interactive
4665    (list (read-string "Host: "
4666                       (let ((name (or (buffer-file-name) default-directory)))
4667                         (and name (car (ange-ftp-ftp-name name)))))))
4668   (if (not (ange-ftp-vms-host host))
4669       (setq ange-ftp-vms-host-regexp
4670             (concat "^" (regexp-quote host) "$"
4671                     (and ange-ftp-vms-host-regexp "\\|")
4672                     ange-ftp-vms-host-regexp)
4673             ange-ftp-host-cache nil)))
4674
4675
4676 (defun ange-ftp-vms-file-name-as-directory (name)
4677   (save-match-data
4678     (if (string-match "\\.\\(DIR\\|dir\\)\\(;[0-9]+\\)?$" name)
4679         (setq name (substring name 0 (match-beginning 0))))
4680     (ange-ftp-real-file-name-as-directory name)))
4681
4682 (or (assq 'vms ange-ftp-file-name-as-directory-alist)
4683     (setq ange-ftp-file-name-as-directory-alist
4684           (cons '(vms . ange-ftp-vms-file-name-as-directory)
4685                 ange-ftp-file-name-as-directory-alist)))
4686
4687 ;;; Tree dired support:
4688
4689 ;; For this code I have borrowed liberally from Sebastian Kremer's
4690 ;; dired-vms.el
4691
4692
4693 ;;;; These regexps must be anchored to beginning of line.
4694 ;;;; Beware that the ftpd may put the device in front of the filename.
4695
4696 ;;(defconst ange-ftp-dired-vms-re-exe "^. [^ \t.]+\\.\\(EXE\\|exe\\)[; ]"
4697 ;;  "Regular expression to use to search for VMS executable files.")
4698
4699 ;;(defconst ange-ftp-dired-vms-re-dir "^. [^ \t.]+\\.\\(DIR\\|dir\\)[; ]"
4700 ;;  "Regular expression to use to search for VMS directories.")
4701
4702 ;;(or (assq 'vms ange-ftp-dired-re-exe-alist)
4703 ;;    (setq ange-ftp-dired-re-exe-alist
4704 ;;        (cons (cons 'vms  ange-ftp-dired-vms-re-exe)
4705 ;;              ange-ftp-dired-re-exe-alist)))
4706
4707 ;;(or (assq 'vms ange-ftp-dired-re-dir-alist)
4708 ;;    (setq ange-ftp-dired-re-dir-alist
4709 ;;        (cons (cons 'vms  ange-ftp-dired-vms-re-dir)
4710 ;;              ange-ftp-dired-re-dir-alist)))
4711
4712 ;;(defun ange-ftp-dired-vms-insert-headerline (dir)
4713 ;;  ;; VMS inserts a headerline. I would prefer the headerline
4714 ;;  ;; to be in ange-ftp format. This version tries to
4715 ;;  ;; be careful, because we can't count on a headerline
4716 ;;  ;; over ftp, and we wouldn't want to delete anything
4717 ;;  ;; important.
4718 ;;  (save-excursion
4719 ;;    (if (looking-at "^  wildcard ")
4720 ;;      (forward-line 1))
4721 ;;    (if (looking-at "^[ \n\t]*[^\n]+\\][ \t]*\n")
4722 ;;      (delete-region (point) (match-end 0))))
4723 ;;  (ange-ftp-real-dired-insert-headerline dir))
4724
4725 ;;(or (assq 'vms ange-ftp-dired-insert-headerline-alist)
4726 ;;    (setq ange-ftp-dired-insert-headerline-alist
4727 ;;        (cons '(vms . ange-ftp-dired-vms-insert-headerline)
4728 ;;              ange-ftp-dired-insert-headerline-alist)))
4729
4730 ;;(defun ange-ftp-dired-vms-move-to-filename (&optional raise-error eol)
4731 ;;  "In dired, move to first char of filename on this line.
4732 ;;Returns position (point) or nil if no filename on this line."
4733 ;;  ;; This is the VMS version.
4734 ;;  (let (case-fold-search)
4735 ;;    (or eol (setq eol (progn (end-of-line) (point))))
4736 ;;    (beginning-of-line)
4737 ;;    (if (re-search-forward ange-ftp-vms-filename-regexp eol t)
4738 ;;      (goto-char (match-beginning 1))
4739 ;;      (if raise-error
4740 ;;        (error "No file on this line")
4741 ;;      nil))))
4742
4743 ;;(or (assq 'vms ange-ftp-dired-move-to-filename-alist)
4744 ;;    (setq ange-ftp-dired-move-to-filename-alist
4745 ;;        (cons '(vms . ange-ftp-dired-vms-move-to-filename)
4746 ;;              ange-ftp-dired-move-to-filename-alist)))
4747
4748 ;;(defun ange-ftp-dired-vms-move-to-end-of-filename (&optional no-error eol)
4749 ;;  ;; Assumes point is at beginning of filename.
4750 ;;  ;; So, it should be called only after (dired-move-to-filename t).
4751 ;;  ;; case-fold-search must be nil, at least for VMS.
4752 ;;  ;; On failure, signals an error or returns nil.
4753 ;;  ;; This is the VMS version.
4754 ;;  (let (opoint hidden case-fold-search)
4755 ;;    (setq opoint (point))
4756 ;;    (or eol (setq eol (save-excursion (end-of-line) (point))))
4757 ;;    (setq hidden (and selective-display
4758 ;;                    (save-excursion (search-forward "\r" eol t))))
4759 ;;    (if hidden
4760 ;;      nil
4761 ;;      (re-search-forward ange-ftp-vms-filename-regexp eol t))
4762 ;;    (or no-error
4763 ;;      (not (eq opoint (point)))
4764 ;;      (error
4765 ;;       (if hidden
4766 ;;           (substitute-command-keys
4767 ;;            "File line is hidden, type \\[dired-hide-subdir] to unhide")
4768 ;;         "No file on this line")))
4769 ;;    (if (eq opoint (point))
4770 ;;      nil
4771 ;;      (point))))
4772
4773 ;;(or (assq 'vms ange-ftp-dired-move-to-end-of-filename-alist)
4774 ;;    (setq ange-ftp-dired-move-to-end-of-filename-alist
4775 ;;        (cons '(vms . ange-ftp-dired-vms-move-to-end-of-filename)
4776 ;;              ange-ftp-dired-move-to-end-of-filename-alist)))
4777
4778 ;;(defun ange-ftp-dired-vms-between-files ()
4779 ;;  (save-excursion
4780 ;;    (beginning-of-line)
4781 ;;    (or (equal (following-char) 10) ; newline
4782 ;;     (equal (following-char) 9)     ; tab
4783 ;;     (progn (forward-char 2)
4784 ;;          (or (looking-at "Total of")
4785 ;;              (equal (following-char) 32))))))
4786
4787 ;;(or (assq 'vms ange-ftp-dired-between-files-alist)
4788 ;;    (setq ange-ftp-dired-between-files-alist
4789 ;;        (cons '(vms . ange-ftp-dired-vms-between-files)
4790 ;;              ange-ftp-dired-between-files-alist)))
4791
4792 ;; Beware! In VMS filenames must be of the form "FILE.TYPE".
4793 ;; Therefore, we cannot just append a ".Z" to filenames for
4794 ;; compressed files. Instead, we turn "FILE.TYPE" into
4795 ;; "FILE.TYPE-Z". Hope that this is a reasonable thing to do.
4796
4797 (defun ange-ftp-vms-make-compressed-filename (name &optional reverse)
4798   (cond
4799    ((string-match "-Z;[0-9]+$" name)
4800     (list nil (substring name 0 (match-beginning 0))))
4801    ((string-match ";[0-9]+$" name)
4802     (list nil (substring name 0 (match-beginning 0))))
4803    ((string-match "-Z$" name)
4804     (list nil (substring name 0 -2)))
4805    (t
4806     (list t
4807           (if (string-match ";[0-9]+$" name)
4808               (concat (substring name 0 (match-beginning 0))
4809                       "-Z")
4810             (concat name "-Z"))))))
4811
4812 (or (assq 'vms ange-ftp-make-compressed-filename-alist)
4813     (setq ange-ftp-make-compressed-filename-alist
4814           (cons '(vms . ange-ftp-vms-make-compressed-filename)
4815                 ange-ftp-make-compressed-filename-alist)))
4816
4817 ;;;; When the filename is too long, VMS will use two lines to list a file
4818 ;;;; (damn them!) This will confuse dired. To solve this, need to convince
4819 ;;;; Sebastian to use a function dired-go-to-end-of-file-line, instead of
4820 ;;;; (forward-line 1). This would require a number of changes to dired.el.
4821 ;;;; If dired gets confused, revert-buffer will fix it.
4822
4823 ;;(defun ange-ftp-dired-vms-ls-trim ()
4824 ;;  (goto-char (point-min))
4825 ;;  (let ((case-fold-search nil))
4826 ;;    (re-search-forward  ange-ftp-vms-filename-regexp))
4827 ;;  (beginning-of-line)
4828 ;;  (delete-region (point-min) (point))
4829 ;;  (forward-line 1)
4830 ;;  (delete-region (point) (point-max)))
4831
4832
4833 ;;(or (assq 'vms ange-ftp-dired-ls-trim-alist)
4834 ;;    (setq ange-ftp-dired-ls-trim-alist
4835 ;;        (cons '(vms . ange-ftp-dired-vms-ls-trim)
4836 ;;              ange-ftp-dired-ls-trim-alist)))
4837
4838 (defun ange-ftp-vms-sans-version (name)
4839   (save-match-data
4840     (if (string-match ";[0-9]+$" name)
4841         (substring name 0 (match-beginning 0))
4842       name)))
4843
4844 (or (assq 'vms ange-ftp-sans-version-alist)
4845     (setq ange-ftp-sans-version-alist
4846           (cons '(vms . ange-ftp-vms-sans-version)
4847                 ange-ftp-sans-version-alist)))
4848
4849 ;;(defvar ange-ftp-file-version-alist)
4850
4851 ;;;;; The vms version of clean-directory has 2 more optional args
4852 ;;;;; than the usual dired version. This is so that it can be used by
4853 ;;;;; ange-ftp-dired-vms-flag-backup-files.
4854
4855 ;;(defun ange-ftp-dired-vms-clean-directory (keep &optional marker msg)
4856 ;;  "Flag numerical backups for deletion.
4857 ;;Spares `dired-kept-versions' latest versions, and `kept-old-versions' oldest.
4858 ;;Positive prefix arg KEEP overrides `dired-kept-versions';
4859 ;;Negative prefix arg KEEP overrides `kept-old-versions' with KEEP made positive.
4860
4861 ;;To clear the flags on these files, you can use \\[dired-flag-backup-files]
4862 ;;with a prefix argument."
4863 ;;;  (interactive "P") ; Never actually called interactively.
4864 ;;  (setq keep (max 1 (if keep (prefix-numeric-value keep) dired-kept-versions)))
4865 ;;  (let ((early-retention (if (< keep 0) (- keep) kept-old-versions))
4866 ;;      ;; late-retention must NEVER be allowed to be less than 1 in VMS!
4867 ;;      ;; This could wipe ALL copies of the file.
4868 ;;      (late-retention (max 1 (if (<= keep 0) dired-kept-versions keep)))
4869 ;;      (action (or msg "Cleaning"))
4870 ;;      (ange-ftp-trample-marker (or marker dired-del-marker))
4871 ;;      (ange-ftp-file-version-alist ()))
4872 ;;    (message (concat action
4873 ;;                   " numerical backups (keeping %d late, %d old)...")
4874 ;;           late-retention early-retention)
4875 ;;    ;; Look at each file.
4876 ;;    ;; If the file has numeric backup versions,
4877 ;;    ;; put on ange-ftp-file-version-alist an element of the form
4878 ;;    ;; (FILENAME . VERSION-NUMBER-LIST)
4879 ;;    (dired-map-dired-file-lines (function
4880 ;;                               ange-ftp-dired-vms-collect-file-versions))
4881 ;;    ;; Sort each VERSION-NUMBER-LIST,
4882 ;;    ;; and remove the versions not to be deleted.
4883 ;;    (let ((fval ange-ftp-file-version-alist))
4884 ;;      (while fval
4885 ;;      (let* ((sorted-v-list (cons 'q (sort (cdr (car fval)) '<)))
4886 ;;             (v-count (length sorted-v-list)))
4887 ;;        (if (> v-count (+ early-retention late-retention))
4888 ;;            (rplacd (nthcdr early-retention sorted-v-list)
4889 ;;                    (nthcdr (- v-count late-retention)
4890 ;;                            sorted-v-list)))
4891 ;;        (rplacd (car fval)
4892 ;;                (cdr sorted-v-list)))
4893 ;;      (setq fval (cdr fval))))
4894 ;;    ;; Look at each file.  If it is a numeric backup file,
4895 ;;    ;; find it in a VERSION-NUMBER-LIST and maybe flag it for deletion.
4896 ;;    (dired-map-dired-file-lines
4897 ;;     (function
4898 ;;      ange-ftp-dired-vms-trample-file-versions mark))
4899 ;;    (message (concat action " numerical backups...done"))))
4900
4901 ;;(or (assq 'vms ange-ftp-dired-clean-directory-alist)
4902 ;;    (setq ange-ftp-dired-clean-directory-alist
4903 ;;        (cons '(vms . ange-ftp-dired-vms-clean-directory)
4904 ;;              ange-ftp-dired-clean-directory-alist)))
4905
4906 ;;(defun ange-ftp-dired-vms-collect-file-versions (fn)
4907 ;;  ;;  "If it looks like file FN has versions, return a list of the versions.
4908 ;;  ;;That is a list of strings which are file names.
4909 ;;  ;;The caller may want to flag some of these files for deletion."
4910 ;;(let ((name (nth 2 (ange-ftp-ftp-name fn))))
4911 ;;  (if (string-match ";[0-9]+$" name)
4912 ;;      (let* ((name (substring name 0 (match-beginning 0)))
4913 ;;           (fn (ange-ftp-replace-name-component fn name)))
4914 ;;      (if (not (assq fn ange-ftp-file-version-alist))
4915 ;;          (let* ((base-versions
4916 ;;                  (concat (file-name-nondirectory name) ";"))
4917 ;;                 (bv-length (length base-versions))
4918 ;;                 (possibilities (file-name-all-completions
4919 ;;                                 base-versions
4920 ;;                                 (file-name-directory fn)))
4921 ;;                 (versions (mapcar
4922 ;;                            '(lambda (arg)
4923 ;;                               (if (and (string-match
4924 ;;                                         "[0-9]+$" arg bv-length)
4925 ;;                                        (= (match-beginning 0) bv-length))
4926 ;;                                   (string-to-int (substring arg bv-length))
4927 ;;                                 0))
4928 ;;                            possibilities)))
4929 ;;            (if versions
4930 ;;                (setq
4931 ;;                 ange-ftp-file-version-alist
4932 ;;                 (cons (cons fn versions)
4933 ;;                       ange-ftp-file-version-alist)))))))))
4934
4935 ;;(defun ange-ftp-dired-vms-trample-file-versions (fn)
4936 ;;  (let* ((start-vn (string-match ";[0-9]+$" fn))
4937 ;;       base-version-list)
4938 ;;    (and start-vn
4939 ;;       (setq base-version-list        ; there was a base version to which
4940 ;;             (assoc (substring fn 0 start-vn) ; this looks like a
4941 ;;                    ange-ftp-file-version-alist))     ; subversion
4942 ;;       (not (memq (string-to-int (substring fn (1+ start-vn)))
4943 ;;                  base-version-list)) ; this one doesn't make the cut
4944 ;;       (progn (beginning-of-line)
4945 ;;              (delete-char 1)
4946 ;;              (insert ange-ftp-trample-marker)))))
4947
4948 ;;(defun ange-ftp-dired-vms-flag-backup-files (&optional unflag-p)
4949 ;;  (let ((dired-kept-versions 1)
4950 ;;      (kept-old-versions 0)
4951 ;;      marker msg)
4952 ;;    (if unflag-p
4953 ;;      (setq marker ?\040 msg "Unflagging")
4954 ;;      (setq marker dired-del-marker msg "Cleaning"))
4955 ;;    (ange-ftp-dired-vms-clean-directory nil marker msg)))
4956
4957 ;;(or (assq 'vms ange-ftp-dired-flag-backup-files-alist)
4958 ;;    (setq ange-ftp-dired-flag-backup-files-alist
4959 ;;        (cons '(vms . ange-ftp-dired-vms-flag-backup-files)
4960 ;;              ange-ftp-dired-flag-backup-files-alist)))
4961
4962 ;;(defun ange-ftp-dired-vms-backup-diff (&optional switches)
4963 ;;  (let ((file (dired-get-filename 'no-dir))
4964 ;;      bak)
4965 ;;    (if (and (string-match ";[0-9]+$" file)
4966 ;;           ;; Find most recent previous version.
4967 ;;           (let ((root (substring file 0 (match-beginning 0)))
4968 ;;                 (ver
4969 ;;                  (string-to-int (substring file (1+ (match-beginning 0)))))
4970 ;;                 found)
4971 ;;             (setq ver (1- ver))
4972 ;;             (while (and (> ver 0) (not found))
4973 ;;               (setq bak (concat root ";" (int-to-string ver)))
4974 ;;               (and (file-exists-p bak) (setq found t))
4975 ;;               (setq ver (1- ver)))
4976 ;;             found))
4977 ;;      (if switches
4978 ;;          (diff (expand-file-name bak) (expand-file-name file) switches)
4979 ;;        (diff (expand-file-name bak) (expand-file-name file)))
4980 ;;      (error "No previous version found for %s" file))))
4981
4982 ;;(or (assq 'vms ange-ftp-dired-backup-diff-alist)
4983 ;;    (setq ange-ftp-dired-backup-diff-alist
4984 ;;        (cons '(vms . ange-ftp-dired-vms-backup-diff)
4985 ;;              ange-ftp-dired-backup-diff-alist)))
4986
4987 \f
4988 ;;;; ------------------------------------------------------------
4989 ;;;; MTS support
4990 ;;;; ------------------------------------------------------------
4991
4992
4993 ;; Convert NAME from UNIX-ish to MTS. If REVERSE given then convert from
4994 ;; MTS to UNIX-ish.
4995 (defun ange-ftp-fix-name-for-mts (name &optional reverse)
4996   (save-match-data
4997     (if reverse
4998         (if (string-match "^\\([^:]+:\\)?\\(.*\\)$" name)
4999             (let (acct file)
5000               (if (match-beginning 1)
5001                   (setq acct (substring name 0 (match-end 1))))
5002               (if (match-beginning 2)
5003                   (setq file (substring name
5004                                         (match-beginning 2) (match-end 2))))
5005               (concat (and acct (concat "/" acct "/"))
5006                       file))
5007           (error "name %s didn't match" name))
5008       (if (string-match "^/\\([^:]+:\\)/\\(.*\\)$" name)
5009           (concat (substring name 1 (match-end 1))
5010                   (substring name (match-beginning 2) (match-end 2)))
5011         ;; Let's hope that mts will recognize it anyway.
5012         name))))
5013
5014 (or (assq 'mts ange-ftp-fix-name-func-alist)
5015     (setq ange-ftp-fix-name-func-alist
5016           (cons '(mts . ange-ftp-fix-name-for-mts)
5017                 ange-ftp-fix-name-func-alist)))
5018
5019 ;; Convert name from UNIX-ish to MTS ready for a DIRectory listing.
5020 ;; Remember that there are no directories in MTS.
5021 (defun ange-ftp-fix-dir-name-for-mts (dir-name)
5022   (if (string-equal dir-name "/")
5023       (error "Cannot get listing for fictitious \"/\" directory.")
5024     (let ((dir-name (ange-ftp-fix-name-for-mts dir-name)))
5025       (cond
5026        ((string-equal dir-name "")
5027         "?")
5028        ((string-match ":$" dir-name)
5029         (concat dir-name "?"))
5030        (dir-name))))) ; It's just a single file.
5031
5032 (or (assq 'mts ange-ftp-fix-dir-name-func-alist)
5033     (setq ange-ftp-fix-dir-name-func-alist
5034           (cons '(mts . ange-ftp-fix-dir-name-for-mts)
5035                 ange-ftp-fix-dir-name-func-alist)))
5036
5037 (or (memq 'mts ange-ftp-dumb-host-types)
5038     (setq ange-ftp-dumb-host-types
5039           (cons 'mts ange-ftp-dumb-host-types)))
5040
5041 (defvar ange-ftp-mts-host-regexp nil)
5042
5043 ;; Return non-nil if HOST is running MTS.
5044 (defun ange-ftp-mts-host (host)
5045   (and ange-ftp-mts-host-regexp
5046        (save-match-data
5047          (string-match ange-ftp-mts-host-regexp host))))
5048
5049 ;; Parse the current buffer which is assumed to be in mts ftp dir format.
5050 (defun ange-ftp-parse-mts-listing ()
5051   (let ((tbl (ange-ftp-make-hashtable)))
5052     (goto-char (point-min))
5053     (save-match-data
5054       (while (re-search-forward ange-ftp-date-regexp nil t)
5055         (end-of-line)
5056         (skip-chars-backward " ")
5057         (let ((end (point)))
5058           (skip-chars-backward "-A-Z0-9_.!")
5059           (ange-ftp-put-hash-entry (buffer-substring (point) end) nil tbl))
5060         (forward-line 1)))
5061       ;; Don't need to bother with ..
5062     (ange-ftp-put-hash-entry "." t tbl)
5063     tbl))
5064
5065 (or (assq 'mts ange-ftp-parse-list-func-alist)
5066     (setq ange-ftp-parse-list-func-alist
5067           (cons '(mts . ange-ftp-parse-mts-listing)
5068                 ange-ftp-parse-list-func-alist)))
5069
5070 (defun ange-ftp-add-mts-host (host)
5071   "Mark HOST as the name of a machine running MTS."
5072   (interactive
5073    (list (read-string "Host: "
5074                       (let ((name (or (buffer-file-name) default-directory)))
5075                         (and name (car (ange-ftp-ftp-name name)))))))
5076   (if (not (ange-ftp-mts-host host))
5077       (setq ange-ftp-mts-host-regexp
5078             (concat "^" (regexp-quote host) "$"
5079                     (and ange-ftp-mts-host-regexp "\\|")
5080                     ange-ftp-mts-host-regexp)
5081             ange-ftp-host-cache nil)))
5082
5083 ;;; Tree dired support:
5084
5085 ;;;; There aren't too many systems left that use MTS. This dired support will
5086 ;;;; work for the implementation of ftp on mtsg.ubc.ca. I hope other mts systems
5087 ;;;; implement ftp in the same way. If not, it might be necessary to make the
5088 ;;;; following more flexible.
5089
5090 ;;(defun ange-ftp-dired-mts-move-to-filename (&optional raise-error eol)
5091 ;;  "In dired, move to first char of filename on this line.
5092 ;;Returns position (point) or nil if no filename on this line."
5093 ;;  ;; This is the MTS version.
5094 ;;  (or eol (setq eol (progn (end-of-line) (point))))
5095 ;;  (beginning-of-line)
5096 ;;  (if (re-search-forward
5097 ;;       ange-ftp-date-regexp eol t)
5098 ;;      (progn
5099 ;;      (skip-chars-forward " ")          ; Eat blanks after date
5100 ;;      (skip-chars-forward "0-9:" eol)   ; Eat time or year
5101 ;;      (skip-chars-forward " " eol)      ; one space before filename
5102 ;;      ;; When listing an account other than the users own account it appends
5103 ;;      ;; ACCT: to the beginning of the filename. Skip over this.
5104 ;;      (and (looking-at "[A-Z0-9_.]+:")
5105 ;;           (goto-char (match-end 0)))
5106 ;;      (point))
5107 ;;    (if raise-error
5108 ;;      (error "No file on this line")
5109 ;;      nil)))
5110
5111 ;;(or (assq 'mts ange-ftp-dired-move-to-filename-alist)
5112 ;;    (setq ange-ftp-dired-move-to-filename-alist
5113 ;;        (cons '(mts . ange-ftp-dired-mts-move-to-filename)
5114 ;;              ange-ftp-dired-move-to-filename-alist)))
5115
5116 ;;(defun ange-ftp-dired-mts-move-to-end-of-filename (&optional no-error eol)
5117 ;;  ;; Assumes point is at beginning of filename.
5118 ;;  ;; So, it should be called only after (dired-move-to-filename t).
5119 ;;  ;; On failure, signals an error or returns nil.
5120 ;;  ;; This is the MTS version.
5121 ;;  (let (opoint hidden case-fold-search)
5122 ;;    (setq opoint (point)
5123 ;;        eol (save-excursion (end-of-line) (point))
5124 ;;        hidden (and selective-display
5125 ;;                    (save-excursion (search-forward "\r" eol t))))
5126 ;;    (if hidden
5127 ;;      nil
5128 ;;      (skip-chars-forward "-A-Z0-9._!" eol))
5129 ;;    (or no-error
5130 ;;      (not (eq opoint (point)))
5131 ;;      (error
5132 ;;       (if hidden
5133 ;;           (substitute-command-keys
5134 ;;            "File line is hidden, type \\[dired-hide-subdir] to unhide")
5135 ;;         "No file on this line")))
5136 ;;    (if (eq opoint (point))
5137 ;;      nil
5138 ;;      (point))))
5139
5140 ;;(or (assq 'mts ange-ftp-dired-move-to-end-of-filename-alist)
5141 ;;    (setq ange-ftp-dired-move-to-end-of-filename-alist
5142 ;;        (cons '(mts . ange-ftp-dired-mts-move-to-end-of-filename)
5143 ;;              ange-ftp-dired-move-to-end-of-filename-alist)))
5144 \f
5145 ;;;; ------------------------------------------------------------
5146 ;;;; CMS support
5147 ;;;; ------------------------------------------------------------
5148
5149 ;; Since CMS doesn't have any full file name syntax, we have to fudge
5150 ;; things with cd's. We actually send too many cd's, but it's dangerous
5151 ;; to try to remember the current minidisk, because if the connection
5152 ;; is closed and needs to be reopened, we will find ourselves back in
5153 ;; the default minidisk. This is fairly likely since CMS ftp servers
5154 ;; usually close the connection after 5 minutes of inactivity.
5155
5156 ;; Have I got the filename character set right?
5157
5158 (defun ange-ftp-fix-name-for-cms (name &optional reverse)
5159   (save-match-data
5160     (if reverse
5161         ;; Since we only convert output from a pwd in this direction,
5162         ;; we'll assume that it's a minidisk, and make it into a
5163         ;; directory file name. Note that the expand-dir-hashtable
5164         ;; stores directories without the trailing /. Is this
5165         ;; consistent?
5166         (concat "/" name)
5167       (if (string-match "^/\\([-A-Z0-9$*._]+\\)/\\([-A-Z0-9$._]+\\)?$"
5168                         name)
5169           (let ((minidisk (substring name 1 (match-end 1))))
5170             (if (match-beginning 2)
5171                 (let ((file (substring name (match-beginning 2)
5172                                        (match-end 2)))
5173                       (cmd (concat "cd " minidisk))
5174
5175                       ;; Note that host and user are bound in the call
5176                       ;; to ange-ftp-send-cmd
5177                       (proc (ange-ftp-get-process ange-ftp-this-host
5178                                                   ange-ftp-this-user)))
5179
5180                   ;; Must use ange-ftp-raw-send-cmd here to avoid
5181                   ;; an infinite loop.
5182                   (if (car (ange-ftp-raw-send-cmd proc cmd ange-ftp-this-msg))
5183                       file
5184                     ;; failed... try ONCE more.
5185                     (setq proc (ange-ftp-get-process ange-ftp-this-host
5186                                                      ange-ftp-this-user))
5187                     (let ((result (ange-ftp-raw-send-cmd proc cmd
5188                                                          ange-ftp-this-msg)))
5189                       (if (car result)
5190                           file
5191                         ;; failed.  give up.
5192                         (ange-ftp-error ange-ftp-this-host ange-ftp-this-user
5193                                         (format "cd to minidisk %s failed: %s"
5194                                                 minidisk (cdr result)))))))
5195               ;; return the minidisk
5196               minidisk))
5197         (error "Invalid CMS filename")))))
5198
5199 (or (assq 'cms ange-ftp-fix-name-func-alist)
5200     (setq ange-ftp-fix-name-func-alist
5201           (cons '(cms . ange-ftp-fix-name-for-cms)
5202                 ange-ftp-fix-name-func-alist)))
5203
5204 (or (memq 'cms ange-ftp-dumb-host-types)
5205     (setq ange-ftp-dumb-host-types
5206           (cons 'cms ange-ftp-dumb-host-types)))
5207
5208 ;; Convert name from UNIX-ish to CMS ready for a DIRectory listing.
5209 (defun ange-ftp-fix-dir-name-for-cms (dir-name)
5210   (cond
5211    ((string-equal "/" dir-name)
5212     (error "Cannot get listing for fictitious \"/\" directory."))
5213    ((string-match "^/\\([-A-Z0-9$*._]+\\)/\\([-A-Z0-9$._]+\\)?$" dir-name)
5214     (let* ((minidisk (substring dir-name (match-beginning 1) (match-end 1)))
5215            ;; host and user are bound in the call to ange-ftp-send-cmd
5216            (proc (ange-ftp-get-process ange-ftp-this-host ange-ftp-this-user))
5217            (cmd (concat "cd " minidisk))
5218            (file (if (match-beginning 2)
5219                      ;; it's a single file
5220                      (substring dir-name (match-beginning 2)
5221                                 (match-end 2))
5222                    ;; use the wild-card
5223                    "*")))
5224       (if (car (ange-ftp-raw-send-cmd proc cmd))
5225           file
5226         ;; try again...
5227         (setq proc (ange-ftp-get-process ange-ftp-this-host
5228                                          ange-ftp-this-user))
5229         (let ((result (ange-ftp-raw-send-cmd proc cmd)))
5230           (if (car result)
5231               file
5232             ;; give up
5233             (ange-ftp-error ange-ftp-this-host ange-ftp-this-user
5234                             (format "cd to minidisk %s failed: "
5235                                     minidisk (cdr result))))))))
5236    (t (error "Invalid CMS file name"))))
5237
5238 (or (assq 'cms ange-ftp-fix-dir-name-func-alist)
5239     (setq ange-ftp-fix-dir-name-func-alist
5240           (cons '(cms . ange-ftp-fix-dir-name-for-cms)
5241                 ange-ftp-fix-dir-name-func-alist)))
5242
5243 (defvar ange-ftp-cms-host-regexp nil
5244   "Regular expression to match hosts running the CMS operating system.")
5245
5246 ;; Return non-nil if HOST is running CMS.
5247 (defun ange-ftp-cms-host (host)
5248   (and ange-ftp-cms-host-regexp
5249        (save-match-data
5250          (string-match ange-ftp-cms-host-regexp host))))
5251
5252 (defun ange-ftp-add-cms-host (host)
5253   "Mark HOST as the name of a CMS host."
5254   (interactive
5255    (list (read-string "Host: "
5256                       (let ((name (or (buffer-file-name) default-directory)))
5257                         (and name (car (ange-ftp-ftp-name name)))))))
5258   (if (not (ange-ftp-cms-host host))
5259       (setq ange-ftp-cms-host-regexp
5260             (concat "^" (regexp-quote host) "$"
5261                     (and ange-ftp-cms-host-regexp "\\|")
5262                     ange-ftp-cms-host-regexp)
5263             ange-ftp-host-cache nil)))
5264
5265 (defun ange-ftp-parse-cms-listing ()
5266   ;; Parse the current buffer which is assumed to be a CMS directory listing.
5267   ;; If we succeed in getting a listing, then we will assume that the minidisk
5268   ;; exists. file is bound by the call to ange-ftp-ls. This doesn't work
5269   ;; because ange-ftp doesn't know that the root hashtable has only part of
5270   ;; the info. It will assume that if a minidisk isn't in it, then it doesn't
5271   ;; exist. It would be nice if completion worked for minidisks, as we
5272   ;; discover them.
5273 ;  (let* ((dir-file (directory-file-name file))
5274 ;        (root (file-name-directory dir-file))
5275 ;        (minidisk (ange-ftp-get-file-part dir-file))
5276 ;        (root-tbl (ange-ftp-get-hash-entry root ange-ftp-files-hashtable)))
5277 ;    (if root-tbl
5278 ;       (ange-ftp-put-hash-entry minidisk t root-tbl)
5279 ;      (setq root-tbl (ange-ftp-make-hashtable))
5280 ;      (ange-ftp-put-hash-entry minidisk t root-tbl)
5281 ;      (ange-ftp-put-hash-entry "." t root-tbl)
5282 ;      (ange-ftp-set-files root root-tbl)))
5283   ;; Now do the usual parsing
5284   (let ((tbl (ange-ftp-make-hashtable)))
5285     (goto-char (point-min))
5286     (save-match-data
5287       (while
5288           (re-search-forward
5289            "^\\([-A-Z0-9$_]+\\) +\\([-A-Z0-9$_]+\\) +[VF] +[0-9]+ " nil t)
5290         (ange-ftp-put-hash-entry
5291          (concat (buffer-substring (match-beginning 1)
5292                                    (match-end 1))
5293                  "."
5294                  (buffer-substring (match-beginning 2)
5295                                    (match-end 2)))
5296          nil tbl)
5297         (forward-line 1))
5298       (ange-ftp-put-hash-entry "." t tbl))
5299     tbl))
5300
5301 (or (assq 'cms ange-ftp-parse-list-func-alist)
5302     (setq ange-ftp-parse-list-func-alist
5303           (cons '(cms . ange-ftp-parse-cms-listing)
5304                 ange-ftp-parse-list-func-alist)))
5305
5306 ;;;;; Tree dired support:
5307
5308 ;;(defconst ange-ftp-dired-cms-re-exe
5309 ;;  "^. [-A-Z0-9$_]+ +EXEC "
5310 ;;  "Regular expression to use to search for CMS executables.")
5311
5312 ;;(or (assq 'cms ange-ftp-dired-re-exe-alist)
5313 ;;    (setq ange-ftp-dired-re-exe-alist
5314 ;;        (cons (cons 'cms  ange-ftp-dired-cms-re-exe)
5315 ;;              ange-ftp-dired-re-exe-alist)))
5316
5317
5318 ;;(defun ange-ftp-dired-cms-insert-headerline (dir)
5319 ;;  ;; CMS has no total line, so we insert a blank line for
5320 ;;  ;; aesthetics.
5321 ;;  (insert "\n")
5322 ;;  (forward-char -1)
5323 ;;  (ange-ftp-real-dired-insert-headerline dir))
5324
5325 ;;(or (assq 'cms ange-ftp-dired-insert-headerline-alist)
5326 ;;    (setq ange-ftp-dired-insert-headerline-alist
5327 ;;        (cons '(cms . ange-ftp-dired-cms-insert-headerline)
5328 ;;              ange-ftp-dired-insert-headerline-alist)))
5329
5330 ;;(defun ange-ftp-dired-cms-move-to-filename (&optional raise-error eol)
5331 ;;  "In dired, move to the first char of filename on this line."
5332 ;;  ;; This is the CMS version.
5333 ;;  (or eol (setq eol (progn (end-of-line) (point))))
5334 ;;  (let (case-fold-search)
5335 ;;    (beginning-of-line)
5336 ;;    (if (re-search-forward " [-A-Z0-9$_]+ +[-A-Z0-9$_]+ +[VF] +[0-9]+ " eol t)
5337 ;;      (goto-char (1+ (match-beginning 0)))
5338 ;;      (if raise-error
5339 ;;        (error "No file on this line")
5340 ;;      nil))))
5341
5342 ;;(or (assq 'cms ange-ftp-dired-move-to-filename-alist)
5343 ;;    (setq ange-ftp-dired-move-to-filename-alist
5344 ;;        (cons '(cms . ange-ftp-dired-cms-move-to-filename)
5345 ;;              ange-ftp-dired-move-to-filename-alist)))
5346
5347 ;;(defun ange-ftp-dired-cms-move-to-end-of-filename (&optional no-error eol)
5348 ;;  ;; Assumes point is at beginning of filename.
5349 ;;  ;; So, it should be called only after (dired-move-to-filename t).
5350 ;;  ;; case-fold-search must be nil, at least for VMS.
5351 ;;  ;; On failure, signals an error or returns nil.
5352 ;;  ;; This is the CMS version.
5353 ;;  (let ((opoint (point))
5354 ;;      case-fold-search hidden)
5355 ;;    (or eol (setq eol (save-excursion (end-of-line) (point))))
5356 ;;    (setq hidden (and selective-display
5357 ;;                    (save-excursion
5358 ;;                      (search-forward "\r" eol t))))
5359 ;;    (if hidden
5360 ;;      (if no-error
5361 ;;          nil
5362 ;;        (error
5363 ;;         (substitute-command-keys
5364 ;;          "File line is hidden, type \\[dired-hide-subdir] to unhide")))
5365 ;;      (skip-chars-forward "-A-Z0-9$_" eol)
5366 ;;      (skip-chars-forward " " eol)
5367 ;;      (skip-chars-forward "-A-Z0-9$_" eol)
5368 ;;      (if (eq opoint (point))
5369 ;;        (if no-error
5370 ;;            nil
5371 ;;          (error "No file on this line"))
5372 ;;      (point)))))
5373
5374 ;;(or (assq 'cms ange-ftp-dired-move-to-end-of-filename-alist)
5375 ;;    (setq ange-ftp-dired-move-to-end-of-filename-alist
5376 ;;        (cons '(cms . ange-ftp-dired-cms-move-to-end-of-filename)
5377 ;;              ange-ftp-dired-move-to-end-of-filename-alist)))
5378
5379 (defun ange-ftp-cms-make-compressed-filename (name &optional reverse)
5380   (if (string-match "-Z$" name)
5381       (list nil (substring name 0 -2))
5382     (list t (concat name "-Z"))))
5383
5384 (or (assq 'cms ange-ftp-make-compressed-filename-alist)
5385     (setq ange-ftp-make-compressed-filename-alist
5386           (cons '(cms . ange-ftp-cms-make-compressed-filename)
5387                 ange-ftp-make-compressed-filename-alist)))
5388
5389 ;;(defun ange-ftp-dired-cms-get-filename (&optional localp no-error-if-not-filep)
5390 ;;  (let ((name (ange-ftp-real-dired-get-filename localp no-error-if-not-filep)))
5391 ;;    (and name
5392 ;;       (if (string-match "^\\([^ ]+\\) +\\([^ ]+\\)$" name)
5393 ;;           (concat (substring name 0 (match-end 1))
5394 ;;                   "."
5395 ;;                   (substring name (match-beginning 2) (match-end 2)))
5396 ;;         name))))
5397
5398 ;;(or (assq 'cms ange-ftp-dired-get-filename-alist)
5399 ;;    (setq ange-ftp-dired-get-filename-alist
5400 ;;        (cons '(cms . ange-ftp-dired-cms-get-filename)
5401 ;;              ange-ftp-dired-get-filename-alist)))
5402 \f
5403 ;;;; ------------------------------------------------------------
5404 ;;;; Finally provide package.
5405 ;;;; ------------------------------------------------------------
5406
5407 (provide 'ange-ftp)
5408
5409 ;;; ange-ftp.el ends here