lisp/ange-ftp.el

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