|
98
|
1 ;; -*-Emacs-Lisp-*-
|
|
|
2 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
3 ;;
|
|
|
4 ;; File: efs-cu.el
|
|
|
5 ;; Release: $efs release: 1.15 $
|
|
100
|
6 ;; Version: $Revision: 1.3 $
|
|
98
|
7 ;; RCS:
|
|
|
8 ;; Description: Common utilities needed by efs files.
|
|
|
9 ;; Author: Sandy Rutherford <sandy@ibm550.sissa.it>
|
|
|
10 ;; Created: Fri Jan 28 19:55:45 1994 by sandy on ibm550
|
|
|
11 ;; Language: Emacs-Lisp
|
|
|
12 ;;
|
|
|
13 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
14
|
|
|
15 ;;; This file is part of efs. See efs.el for copyright
|
|
|
16 ;;; (it's copylefted) and warrranty (there isn't one) information.
|
|
|
17
|
|
|
18 ;;;; Provisions and autoloads.
|
|
|
19
|
|
|
20 (provide 'efs-cu)
|
|
|
21 (require 'backquote)
|
|
|
22 (autoload 'efs-get-process "efs")
|
|
|
23 (autoload 'efs-parse-netrc "efs-netrc")
|
|
|
24
|
|
|
25 ;;;; ------------------------------------------------------------
|
|
|
26 ;;;; Use configuration variables.
|
|
|
27 ;;;; ------------------------------------------------------------
|
|
|
28
|
|
|
29 (defvar efs-default-user nil
|
|
|
30 "*User name to use when none is specied in a pathname.
|
|
|
31
|
|
|
32 If a string, than this string is used as the default user name.
|
|
|
33 If nil, then the name under which the user is logged in is used.
|
|
|
34 If t, then the user is prompted for a name.
|
|
|
35 If an association list of the form
|
|
|
36
|
|
|
37 '((REGEXP1 . USERNAME1) (REGEXP2 . USERNAME2) ...)
|
|
|
38
|
|
|
39 then the host name is tested against each of the regular expressions
|
|
|
40 REGEXP in turn, and the default user name is the corresponding value
|
|
|
41 of USERNAME. USERNAME may be either a string, nil, or t, and these
|
|
|
42 values are interpreted as above. If there are no matches, then the
|
|
|
43 user's curent login name is used.")
|
|
|
44
|
|
|
45 (defvar efs-default-password nil
|
|
|
46 "*Password to use when the user is the same as efs-default-user.")
|
|
|
47
|
|
|
48 (defvar efs-default-account nil
|
|
|
49 "*Account password to use when the user is efs-default-user.")
|
|
|
50
|
|
|
51 ;;;; -------------------------------------------------------------
|
|
|
52 ;;;; Internal variables.
|
|
|
53 ;;;; -------------------------------------------------------------
|
|
|
54
|
|
|
55 (defconst efs-cu-version
|
|
|
56 (concat (substring "$efs release: 1.15 $" 14 -2)
|
|
|
57 "/"
|
|
100
|
58 (substring "$Revision: 1.3 $" 11 -2)))
|
|
98
|
59
|
|
|
60 (defconst efs-case-insensitive-host-types
|
|
|
61 '(vms cms mts ti-twenex ti-explorer dos mvs tops-20 mpe ka9q dos-distinct
|
|
|
62 os2 hell guardian ms-unix netware cms-knet nos-ve)
|
|
|
63 "List of host types for which case is insignificant in file names.")
|
|
|
64
|
|
|
65 ;;; Remote path name syntax
|
|
|
66
|
|
|
67 ;; All of the following variables must be set consistently.
|
|
|
68 ;; As well the below two functions depend on the grouping constructs
|
|
|
69 ;; in efs-path-regexp. So know what you're doing if you change them.
|
|
|
70
|
|
|
71 (defvar efs-path-regexp "^/\\([^@:/]*@\\)?\\([^@:/]*\\):.*"
|
|
|
72 "Regexp of a fully expanded remote path.")
|
|
|
73
|
|
|
74 (defvar efs-path-format-string "/%s@%s:%s"
|
|
|
75 "Format of a fully expanded remote path. Passed to format with
|
|
|
76 additional arguments user, host, and remote path.")
|
|
|
77
|
|
|
78 (defvar efs-path-format-without-user "/%s:%s"
|
|
|
79 "Format of a remote path, but not specifying a user.")
|
|
|
80
|
|
|
81 (defvar efs-path-user-at-host-format
|
|
|
82 (substring efs-path-format-string 1 7)
|
|
|
83 "Format to return `user@host:' strings for completion in root directory.")
|
|
|
84
|
|
|
85 (defvar efs-path-host-format
|
|
|
86 (substring efs-path-user-at-host-format 3)
|
|
|
87 "Format to return `host:' strings for completion in root directory.")
|
|
|
88
|
|
|
89 (defvar efs-path-root-regexp "^/[^/:]+:"
|
|
|
90 "Regexp to match the `/user@host:' root of an efs full path.")
|
|
|
91
|
|
|
92 (defvar efs-path-root-short-circuit-regexp "//[^/:]+:")
|
|
|
93 ;; Regexp to match an efs user@host root, which short-circuits
|
|
|
94 ;; the part of the path to the left of this pattern.
|
|
|
95
|
|
|
96 ;;;; -----------------------------------------------------------
|
|
|
97 ;;;; Variables for multiple host type support
|
|
|
98 ;;;; -----------------------------------------------------------
|
|
|
99
|
|
|
100 (defvar efs-vms-host-regexp nil
|
|
|
101 "Regexp to match the names of hosts running VMS.")
|
|
|
102 (defvar efs-cms-host-regexp nil
|
|
|
103 "Regexp to match the names of hosts running CMS.")
|
|
|
104 (defvar efs-mts-host-regexp nil
|
|
|
105 "Regexp to match the names of hosts running MTS.")
|
|
|
106 (defvar efs-ti-explorer-host-regexp nil
|
|
|
107 "Regexp to match the names of hosts running TI-EXPLORER.
|
|
|
108 These are lisp machines.")
|
|
|
109 (defvar efs-ti-twenex-host-regexp nil
|
|
|
110 "Regexp to match the names of hosts running TI-TWENEX.
|
|
|
111 These are lisp machines, and this should not be confused with DEC's TOPS-20.")
|
|
|
112 (defvar efs-sysV-unix-host-regexp nil
|
|
|
113 "Regexp to match the names of sysV unix hosts.
|
|
|
114 These are defined to be unix hosts which mark symlinks
|
|
|
115 with a @ in an ls -lF listing.")
|
|
|
116 (defvar efs-bsd-unix-host-regexp nil
|
|
|
117 "Regexp to match the names of bsd unix hosts.
|
|
|
118 These are defined to be unix hosts which do not mark symlinks
|
|
|
119 with a @ in an ls -lF listing.")
|
|
|
120 (defvar efs-next-unix-host-regexp nil
|
|
|
121 "Regexp to match names of NeXT unix hosts.
|
|
|
122 These are defined to be unix hosts which put a @ after the
|
|
|
123 destination of a symlink when doing ls -lF listing.")
|
|
|
124 (defvar efs-unix-host-regexp nil
|
|
|
125 "Regexp to match names of unix hosts.
|
|
|
126 I you know which type of unix, it is much better to set that regexp instead.")
|
|
|
127 (defvar efs-dumb-unix-host-regexp nil
|
|
|
128 "Regexp to match names of unix hosts which do not take ls switches.
|
|
|
129 For these hosts we use the \"dir\" command.")
|
|
|
130 (defvar efs-super-dumb-unix-host-regexp nil
|
|
|
131 "Regexp to match names of unix hosts with FTP servers that cannot do a PWD.
|
|
|
132 It is also assumed that these hosts do not accept ls switches, whether
|
|
|
133 or not this is actually true.")
|
|
|
134 (defvar efs-dos-host-regexp nil
|
|
|
135 "Regexp to match names of hosts running DOS.")
|
|
|
136 ;; In principal there is apollo unix support -- at least efs
|
|
|
137 ;; should do the right thing. However, apollo ftp servers can be
|
|
|
138 ;; very flakey, especially about accessing files by fullpaths.
|
|
|
139 ;; Good luck.
|
|
|
140 (defvar efs-apollo-unix-host-regexp nil
|
|
|
141 "Regexp to match names of apollo unix hosts running Apollo's Domain.
|
|
|
142 For these hosts we don't short-circuit //'s immediately following
|
|
|
143 \"/user@host:\"")
|
|
|
144 (defvar efs-mvs-host-regexp nil
|
|
|
145 "Regexp to match names of hosts running MVS.")
|
|
|
146 (defvar efs-tops-20-host-regexp nil
|
|
|
147 "Regexp to match names of hosts runninf TOPS-20.")
|
|
|
148 (defvar efs-mpe-host-regexp nil
|
|
|
149 "Regexp to match hosts running the MPE operating system.")
|
|
|
150 (defvar efs-ka9q-host-regexp nil
|
|
|
151 "Regexp to match hosts using the ka9q ftp server.
|
|
|
152 These may actually be running one of DOS, LINUX, or unix.")
|
|
|
153 (defvar efs-dos-distinct-host-regexp nil
|
|
|
154 "Regexp to match DOS hosts using the Distinct FTP server.
|
|
|
155 These are not treated as DOS hosts with a special listing format, because
|
|
|
156 the Distinct FTP server uses unix-style path syntax.")
|
|
|
157 (defvar efs-os2-host-regexp nil
|
|
|
158 "Regexp to match names of hosts running OS/2.")
|
|
|
159 (defvar efs-vos-host-regexp nil
|
|
|
160 "Regexp to match hosts running the VOS operating system.")
|
|
|
161 (defvar efs-hell-host-regexp nil
|
|
|
162 "Regexp to match hosts using the hellsoft ftp server.
|
|
|
163 These map be either DOS PC's or Macs.")
|
|
|
164 ;; The way that we implement the hellsoft support, it probably won't
|
|
|
165 ;; work with Macs. This could probably be fixed, if enough people scream.
|
|
|
166 (defvar efs-guardian-host-regexp nil
|
|
|
167 "Regexp to match hosts running Tandem's guardian operating system.")
|
|
|
168 ;; Note that ms-unix is really an FTP server running under DOS.
|
|
|
169 ;; It's not a type of unix.
|
|
|
170 (defvar efs-ms-unix-host-regexp nil
|
|
|
171 "Regexp to match hosts using the Microsoft FTP server in unix mode.")
|
|
|
172 (defvar efs-plan9-host-regexp nil
|
|
|
173 "Regexp to match hosts running ATT's Plan 9 operating system.")
|
|
|
174 (defvar efs-cms-knet-host-regexp nil
|
|
|
175 "Regexp to match hosts running the CMS KNET FTP server.")
|
|
|
176 (defvar efs-nos-ve-host-regexp nil
|
|
|
177 "Regexp to match hosts running NOS/VE.")
|
|
|
178 (defvar efs-netware-host-regexp nil
|
|
|
179 "Regexp to match hosts running Novell Netware.")
|
|
|
180 (defvar efs-dumb-apollo-unix-regexp nil
|
|
|
181 "Regexp to match dumb hosts running Apollo's Domain.
|
|
|
182 These are hosts which do not accept switches to ls over FTP.")
|
|
|
183
|
|
|
184 ;;; Further host types:
|
|
|
185 ;;
|
|
|
186 ;; unknown: This encompasses ka9q, dos-distinct, unix, sysV-unix, bsd-unix,
|
|
|
187 ;; next-unix, and dumb-unix.
|
|
|
188
|
|
|
189 (defconst efs-host-type-alist
|
|
|
190 ;; When efs-add-host is called interactively, it will only allow
|
|
|
191 ;; host types from this list.
|
|
|
192 '((dumb-unix . efs-dumb-unix-host-regexp)
|
|
|
193 (super-dumb-unix . efs-super-dumb-unix-host-regexp)
|
|
|
194 (next-unix . efs-next-unix-host-regexp)
|
|
|
195 (sysV-unix . efs-sysV-unix-host-regexp)
|
|
|
196 (bsd-unix . efs-bsd-unix-host-regexp)
|
|
|
197 (apollo-unix . efs-apollo-unix-host-regexp)
|
|
|
198 (unix . efs-unix-host-regexp)
|
|
|
199 (vms . efs-vms-host-regexp)
|
|
|
200 (mts . efs-mts-host-regexp)
|
|
|
201 (cms . efs-cms-host-regexp)
|
|
|
202 (ti-explorer . efs-ti-explorer-host-regexp)
|
|
|
203 (ti-twenex . efs-ti-twenex-host-regexp)
|
|
|
204 (dos . efs-dos-host-regexp)
|
|
|
205 (mvs . efs-mvs-host-regexp)
|
|
|
206 (tops-20 . efs-tops-20-host-regexp)
|
|
|
207 (mpe . efs-mpe-host-regexp)
|
|
|
208 (ka9q . efs-ka9q-host-regexp)
|
|
|
209 (dos-distinct . efs-dos-distinct-host-regexp)
|
|
|
210 (os2 . efs-os2-host-regexp)
|
|
|
211 (vos . efs-vos-host-regexp)
|
|
|
212 (hell . efs-hell-host-regexp)
|
|
|
213 (guardian . efs-guardian-host-regexp)
|
|
|
214 (ms-unix . efs-ms-unix-host-regexp)
|
|
|
215 (plan9 . efs-plan9-host-regexp)
|
|
|
216 (cms-net . efs-cms-knet-host-regexp)
|
|
|
217 (nos-ve . efs-nos-ve-host-regexp)
|
|
|
218 (netware . efs-netware-host-regexp)
|
|
|
219 (dumb-apollo-unix . efs-dumb-apollo-unix-regexp)))
|
|
|
220
|
|
|
221 ;; host type cache
|
|
|
222 (defconst efs-host-cache nil)
|
|
|
223 (defconst efs-host-type-cache nil)
|
|
|
224
|
|
|
225 ;; cache for efs-ftp-path.
|
|
|
226 (defconst efs-ftp-path-arg "")
|
|
|
227 (defconst efs-ftp-path-res nil)
|
|
|
228
|
|
|
229 ;;;; -------------------------------------------------------------
|
|
|
230 ;;;; General macros.
|
|
|
231 ;;;; -------------------------------------------------------------
|
|
|
232
|
|
|
233 (defmacro efs-save-match-data (&rest body)
|
|
|
234 "Execute the BODY forms, restoring the global value of the match data.
|
|
|
235 Before executing BODY, case-fold-search is locally bound to nil."
|
|
|
236 ;; Because Emacs is buggy about let-binding buffer-local variables,
|
|
|
237 ;; we have to do this in a slightly convoluted way.
|
|
|
238 (let ((match-data-temp (make-symbol "match-data"))
|
|
|
239 (buff-temp (make-symbol "buff"))
|
|
|
240 (cfs-temp (make-symbol "cfs")))
|
|
|
241 (list
|
|
|
242 'let (list (list match-data-temp '(match-data))
|
|
|
243 (list buff-temp '(current-buffer))
|
|
|
244 (list cfs-temp 'case-fold-search))
|
|
|
245 (list 'unwind-protect
|
|
|
246 (cons 'progn
|
|
|
247 (cons
|
|
|
248 '(setq case-fold-search nil)
|
|
|
249 body))
|
|
|
250 (list 'condition-case nil
|
|
|
251 (list 'save-excursion
|
|
|
252 (list 'set-buffer buff-temp)
|
|
|
253 (list 'setq 'case-fold-search cfs-temp))
|
|
|
254 '(error nil))
|
|
|
255 (list 'store-match-data match-data-temp)))))
|
|
|
256
|
|
|
257 (put 'efs-save-match-data 'lisp-indent-hook 0)
|
|
|
258 (put 'efs-save-match-data 'edebug-form-spec '(&rest form))
|
|
|
259
|
|
|
260 (defmacro efs-define-fun (fun args &rest body)
|
|
|
261 "Like defun, but only defines a function if it has no previous definition."
|
|
|
262 ;; There are easier ways to do this. This approach is used so that the
|
|
|
263 ;; byte compiler won't complain about possibly undefined functions.
|
|
|
264 (`
|
|
|
265 (progn
|
|
|
266 (put (quote (, fun)) 'efs-define-fun
|
|
|
267 (and (fboundp (quote (, fun)))
|
|
|
268 (symbol-function (quote (, fun)))))
|
|
|
269 (defun (, fun) (, args) (,@ body))
|
|
|
270 (if (and (get (quote (, fun)) 'efs-define-fun)
|
|
|
271 (not (eq (car-safe (get (quote (, fun)) 'efs-define-fun))
|
|
|
272 (quote autoload))))
|
|
|
273 (fset (quote (, fun)) (get (quote (, fun)) 'efs-define-fun)))
|
|
|
274 (put (quote (, fun)) 'efs-define-fun nil)
|
|
|
275 (quote (, fun)))))
|
|
|
276
|
|
|
277 (put 'efs-define-fun 'lisp-indent-hook 'defun)
|
|
|
278
|
|
|
279 (defmacro efs-quote-dollars (string)
|
|
|
280 ;; Quote `$' as `$$' in STRING to get it past `substitute-in-file-name.'
|
|
|
281 (`
|
|
|
282 (let ((string (, string))
|
|
|
283 (pos 0))
|
|
|
284 (while (setq pos (string-match "\\$" string pos))
|
|
|
285 (setq string (concat (substring string 0 pos)
|
|
|
286 "$";; precede by escape character (also a $)
|
|
|
287 (substring string pos))
|
|
|
288 ;; add 2 instead 1 since another $ was inserted
|
|
|
289 pos (+ 2 pos)))
|
|
|
290 string)))
|
|
|
291
|
|
|
292 (defmacro efs-cont (implicit-args explicit-args &rest body)
|
|
|
293 "Defines an efs continuation function.
|
|
|
294 The IMPLICIT-ARGS are bound when the continuation function is called.
|
|
|
295 The EXPLICIT-ARGS are bound when the continuation function is set."
|
|
|
296 (let ((fun (list 'function
|
|
|
297 (cons 'lambda
|
|
|
298 (cons
|
|
|
299 (append implicit-args explicit-args)
|
|
|
300 body)))))
|
|
|
301 (if explicit-args
|
|
|
302 (cons 'list (cons fun explicit-args))
|
|
|
303 fun)))
|
|
|
304
|
|
|
305 (put 'efs-cont 'lisp-indent-hook 2)
|
|
|
306
|
|
|
307 ;;;; ------------------------------------------------------------
|
|
|
308 ;;;; Utility functions
|
|
|
309 ;;;; ------------------------------------------------------------
|
|
|
310
|
|
|
311 (efs-define-fun efs-repaint-minibuffer ()
|
|
|
312 ;; Set minibuf_message = 0, so that the contents of the minibuffer will show.
|
|
|
313 ;; This is the Emacs V19 version of this function. For Emacs 18, it will
|
|
|
314 ;; be redefined in a grotty way to accomplish the same thing.
|
|
|
315 (message nil))
|
|
|
316
|
|
|
317 (defun efs-get-user (host)
|
|
|
318 "Given a HOST, return the default USER."
|
|
|
319 (efs-parse-netrc)
|
|
|
320 ;; We cannot check for users case-insensitively on those systems
|
|
|
321 ;; which are treat usernames case-insens., because we need to log in
|
|
|
322 ;; first, before we know what type of system.
|
|
|
323 (let ((user (efs-get-host-property host 'user)))
|
|
|
324 (if (stringp user)
|
|
|
325 user
|
|
|
326 (prog1
|
|
|
327 (setq user
|
|
|
328 (cond ((stringp efs-default-user)
|
|
|
329 ;; We have a default name. Use it.
|
|
|
330 efs-default-user)
|
|
|
331 ((consp efs-default-user)
|
|
|
332 ;; Walk the list looking for a host-specific value.
|
|
|
333 (efs-save-match-data
|
|
|
334 (let ((alist efs-default-user)
|
|
|
335 (case-fold-search t)
|
|
|
336 result)
|
|
|
337 (while alist
|
|
|
338 (if (string-match (car (car alist)) host)
|
|
|
339 (setq result (cdr (car alist))
|
|
|
340 alist nil)
|
|
|
341 (setq alist (cdr alist))))
|
|
|
342 (cond
|
|
|
343 ((stringp result)
|
|
|
344 result)
|
|
|
345 (result
|
|
|
346 (let ((enable-recursive-minibuffers t))
|
|
|
347 (read-string (format "User for %s: " host)
|
|
|
348 (user-login-name))))
|
|
|
349 (t
|
|
|
350 (user-login-name))))))
|
|
|
351 (efs-default-user
|
|
|
352 ;; Ask the user.
|
|
|
353 (let ((enable-recursive-minibuffers t))
|
|
|
354 (read-string (format "User for %s: " host)
|
|
|
355 (user-login-name))))
|
|
|
356 ;; Default to the user's login name.
|
|
|
357 (t
|
|
|
358 (user-login-name))))
|
|
|
359 (efs-set-user host user)))))
|
|
|
360
|
|
|
361 (defun efs-ftp-path (path)
|
|
|
362 "Parse PATH according to efs-path-regexp.
|
|
|
363 Returns a list (HOST USER PATH), or nil if PATH does not match the format."
|
|
|
364 (or (string-equal path efs-ftp-path-arg)
|
|
|
365 (setq efs-ftp-path-res
|
|
|
366 (efs-save-match-data
|
|
|
367 (and (string-match efs-path-regexp path)
|
|
|
368 (let ((host (substring path (match-beginning 2)
|
|
|
369 (match-end 2)))
|
|
|
370 (user (and (match-beginning 1)
|
|
|
371 (substring path (match-beginning 1)
|
|
|
372 (1- (match-end 1)))))
|
|
|
373 (rpath (substring path (1+ (match-end 2)))))
|
|
|
374 (list (if (string-equal host "")
|
|
|
375 (setq host (system-name))
|
|
|
376 host)
|
|
|
377 (or user (efs-get-user host))
|
|
|
378 rpath))))
|
|
|
379 ;; Set this last, in case efs-get-user calls this
|
|
|
380 ;; function, which would modify an earlier setting.
|
|
|
381 efs-ftp-path-arg path))
|
|
|
382 efs-ftp-path-res)
|
|
|
383
|
|
|
384 (defun efs-chase-symlinks (file)
|
|
|
385 ;; If FILE is a symlink, chase it until we get to a real file.
|
|
|
386 ;; Unlike file truename, this function does not chase symlinks at
|
|
|
387 ;; every level, only the bottom level. Therefore, it is not useful for
|
|
|
388 ;; obtaining the truename of a file. It is useful for getting at file
|
|
|
389 ;; attributes, with a lot less overhead than file truename.
|
|
|
390 (let ((target (file-symlink-p file)))
|
|
|
391 (if target
|
|
|
392 (efs-chase-symlinks
|
|
|
393 (expand-file-name target (file-name-directory file)))
|
|
|
394 file)))
|
|
|
395
|
|
|
396 ;; If efs-host-type is called with the optional user
|
|
|
397 ;; argument, it will attempt to guess the host type by connecting
|
|
|
398 ;; as user, if necessary.
|
|
|
399
|
|
|
400 (defun efs-host-type (host &optional user)
|
|
|
401 "Return a symbol which represents the type of the HOST given.
|
|
|
402 If the optional argument USER is given, attempts to guess the
|
|
|
403 host-type by logging in as USER."
|
|
|
404
|
|
|
405 (and host
|
|
|
406 (let ((host (downcase host))
|
|
|
407 type)
|
|
|
408 (cond
|
|
|
409
|
|
|
410 ((and efs-host-cache
|
|
|
411 (string-equal host efs-host-cache)
|
|
|
412 efs-host-type-cache))
|
|
|
413
|
|
|
414 ((setq type
|
|
|
415 (efs-get-host-property host 'host-type))
|
|
|
416 (setq efs-host-cache host
|
|
|
417 efs-host-type-cache type))
|
|
|
418
|
|
|
419 ;; Trigger an ftp connection, in case we need to
|
|
|
420 ;; guess at the host type.
|
|
|
421 ((and user (efs-get-process host user)
|
|
|
422 (if (string-equal host efs-host-cache)
|
|
|
423 ;; logging in may update the cache
|
|
|
424 efs-host-type-cache
|
|
|
425 (and (setq type (efs-get-host-property host 'host-type))
|
|
|
426 (setq efs-host-cache host
|
|
|
427 efs-host-type-cache type)))))
|
|
|
428
|
|
|
429 ;; Try the regexps.
|
|
|
430 ((setq type
|
|
|
431 (let ((alist efs-host-type-alist)
|
|
|
432 regexp type-pair)
|
|
|
433 (catch 'match
|
|
|
434 (efs-save-match-data
|
|
|
435 (let ((case-fold-search t))
|
|
|
436 (while alist
|
|
|
437 (progn
|
|
|
438 (and (setq type-pair (car alist)
|
|
|
439 regexp (eval (cdr type-pair)))
|
|
|
440 (string-match regexp host)
|
|
|
441 (throw 'match (car type-pair)))
|
|
|
442 (setq alist (cdr alist)))))
|
|
|
443 nil))))
|
|
|
444 (setq efs-host-cache host
|
|
|
445 efs-host-type-cache type))
|
|
|
446 ;; Return 'unknown, but _don't_ cache it.
|
|
|
447 (t 'unknown)))))
|
|
|
448
|
|
|
449 ;;;; -------------------------------------------------------------
|
|
|
450 ;;;; Functions and macros for hashtables.
|
|
|
451 ;;;; -------------------------------------------------------------
|
|
|
452
|
|
|
453 (defun efs-make-hashtable (&optional size)
|
|
|
454 "Make an obarray suitable for use as a hashtable.
|
|
|
455 SIZE, if supplied, should be a prime number."
|
|
|
456 (make-vector (or size 31) 0))
|
|
|
457
|
|
|
458 (defun efs-map-hashtable (fun tbl &optional property)
|
|
|
459 "Call FUNCTION on each key and value in HASHTABLE.
|
|
|
460 If PROPERTY is non-nil, it is the property to be used as the second
|
|
|
461 argument to FUNCTION. The default property is 'val"
|
|
|
462 (let ((prop (or property 'val)))
|
|
|
463 (mapatoms
|
|
|
464 (function
|
|
|
465 (lambda (sym)
|
|
|
466 (funcall fun (symbol-name sym) (get sym prop))))
|
|
|
467 tbl)))
|
|
|
468
|
|
|
469 (defmacro efs-make-hash-key (key)
|
|
|
470 "Convert KEY into a suitable key for a hashtable. This returns a string."
|
|
|
471 (` (let ((key (, key))) ; eval exactly once, in case evalling key moves the
|
|
|
472 ; point.
|
|
|
473 (if (stringp key) key (prin1-to-string key)))))
|
|
|
474
|
|
|
475 ;;; Note, if you store entries in a hashtable case-sensitively, and then
|
|
|
476 ;;; retrieve them with IGNORE-CASE=t, it is possible that there may be
|
|
|
477 ;;; be more than one entry that could be retrieved. It is more or less random
|
|
|
478 ;;; which one you'll get. The onus is on the programmer to be consistent.
|
|
|
479 ;;; Suggestions to make this faster are gratefully accepted!
|
|
|
480
|
|
|
481 (defmacro efs-case-fold-intern-soft (name tbl)
|
|
|
482 "Returns a symbol with case-insensitive name NAME in the obarray TBL.
|
|
|
483 Case is considered insignificant in NAME. Note, if there is more than
|
|
|
484 one possible match, it is hard to predicate which one you'll get."
|
|
|
485 (`
|
|
|
486 (let* ((completion-ignore-case t)
|
|
|
487 (name (, name))
|
|
|
488 (tbl (, tbl))
|
|
|
489 (len (length (, name)))
|
|
|
490 (newname (try-completion name tbl
|
|
|
491 (function
|
|
|
492 (lambda (sym)
|
|
|
493 (= (length (symbol-name sym)) len))))))
|
|
|
494 (and newname
|
|
|
495 (if (eq newname t)
|
|
|
496 (intern name tbl)
|
|
|
497 (intern newname tbl))))))
|
|
|
498
|
|
|
499 (defmacro efs-hash-entry-exists-p (key tbl &optional ignore-case)
|
|
|
500 "Return whether there is an association for KEY in TABLE.
|
|
|
501 If optional IGNORE-CASE is non-nil, then ignore-case in the test."
|
|
|
502 (` (let ((key (efs-make-hash-key (, key))))
|
|
|
503 (if (, ignore-case)
|
|
|
504 (efs-case-fold-intern-soft key (, tbl))
|
|
|
505 (intern-soft key (, tbl))))))
|
|
|
506
|
|
|
507 (defmacro efs-get-hash-entry (key tbl &optional ignore-case)
|
|
|
508 "Return the value associated with KEY in HASHTABLE.
|
|
|
509 If the optional argument IGNORE-CASE is given, then case in the key is
|
|
|
510 considered irrelevant."
|
|
|
511 (` (let* ((key (efs-make-hash-key (, key)))
|
|
|
512 (sym (if (, ignore-case)
|
|
|
513 (efs-case-fold-intern-soft key (, tbl))
|
|
|
514 (intern-soft key (, tbl)))))
|
|
|
515 (and sym (get sym 'val)))))
|
|
|
516
|
|
|
517 (defmacro efs-put-hash-entry (key val tbl &optional ignore-case)
|
|
|
518 "Record an association between KEY and VALUE in HASHTABLE.
|
|
|
519 If the optional IGNORE-CASE argument is given, then check for an entry
|
|
|
520 which is the same modulo case, and update it instead of adding a new entry."
|
|
|
521 (` (let* ((key (efs-make-hash-key (, key)))
|
|
|
522 (sym (if (, ignore-case)
|
|
|
523 (or (efs-case-fold-intern-soft key (, tbl))
|
|
|
524 (intern key (, tbl)))
|
|
|
525 (intern key (, tbl)))))
|
|
|
526 (put sym 'val (, val)))))
|
|
|
527
|
|
|
528 (defun efs-del-hash-entry (key tbl &optional ignore-case)
|
|
|
529 "Copy all symbols except KEY in HASHTABLE and return modified hashtable.
|
|
|
530 If the optional argument CASE-FOLD is non-nil, then fold KEY to lower case."
|
|
|
531 (let* ((len (length tbl))
|
|
|
532 (new-tbl (efs-make-hashtable len))
|
|
|
533 (i (1- len))
|
|
|
534 (key (efs-make-hash-key key)))
|
|
|
535 (if ignore-case (setq key (downcase key)))
|
|
|
536 (efs-map-hashtable
|
|
|
537 (if ignore-case
|
|
|
538 (function
|
|
|
539 (lambda (k v)
|
|
|
540 (or (string-equal (downcase k) key)
|
|
|
541 ;; Don't need to specify ignore-case here, because
|
|
|
542 ;; we have already weeded out possible case-fold matches.
|
|
|
543 (efs-put-hash-entry k v new-tbl))))
|
|
|
544 (function
|
|
|
545 (lambda (k v)
|
|
|
546 (or (string-equal k key)
|
|
|
547 (efs-put-hash-entry k v new-tbl)))))
|
|
|
548 tbl)
|
|
|
549 (while (>= i 0)
|
|
|
550 (aset tbl i (aref new-tbl i))
|
|
|
551 (setq i (1- i)))
|
|
|
552 ;; Return the result.
|
|
|
553 tbl))
|
|
|
554
|
|
|
555 (defun efs-hash-table-keys (tbl &optional nosort)
|
|
|
556 "Return a sorted of all the keys in the hashtable TBL, as strings.
|
|
|
557 This list is sorted, unless the optional argument NOSORT is non-nil."
|
|
|
558 (let ((result (all-completions "" tbl)))
|
|
|
559 (if nosort
|
|
|
560 result
|
|
|
561 (sort result (function string-lessp)))))
|
|
|
562
|
|
|
563 ;;; hashtable variables
|
|
|
564
|
|
|
565 (defconst efs-host-hashtable (efs-make-hashtable)
|
|
|
566 "Hash table holding data on hosts.")
|
|
|
567
|
|
|
568 (defconst efs-host-user-hashtable (efs-make-hashtable)
|
|
|
569 "Hash table for holding data on host user pairs.")
|
|
|
570
|
|
|
571 (defconst efs-minidisk-hashtable (efs-make-hashtable)
|
|
|
572 "Mapping between a host, user, minidisk triplet and a account password.")
|
|
|
573
|
|
|
574 ;;;; ------------------------------------------------------------
|
|
|
575 ;;;; Host / User mapping
|
|
|
576 ;;;; ------------------------------------------------------------
|
|
|
577
|
|
|
578 (defun efs-set-host-property (host property value)
|
|
|
579 ;; For HOST, sets PROPERTY to VALUE.
|
|
|
580 (put (intern (downcase host) efs-host-hashtable) property value))
|
|
|
581
|
|
|
582 (defun efs-get-host-property (host property)
|
|
|
583 ;; For HOST, gets PROPERTY.
|
|
|
584 (get (intern (downcase host) efs-host-hashtable) property))
|
|
|
585
|
|
|
586 (defun efs-set-host-user-property (host user property value)
|
|
|
587 ;; For HOST and USER, sets PROPERTY to VALUE.
|
|
|
588 (let* ((key (concat (downcase host) "/" user))
|
|
|
589 (sym (and (memq (efs-host-type host) efs-case-insensitive-host-types)
|
|
|
590 (efs-case-fold-intern-soft key efs-host-user-hashtable))))
|
|
|
591 (or sym (setq sym (intern key efs-host-user-hashtable)))
|
|
|
592 (put sym property value)))
|
|
|
593
|
|
|
594 (defun efs-get-host-user-property (host user property)
|
|
|
595 ;; For HOST and USER, gets PROPERTY.
|
|
|
596 (let* ((key (concat (downcase host) "/" user))
|
|
|
597 (sym (and (memq (efs-host-type host) efs-case-insensitive-host-types)
|
|
|
598 (efs-case-fold-intern-soft key efs-host-user-hashtable))))
|
|
|
599 (or sym (setq sym (intern key efs-host-user-hashtable)))
|
|
|
600 (get sym property)))
|
|
|
601
|
|
|
602 (defun efs-set-user (host user)
|
|
|
603 "For a given HOST, set or change the default USER."
|
|
|
604 (interactive "sHost: \nsUser: ")
|
|
|
605 (efs-set-host-property host 'user user))
|
|
|
606
|
|
|
607 ;;;; ------------------------------------------------------------
|
|
|
608 ;;;; Encryption
|
|
|
609 ;;;; ------------------------------------------------------------
|
|
|
610
|
|
|
611 (defconst efs-passwd-seed nil)
|
|
|
612 ;; seed used to encrypt the password cache.
|
|
|
613
|
|
|
614 (defun efs-get-passwd-seed ()
|
|
|
615 ;; Returns a random number to use for encrypting passwords.
|
|
|
616 (or efs-passwd-seed
|
|
|
617 (setq efs-passwd-seed (+ 1 (random 255)))))
|
|
|
618
|
|
|
619 (defun efs-code-string (string)
|
|
|
620 ;; Encode a string, using `efs-passwd-seed'. This is nil-potent,
|
|
|
621 ;; meaning applying it twice decodes.
|
|
|
622 (if (and (fboundp 'int-char) (fboundp 'char-int))
|
|
|
623 (mapconcat
|
|
|
624 (function
|
|
|
625 (lambda (c)
|
|
|
626 (char-to-string
|
|
|
627 (int-char (logxor (efs-get-passwd-seed) (char-int c))))))
|
|
|
628 string "")
|
|
|
629 (mapconcat
|
|
|
630 (function
|
|
|
631 (lambda (c)
|
|
|
632 (char-to-string (logxor (efs-get-passwd-seed) c))))
|
|
|
633 string "")))
|
|
|
634
|
|
|
635 ;;; end of efs-cu.el
|
