Mercurial > hg > xemacs-beta

comparison lisp/efs/efs-cu.el @ 98:0d2f883870bc r20-1b1

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-1b1
author cvs
date Mon, 13 Aug 2007 09:13:56 +0200
parents
children 4be1180a9e89
comparison
equal deleted inserted replaced
97:498bf5da1c90 98:0d2f883870bc
1 ;; -*-Emacs-Lisp-*-
2 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3 ;;
4 ;; File: efs-cu.el
5 ;; Release: $efs release: 1.15 $
6 ;; Version: $Revision: 1.2 $
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 "/"
58 (substring "$Revision: 1.2 $" 11 -2)))
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