Mercurial > hg > xemacs-beta

comparison lisp/efs/efs-netrc.el @ 22:8fc7fe29b841 r19-15b94

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-15b94
author cvs
date Mon, 13 Aug 2007 08:50:29 +0200
parents
children 7e54bd776075
comparison
equal deleted inserted replaced
21:b88636d63495 22:8fc7fe29b841
1 ;; -*-Emacs-Lisp-*-
2 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3 ;;
4 ;; File: efs-netrc.el
5 ;; Release: $efs release: 1.15 $
6 ;; Version: $Revision: 1.1 $
7 ;; RCS:
8 ;; Description: Parses ~/.netrc file, and does completion in /.
9 ;; Author: Sandy Rutherford <sandy@ibm550.sissa.it>
10 ;; Created: Fri Jan 28 19:32:47 1994 by sandy on ibm550
11 ;; Modified: Sun Nov 27 18:38:50 1994 by sandy on gandalf
12 ;; Language: Emacs-Lisp
13 ;;
14 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
15
16 ;;; This file is part of efs. See efs.el for copyright
17 ;;; (it's copylefted) and warrranty (there isn't one) information.
18
19 ;;;; ------------------------------------------------------------
20 ;;;; Provisions and requirements.
21 ;;;; ------------------------------------------------------------
22
23 (provide 'efs-netrc)
24 (require 'efs-cu)
25 (require 'efs-ovwrt)
26 (require 'passwd)
27 (require 'efs-fnh)
28
29 ;;;; ------------------------------------------------------------
30 ;;;; Internal Variables
31 ;;;; ------------------------------------------------------------
32
33 (defconst efs-netrc-version
34 (concat (substring "$efs release: 1.15 $" 14 -2)
35 "/"
36 (substring "$Revision: 1.1 $" 11 -2)))
37
38 ;; Make the byte compiler happy.
39 (defvar dired-directory)
40
41 ;;;; ------------------------------------------------------------
42 ;;;; Use configuration variables.
43 ;;;; ------------------------------------------------------------
44
45 (defvar efs-netrc-filename "~/.netrc"
46 "*File in .netrc format to search for passwords.
47 If you encrypt this file, name it something other than ~/.netrc. Otherwise,
48 ordinary FTP will bomb.
49
50 If you have any cryption package running off of find-file-hooks
51 (such as crypt.el or crypt++.el), efs will use it to decrypt this file.
52 Encrypting this file is a good idea!")
53
54 (defvar efs-disable-netrc-security-check nil
55 "*If non-nil avoid checking permissions for `efs-netrc-filename'.")
56
57 ;;;; ------------------------------------------------------------
58 ;;;; Host / User / Account mapping support.
59 ;;;; ------------------------------------------------------------
60
61 (defun efs-set-passwd (host user passwd)
62 "For a given HOST and USER, set or change the associated PASSWORD."
63 (interactive (list (read-string "Host: ")
64 (read-string "User: ")
65 (read-passwd "Password: ")))
66 (efs-set-host-user-property host user 'passwd
67 (and passwd (efs-code-string passwd))))
68
69 (defun efs-set-account (host user minidisk account)
70 "Given HOST, USER, and MINIDISK, set or change the ACCOUNT password.
71 The minidisk is only relevant for CMS. If minidisk is irrelevant,
72 give the null string for it. In lisp programs, give the minidisk as nil."
73 (interactive (efs-save-match-data
74 (let* ((path (or buffer-file-name
75 (and (eq major-mode 'dired-mode)
76 dired-directory)))
77 (parsed (and path (efs-ftp-path path)))
78 (default-host (car parsed))
79 (default-user (nth 1 parsed))
80 (default-minidisk
81 (and parsed
82 (eq (efs-host-type default-host) 'cms)
83 (string-match "^/[^/]+/" (nth 2 parsed))
84 (substring (nth 2 parsed) 1
85 (1- (match-end 0)))))
86 (host (read-string "Host: " default-host))
87 (user (read-string "User: " default-user))
88 (minidisk
89 (read-string
90 "Minidisk (enter null string if inapplicable): "
91 default-minidisk))
92 (account (read-passwd "Account password: ")))
93 (if (string-match "^ *$" minidisk)
94 (setq minidisk nil))
95 (list host user minidisk account))))
96 (and account (setq account (efs-code-string account)))
97 (if minidisk
98 (efs-put-hash-entry (concat (downcase host) "/" user "/" minidisk)
99 account efs-minidisk-hashtable)
100 (efs-set-host-user-property host user 'account account)))
101
102 ;;;; ------------------------------------------------------------
103 ;;;; Parsing the ~/.netrc.
104 ;;;; ------------------------------------------------------------
105
106 (defconst efs-netrc-modtime nil)
107 ;; Last modified time of the netrc file from file-attributes.
108
109 (defun efs-netrc-next-token ()
110 ;; Gets the next token plus it's value.
111 ;; Returns \(token value-1 value-2 ...\)
112 (skip-chars-forward " \t\n")
113 (while (char-equal (following-char) ?#)
114 (forward-line 1)
115 (skip-chars-forward " \t\n"))
116 (let ((tok (and (not (eobp))
117 (downcase (buffer-substring
118 (point)
119 (progn
120 (skip-chars-forward "^ \n\t")
121 (point)))))))
122 (cond
123 ((null tok) nil)
124 ((string-equal tok "default")
125 (list tok))
126 ((member tok (list "machine" "login" "password" "account"))
127 (list tok (efs-netrc-read-token-value)))
128 ((string-equal tok "minidisk")
129 (list tok (efs-netrc-read-token-value)
130 (efs-netrc-read-token-value)))
131 ((string-equal tok "include")
132 (let ((start (- (point) 7))
133 (path (expand-file-name (efs-netrc-read-token-value))))
134 (delete-region start (point))
135 (save-excursion (insert (efs-netrc-get-include path))))
136 (efs-netrc-next-token))
137 ;; Deal with tokens that we skip
138 ((string-equal tok "macdef")
139 (efs-save-match-data
140 (search-forward "\n\n" nil 'move))
141 (if (eobp)
142 nil
143 (efs-netrc-next-token)))
144 (t (error "efs netrc file error: Invalid token %s." tok)))))
145
146 (defun efs-netrc-read-token-value ()
147 ;; Read the following word as a token value.
148 (skip-chars-forward " \t\n")
149 (while (char-equal (following-char) ?#)
150 (forward-line 1)
151 (skip-chars-forward " \t\n"))
152 (if (eq (following-char) ?\") ;quoted token value
153 (prog2
154 (forward-char 1)
155 (buffer-substring (point)
156 (progn (skip-chars-forward "^\"") (point)))
157 (forward-char 1))
158 (buffer-substring (point)
159 (progn (skip-chars-forward "^ \n\t") (point)))))
160
161 (defun efs-netrc-get-include (path)
162 ;; Returns the text of an include file.
163 (let ((buff (create-file-buffer path)))
164 (unwind-protect
165 (save-excursion
166 (set-buffer buff)
167 (setq buffer-file-name path
168 default-directory (file-name-directory path))
169 (insert-file-contents path)
170 (normal-mode t)
171 (mapcar 'funcall find-file-hooks)
172 (setq buffer-file-name nil)
173 (buffer-string))
174 (condition-case nil
175 ;; go through this rigamoroll, because who knows
176 ;; where an interrupt in find-file-hooks leaves us.
177 (save-excursion
178 (set-buffer buff)
179 (set-buffer-modified-p nil)
180 (passwd-kill-buffer buff))
181 (error nil)))))
182
183 (defun efs-parse-netrc-group (&optional machine)
184 ;; Extract the values for the tokens "machine", "login", "password",
185 ;; "account" and "minidisk" in the current buffer. If successful,
186 ;; record the information found.
187 (let (data login)
188 ;; Get a machine token.
189 (if (or machine (setq data (efs-netrc-next-token)))
190 (progn
191 (cond
192 (machine) ; noop
193 ((string-equal (car data) "machine")
194 (setq machine (nth 1 data)))
195 ((string-equal (car data) "default")
196 (setq machine 'default))
197 (error
198 "efs netrc file error: %s"
199 "Token group must start with machine or default."))
200 ;; Next look for a login token.
201 (setq data (efs-netrc-next-token))
202 (cond
203 ((null data)
204 ;; This just interns in the hashtable for completion to
205 ;; work. The username gets set later by efs-get-user.
206 (if (stringp machine) (efs-set-user machine nil))
207 nil)
208 ((string-equal (car data) "machine")
209 (if (stringp machine) (efs-set-user machine nil))
210 (nth 1 data))
211 ((string-equal (car data) "default")
212 'default)
213 ((not (string-equal (car data) "login"))
214 (error "efs netrc file error: Expected login token for %s."
215 (if (eq machine 'default)
216 "default"
217 (format "machine %s" machine))))
218 (t
219 (setq login (nth 1 data))
220 (if (eq machine 'default)
221 (setq efs-default-user login)
222 (efs-set-user machine login)
223 ;; Since an explicit login entry is given, intern an entry
224 ;; in the efs-host-user-hashtable for completion purposes.
225 (efs-set-host-user-property machine login nil nil))
226 (while (and (setq data (efs-netrc-next-token))
227 (not (or (string-equal (car data) "machine")
228 (string-equal (car data) "default"))))
229 (cond
230 ((string-equal (car data) "password")
231 (if (eq machine 'default)
232 (setq efs-default-password (nth 1 data))
233 (efs-set-passwd machine login (nth 1 data))))
234 ((string-equal (car data) "account")
235 (if (eq machine 'default)
236 (setq efs-default-account (nth 1 data))
237 (efs-set-account machine login nil (nth 1 data))))
238 ((string-equal (car data) "minidisk")
239 (if (eq machine 'default)
240 (error "efs netrc file error: %s."
241 "Minidisk token is not allowed for default entry.")
242 (apply 'efs-set-account machine login (cdr data))))
243 ((string-equal (car data) "login")
244 (error "efs netrc file error: Second login token for %s."
245 (if (eq machine 'default)
246 "default"
247 (format "machine %s" machine))))))
248 (and data (if (string-equal (car data) "machine")
249 (nth 1 data)
250 'default))))))))
251
252 (defun efs-parse-netrc ()
253 "Parse the users ~/.netrc file, or file specified `by efs-netrc-filename'.
254 If the file exists and has the correct permissions then extract the
255 \`machine\', \`login\', \`password\', \`account\', and \`minidisk\'
256 information from within."
257 (interactive)
258 (and efs-netrc-filename
259 (let* ((file (expand-file-name efs-netrc-filename))
260 ;; Set to nil to avoid an infinite recursion if the
261 ;; .netrc file is remote.
262 (efs-netrc-filename nil)
263 (file (efs-chase-symlinks file))
264 (attr (file-attributes file))
265 netrc-buffer next)
266 (if (or (interactive-p) ; If interactive, really do something.
267 (and attr ; file exists.
268 ;; file changed
269 (not (equal (nth 5 attr) efs-netrc-modtime))))
270 (efs-save-match-data
271 (or efs-disable-netrc-security-check
272 (and (eq (nth 2 attr) (user-uid)) ; Same uids.
273 (string-match ".r..------" (nth 8 attr)))
274 (efs-netrc-scream-and-yell file attr))
275 (unwind-protect
276 (save-excursion
277 ;; we are cheating a bit here. I'm trying to do the
278 ;; equivalent of find-file on the .netrc file, but
279 ;; then nuke it afterwards.
280 ;; with the bit of logic below we should be able to have
281 ;; encrypted .netrc files.
282 (set-buffer (setq netrc-buffer
283 (generate-new-buffer "*ftp-.netrc*")))
284 (insert-file-contents file)
285 (setq buffer-file-name file)
286 (setq default-directory (file-name-directory file))
287 (normal-mode t)
288 (mapcar 'funcall find-file-hooks)
289 (setq buffer-file-name nil)
290 (goto-char (point-min))
291 (while (and (not (eobp))
292 (setq next (efs-parse-netrc-group next)))))
293 (condition-case nil
294 ;; go through this rigamoroll, because we knows
295 ;; where an interrupt in find-file-hooks leaves us.
296 (save-excursion
297 (set-buffer netrc-buffer)
298 (set-buffer-modified-p nil)
299 (passwd-kill-buffer netrc-buffer))
300 (error nil)))
301 (setq efs-netrc-modtime (nth 5 attr)))))))
302
303 (defun efs-netrc-scream-and-yell (file attr)
304 ;; Complain about badly protected netrc files.
305 (let* ((bad-own (/= (nth 2 attr) (user-uid)))
306 (modes (nth 8 attr))
307 (bad-protect (not (string-match ".r..------" modes))))
308 (if (or bad-own bad-protect)
309 (save-window-excursion
310 (with-output-to-temp-buffer "*Help*"
311 (if bad-own
312 (princ
313 (format
314 "Beware that your .netrc file %s is not owned by you.\n"
315 file)))
316 (if bad-protect
317 (progn
318 (if bad-own
319 (princ "\nAlso,")
320 (princ "Beware that"))
321 (princ
322 " your .netrc file ")
323 (or bad-own (princ (concat file " ")))
324 (princ
325 (format
326 "has permissions\n %s.\n" modes))))
327 (princ
328 "\nIf this is intentional, then setting \
329 efs-disable-netrc-security-check
330 to t will inhibit this warning in the future.\n"))
331 (select-window (get-buffer-window "*Help*"))
332 (enlarge-window (- (count-lines (point-min) (point-max))
333 (window-height) -1))
334 (if (and bad-protect
335 (y-or-n-p (format "Set permissions on %s to 600? " file)))
336 (set-file-modes file 384))))))
337
338 ;;;; ----------------------------------------------------------------
339 ;;;; Completion in the root directory.
340 ;;;; ----------------------------------------------------------------
341
342 (defun efs-generate-root-prefixes ()
343 "Return a list of prefixes of the form \"user@host:\".
344 Used when completion is done in the root directory."
345 (efs-parse-netrc)
346 (efs-save-match-data
347 (let (res)
348 (efs-map-hashtable
349 (function
350 (lambda (key value)
351 (if (string-match "^[^/]+\\(/\\).+$" key)
352 ;; efs-passwd-hashtable may have entries of the type
353 ;; "machine/" to indicate a password assigned to the default
354 ;; user for "machine". Don't use these entries for completion.
355 (let ((host (substring key 0 (match-beginning 1)))
356 (user (substring key (match-end 1))))
357 (setq res (cons (list (format
358 efs-path-user-at-host-format
359 user host))
360 res))))))
361 efs-host-user-hashtable)
362 (efs-map-hashtable
363 (function (lambda (host user)
364 (setq res (cons (list (format efs-path-host-format
365 host))
366 res))))
367 efs-host-hashtable)
368 (if (and (null res)
369 (string-match "^1[0-8]\\.\\|^[0-9]\\." emacs-version))
370 (list nil)
371 res))))
372
373 (defun efs-root-file-name-all-completions (file dir)
374 ;; Generates all completions in the root directory.
375 (let ((file-name-handler-alist (efs-file-name-handler-alist-sans-fn
376 'efs-root-handler-function)))
377 (nconc (all-completions file (efs-generate-root-prefixes))
378 (file-name-all-completions file dir))))
379
380
381 (defun efs-root-file-name-completion (file dir)
382 ;; Calculates completions in the root directory to include remote hosts.
383 (let ((file-name-handler-alist (efs-file-name-handler-alist-sans-fn
384 'efs-root-handler-function)))
385 (try-completion
386 file
387 (nconc (efs-generate-root-prefixes)
388 (mapcar 'list (file-name-all-completions file "/"))))))
389
390
391 ;;; end of efs-netrc.el