xemacs-base / passwd.el

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
;;; passwd.el --- Prompting for passwords semi-securely

;; Copyright (C) 1994 Free Software Foundation, Inc.

;; Author: Jamie Zawinski <jwz@jwz.org>
;; Maintainer: XEmacs Development Team
;; Keywords: comm, extensions

;; This file is part of XEmacs.

;; XEmacs is free software; you can redistribute it and/or modify it
;; under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; XEmacs is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with XEmacs; see the file COPYING.  If not, write to the Free
;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.

;;; Synched up with: Not in FSF

;; Commentary:

;;; Change Log:

;;  Sun Jun 12 04:19:30 1994 by sandy on ibm550.sissa.it
;;    Added support for password histories and (provide 'passwd)
;;    (jwz says: this "history" thing is completely undocumented, you loser!)
;; 2-Jan-95 (mon); 4:13 AM by jwz@jwz.org
;;    Fixed Sandy's extreme keymap bogosity.  Made it invert the screen when
;;    reading securely (this could be better; maybe use red text or something
;;    instead...)
;; 9-Jul-95 (fri); 4:55 AM by jwz@jwz.org
;;    Made it work with XEmacs 19.12.
;; 7-Jul-95 by cthomp@cs.uiuc.edu
;;    Added variable to control inverting frame when keyboard grabbed

;;; Code:

(defgroup passwd nil
  "Prompting for passwords semi-securely"
  :group 'processes)


(defcustom passwd-invert-frame-when-keyboard-grabbed (not (featurep 'infodock))
  "*If non-nil swap the foreground and background colors of all faces.
This is done while the keyboard is grabbed in order to give a visual
clue that a grab is in effect."
  :type 'boolean
  :group 'passwd)

(defcustom passwd-echo ?.
  "*The character which should be echoed when typing a password,
or nil, meaning echo nothing."
  :type 'sexp
  :group 'passwd)

(defvar read-passwd-map
  (let ((i 0)
	(s (make-string 1 0))
	map)
    (cond ((fboundp 'set-keymap-parent)
	   (setq map (make-keymap))
	   (set-keymap-parent map minibuffer-local-map))
	  (t  ; v18/FSFmacs compatibility
	   (setq map (copy-keymap minibuffer-local-map))))
    (if (fboundp 'set-keymap-name)
	(set-keymap-name map 'read-passwd-map))

    (while (< i 127)
      (aset s 0 i)
      (or (and (boundp 'meta-prefix-char) (eq (int-char i) meta-prefix-char))
	  (define-key map s 'self-insert-command))
      (setq i (1+ i)))

    (define-key map "\C-g" 'keyboard-quit)
    (define-key map "\C-h" 'delete-backward-char)
    (define-key map "\r" 'exit-minibuffer)
    (define-key map "\n" 'exit-minibuffer)
    (define-key map "\C-u" 'passwd-erase-buffer)
    (define-key map "\C-q" 'quoted-insert)
    (define-key map "\177" 'delete-backward-char)
    (define-key map "\M-n" 'passwd-next-history-element)
    (define-key map "\M-p" 'passwd-previous-history-element)
    map)
  "Keymap used for reading passwords in the minibuffer.
The \"bindings\" in this map are not real commands; only a limited
number of commands are understood.  The important bindings are:
\\<read-passwd-map>
	\\[passwd-erase-buffer]	Erase all input.
	\\[quoted-insert]	Insert the next character literally.
	\\[delete-backward-char]	Delete the previous character.
	\\[exit-minibuffer]	Accept what you have typed.
	\\[keyboard-quit]	Abort the command.

All other characters insert themselves (but do not echo.)")

;;; internal variables

(defvar passwd-history nil)
(defvar passwd-history-posn 0)

;;;###autoload
(defun read-passwd (prompt &optional confirm default)
  "Prompts for a password in the minibuffer, and returns it as a string.
If PROMPT may be a prompt string or an alist of elements 
'\(prompt . default\).
If optional arg CONFIRM is true, then ask the user to type the password
again to confirm that they typed it correctly.
If optional arg DEFAULT is provided, then it is a string to insert as
the default choice (it is not, of course, displayed.)

If running under X, the keyboard will be grabbed (with XGrabKeyboard())
to reduce the possibility that eavesdropping is occuring.

When reading a password, all keys self-insert, except for:
\\<read-passwd-map>
	\\[read-passwd-erase-line]	Erase the entire line.
	\\[quoted-insert]	Insert the next character literally.
	\\[delete-backward-char]	Delete the previous character.
	\\[exit-minibuffer]	Accept what you have typed.
	\\[keyboard-quit]	Abort the command.

The returned value is always a newly-created string.  No additional copies
of the password remain after this function has returned.

NOTE: unless great care is taken, the typed password will exist in plaintext
form in the running image for an arbitrarily long time.  Priveleged users may
be able to extract it from memory.  If emacs crashes, it may appear in the
resultant core file.

Some steps you can take to prevent the password from being copied around:

 - as soon as you are done with the returned string, destroy it with
   (fillarray string 0).  The same goes for any default passwords
   or password histories.

 - do not copy the string, as with concat or substring - if you do, be
   sure to keep track of and destroy all copies.

 - do not insert the password into a buffer - if you do, be sure to 
   overwrite the buffer text before killing it, as with the functions 
   `passwd-erase-buffer' or `passwd-kill-buffer'.  Note that deleting
   the text from the buffer does NOT necessarily remove the text from
   memory.

 - be careful of the undo history - if you insert the password into a 
   buffer which has undo recording turned on, the password will be 
   copied onto the undo list, and thus recoverable.

 - do not pass it as an argument to a shell command - anyone will be
   able to see it if they run `ps' at the right time.

"
  (save-excursion
    (let ((input (get-buffer-create " *password*"))
	  (passwd-history-posn 0)
	  (read-passwd nil)
	  passwd-history)
      (if (listp prompt)
	  (setq passwd-history prompt
		default (cdr (car passwd-history))))
      (if (should-use-dialog-box-p)
	  (condition-case ()
	      (popup-dialog-box (list 'built-in 'password
				      default
				      (lambda (pass)
					(setq read-passwd pass))
				      :prompt (or (car-safe prompt) prompt)
				      :verify confirm))
	    (error nil)))
      (if read-passwd
	  read-passwd
	(set-buffer input)
	(buffer-disable-undo input)
	(use-local-map read-passwd-map)
	(unwind-protect
	    (progn
	      (if (passwd-grab-keyboard)
		  (passwd-secure-display))
	      (read-passwd-1 input prompt nil default)
	      (set-buffer input)

	      (if (not confirm)
		  (buffer-string)
		(let ((ok nil)
		      passwd)
		  (while (not ok)
		    (set-buffer input)
		    (setq passwd (buffer-string))
		    (read-passwd-1 input prompt "[Retype to confirm]")
		    (if (passwd-compare-string-to-buffer passwd input)
			(setq ok t)
		      (fillarray passwd 0)
		      (setq passwd nil)
		      (beep)
		      (read-passwd-1 input prompt "[Mismatch. Start over]")
		      ))
		  passwd)))
	  ;; protected
	  (passwd-ungrab-keyboard)
	  (passwd-insecure-display)
	  (passwd-kill-buffer input)
	  (message "")
          (sit-for 0)
	  )))))


(defun read-passwd-1 (buffer prompt &optional prompt2 default)
  (set-buffer buffer)
  (passwd-erase-buffer)
  (if default (insert default))
  (catch 'exit ; exit-minibuffer throws here
    (while t
      (set-buffer buffer)
      (let* ((minibuffer-completion-table nil)
	     (cursor-in-echo-area t)
	     (echo-keystrokes 0)
	     (inhibit-input-event-recording t)
	     (key (passwd-read-key-sequence
		   (concat (if (listp prompt)
			       (car (nth passwd-history-posn passwd-history))
			     prompt)
			   prompt2
			   (if passwd-echo
			       (make-string (buffer-size) passwd-echo)))))
	     (binding (key-binding key)))
	(setq prompt2 nil)
	(set-buffer buffer)		; just in case...
	(if (fboundp 'event-to-character) ;; lemacs
	    (setq last-command-event (aref key (1- (length key)))
		  last-command-char (event-to-character last-command-event))
	  ;; v18/FSFmacs compatibility
	  (setq last-command-char (aref key (1- (length key)))))
	(setq this-command binding)
	(condition-case c
	    (command-execute binding)
	  (error
	   (beep)
	   (if (fboundp 'display-error)
	       (display-error c t)
	     ;; v18/FSFmacs compatibility
	     (message (concat (or (get (car-safe c) 'error-message) "???")
			      (if (cdr-safe c) ": ")
			      (mapconcat 
			       (function (lambda (x) (format "%s" x)))
			       (cdr-safe c) ", "))))
	   (sit-for 2)))
	))))

(defun passwd-previous-history-element (n)
  (interactive "p")
  (or passwd-history
      (error "Password history is empty."))
  (let ((l (length passwd-history)))
    (setq passwd-history-posn
	  (% (+ n passwd-history-posn) l))
    (if (< passwd-history-posn 0)
	(setq passwd-history-posn (+ passwd-history-posn l))))
  (let ((obuff (current-buffer))) ; want to move point in passwd buffer
    (unwind-protect
	(progn
	  (set-buffer " *password*")
	  (passwd-erase-buffer)
	  (insert (cdr (nth passwd-history-posn passwd-history))))
      (set-buffer obuff))))

(defun passwd-next-history-element (n)
  (interactive "p")
  (passwd-previous-history-element (- n)))

(defun passwd-erase-buffer ()
  ;; First erase the buffer, which will simply enlarge the gap.
  ;; Then insert null characters until the gap is filled with them
  ;; to prevent the old text from being visible in core files or kmem.
  ;; (Actually use 3x the size of the buffer just to be safe - a longer
  ;; passwd might have been typed and backspaced over.)
  (interactive)
  (widen)
  (let ((s (* (buffer-size) 3)))
    (erase-buffer)
    (while (> s 0)
      (insert ?\000)
      (setq s (1- s)))
    (erase-buffer)))

(defun passwd-kill-buffer (buffer)
  (save-excursion
    (set-buffer buffer)
    (buffer-disable-undo buffer)
    (passwd-erase-buffer)
    (set-buffer-modified-p nil))
  (kill-buffer buffer))


(defun passwd-compare-string-to-buffer (string buffer)
  ;; same as (equal string (buffer-string)) but with no dangerous consing.
  (save-excursion
    (set-buffer buffer)
    (goto-char (point-min))
    (let ((L (length string))
	  (i 0))
      (if (/= L (- (point-max) (point-min)))
	  nil
	(while (not (eobp))
	  (if (/= (following-char) (aref string i))
	      (goto-char (point-max))
	    (setq i (1+ i))
	    (forward-char)))
	(= (point) (+ i (point-min)))))))


(defvar passwd-face-data nil)
(defun passwd-secure-display ()
  ;; Inverts the screen - used to indicate secure input, like xterm.
  (when passwd-invert-frame-when-keyboard-grabbed
    (setq passwd-face-data
	  (delq nil (mapcar
		     (lambda (face)
		       (let ((fg (face-foreground-instance 
				  face (selected-frame) nil 
				  'no-fallback))
			     (bg (face-background-instance
				  face (selected-frame) nil
				  'no-fallback)))
			 (if (and fg bg)
			     (list face fg bg)
			   nil)))
		     (face-list))))
    (let ((rest passwd-face-data))
      (while rest
	(set-face-foreground (nth 0 (car rest)) (nth 2 (car rest)) (selected-frame))
	(set-face-background (nth 0 (car rest)) (nth 1 (car rest)) (selected-frame))
	(setq rest (cdr rest))))))

(defun passwd-insecure-display ()
  ;; Undoes the effect of `passwd-secure-display'.
  (when passwd-invert-frame-when-keyboard-grabbed
    (while passwd-face-data
      (remove-face-property (nth 0 (car passwd-face-data))
			    'foreground (selected-frame))
      (remove-face-property (nth 0 (car passwd-face-data))
			    'background (selected-frame))
      (setq passwd-face-data (cdr passwd-face-data)))))

(defun passwd-grab-keyboard ()
  ;; It is officially time to give up on lemacs 19.10
  ;; and just deal with device types.
  (let ((lock-func (case (frame-type)
		     (x
		      'x-grab-keyboard)
		     (gtk
		      'gtk-grab-keyboard)
		     (otherwise
		      nil))))
    (if (not lock-func)
	;; There is nothing we can do...
	nil
      (if (funcall lock-func)
	  ;; Grabbed it, hooray!
	  t
	(message "Unable to grab keyboard - waiting a second...")
	(sleep-for 1)
	(if (funcall lock-func)
	    (progn
	      (message "Keyboard grabbed on second try.")
	      t)
	  (beep)
	  (message "WARNING: keyboard is insecure (unable to grab!)")
	  (sleep-for 3)
	  nil)))))

(defun passwd-ungrab-keyboard ()
  (case (frame-type)
    (x (x-ungrab-keyboard))
    (gtk (gtk-ungrab-keyboard))
    (otherwise nil)))

;; v18 compatibility
(or (fboundp 'buffer-disable-undo)
    (fset 'buffer-disable-undo 'buffer-flush-undo))

;; read-key-sequence echoes the key sequence in Emacs 18.
(defun passwd-read-key-sequence (prompt)
  (let ((inhibit-quit t)
	str)
    (while (or (null str) (keymapp (key-binding str)))
      (message prompt)
      (setq str (concat str (char-to-string (read-char)))))
    (setq quit-flag nil)
    str))

(or (string-match "^18" emacs-version)
    (fset 'passwd-read-key-sequence 'read-key-sequence))

(provide 'passwd)

;;; passwd.el ends here
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.