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