|
22
|
1 ;; -*-Emacs-Lisp-*-
|
|
|
2 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
3 ;;
|
|
|
4 ;; File: efs-netrc.el
|
|
|
5 ;; Release: $efs release: 1.15 $
|
|
40
|
6 ;; Version: $Revision: 1.2 $
|
|
22
|
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 ;; 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 ;;;; ------------------------------------------------------------
|
|
|
19 ;;;; Provisions and requirements.
|
|
|
20 ;;;; ------------------------------------------------------------
|
|
|
21
|
|
|
22 (provide 'efs-netrc)
|
|
|
23 (require 'efs-cu)
|
|
|
24 (require 'efs-ovwrt)
|
|
|
25 (require 'passwd)
|
|
|
26 (require 'efs-fnh)
|
|
|
27
|
|
|
28 ;;;; ------------------------------------------------------------
|
|
|
29 ;;;; Internal Variables
|
|
|
30 ;;;; ------------------------------------------------------------
|
|
|
31
|
|
|
32 (defconst efs-netrc-version
|
|
|
33 (concat (substring "$efs release: 1.15 $" 14 -2)
|
|
|
34 "/"
|
|
40
|
35 (substring "$Revision: 1.2 $" 11 -2)))
|
|
22
|
36
|
|
|
37 ;; Make the byte compiler happy.
|
|
|
38 (defvar dired-directory)
|
|
|
39
|
|
|
40 ;;;; ------------------------------------------------------------
|
|
|
41 ;;;; Use configuration variables.
|
|
|
42 ;;;; ------------------------------------------------------------
|
|
|
43
|
|
|
44 (defvar efs-netrc-filename "~/.netrc"
|
|
|
45 "*File in .netrc format to search for passwords.
|
|
|
46 If you encrypt this file, name it something other than ~/.netrc. Otherwise,
|
|
|
47 ordinary FTP will bomb.
|
|
|
48
|
|
|
49 If you have any cryption package running off of find-file-hooks
|
|
|
50 (such as crypt.el or crypt++.el), efs will use it to decrypt this file.
|
|
|
51 Encrypting this file is a good idea!")
|
|
|
52
|
|
|
53 (defvar efs-disable-netrc-security-check nil
|
|
|
54 "*If non-nil avoid checking permissions for `efs-netrc-filename'.")
|
|
|
55
|
|
|
56 ;;;; ------------------------------------------------------------
|
|
|
57 ;;;; Host / User / Account mapping support.
|
|
|
58 ;;;; ------------------------------------------------------------
|
|
|
59
|
|
40
|
60 ;;;###autoload
|
|
22
|
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
|
|
40
|
373 ;;;###autoload
|
|
22
|
374 (defun efs-root-file-name-all-completions (file dir)
|
|
|
375 ;; Generates all completions in the root directory.
|
|
|
376 (let ((file-name-handler-alist (efs-file-name-handler-alist-sans-fn
|
|
|
377 'efs-root-handler-function)))
|
|
|
378 (nconc (all-completions file (efs-generate-root-prefixes))
|
|
|
379 (file-name-all-completions file dir))))
|
|
|
380
|
|
|
381
|
|
40
|
382 ;;;###autoload
|
|
22
|
383 (defun efs-root-file-name-completion (file dir)
|
|
|
384 ;; Calculates completions in the root directory to include remote hosts.
|
|
|
385 (let ((file-name-handler-alist (efs-file-name-handler-alist-sans-fn
|
|
|
386 'efs-root-handler-function)))
|
|
|
387 (try-completion
|
|
|
388 file
|
|
|
389 (nconc (efs-generate-root-prefixes)
|
|
|
390 (mapcar 'list (file-name-all-completions file "/"))))))
|
|
|
391
|
|
|
392
|
|
|
393 ;;; end of efs-netrc.el
|
