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