From d70adab963424869c1d514778cc0c4c51e5f185c Mon Sep 17 00:00:00 2001
From: Matt Birkholz <matt@birkholz.chandler.az.us>
Date: Wed, 17 Aug 2011 14:19:32 -0700
Subject: [PATCH] Added prompt-for-string and call-with-pass-phrase.

---
 src/edwin/intmod.scm    |  10 ++++
 src/runtime/runtime.pkg |   2 +
 src/runtime/usrint.scm  | 102 ++++++++++++++++++++++++++++++++++++++++
 3 files changed, 114 insertions(+)

diff --git a/src/edwin/intmod.scm b/src/edwin/intmod.scm
index e5745bb38..04a52beb7 100644
--- a/src/edwin/intmod.scm
+++ b/src/edwin/intmod.scm
@@ -1055,6 +1055,14 @@ If this is an error, the debugger examines the error condition."
 (define (operation/prompt-for-confirmation port prompt)
   (unsolicited-prompt port prompt-for-confirmation? prompt))
 
+(define (operation/prompt-for-string port prompt)
+  (unsolicited-prompt port (lambda (prompt)
+			     (prompt-for-string prompt "")) prompt))
+
+(define (operation/call-with-pass-phrase port prompt receiver)
+  (unsolicited-prompt port (lambda (prompt)
+			     (call-with-pass-phrase prompt receiver)) prompt))
+
 (define unsolicited-prompt
   (let ((wait-value (list #f))
 	(abort-value (list #f)))
@@ -1162,6 +1170,8 @@ If this is an error, the debugger examines the error condition."
      (PROMPT-FOR-CONFIRMATION ,operation/prompt-for-confirmation)
      (PROMPT-FOR-COMMAND-EXPRESSION ,operation/prompt-for-command-expression)
      (PROMPT-FOR-COMMAND-CHAR ,operation/prompt-for-command-char)
+     (PROMPT-FOR-STRING ,operation/prompt-for-string)
+     (CALL-WITH-PASS-PHRASE ,operation/call-with-pass-phrase)
      (SET-DEFAULT-DIRECTORY ,operation/set-default-directory)
      (SET-DEFAULT-ENVIRONMENT ,operation/set-default-environment)
      (READ-CHAR ,operation/read-char)
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 18837dd58..d5c5774a6 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -4904,6 +4904,8 @@ USA.
 	  prompt-for-confirmation
 	  prompt-for-evaluated-expression
 	  prompt-for-expression
+	  prompt-for-string
+	  call-with-pass-phrase
 	  with-notification)
   (export (runtime rep)
 	  port/set-default-environment
diff --git a/src/runtime/usrint.scm b/src/runtime/usrint.scm
index 3b59d9573..10b1d0161 100644
--- a/src/runtime/usrint.scm
+++ b/src/runtime/usrint.scm
@@ -165,6 +165,108 @@ USA.
 	     (beep port)
 	     (flush-output port)))
 	 (loop))))))
+
+(define (prompt-for-string prompt #!optional port)
+  ;; Returns a string (the normal, "cooked" input line) or eof-object.
+  (let ((port (if (default-object? port) (interaction-i/o-port) port)))
+    (let ((operation (port/operation port 'PROMPT-FOR-STRING)))
+      (if operation
+	  (operation port prompt)
+	  (default/prompt-for-string port prompt)))))
+
+(define (default/prompt-for-string port prompt)
+  (port/with-output-terminal-mode port 'COOKED
+    (lambda ()
+      (fresh-line port)
+      (newline port)
+      (write-string prompt port)
+      (flush-output port)))
+  (port/with-input-terminal-mode port 'COOKED
+    (lambda ()
+      (read-line port))))
+
+(define (call-with-pass-phrase prompt receiver #!optional port)
+  ;; Returns a string or eof-object -- the normal, "cooked but not
+  ;; echoed" input line.
+  (let ((port (if (default-object? port) (interaction-i/o-port) port)))
+    (let ((operation (port/operation port 'CALL-WITH-PASS-PHRASE)))
+      (if operation
+	  (operation port prompt receiver)
+	  (default/call-with-pass-phrase port prompt receiver)))))
+
+(define (default/call-with-pass-phrase port prompt receiver)
+  ;; Kludge: Uses RAW mode and "cooks" #\backspace, #\return, etc.
+  ;; without regard for the tty's current "special characters".
+  ;; Signals an error if PORT is not an i/o port.
+
+  (define (del-char str)
+    (let ((l (string-length str)))
+      (if (fix:> l 0)
+	  (set-string-length! str (fix:-1+ l))))
+    str)
+
+  (define (add-char str char)
+    (let ((i (string-length str))
+	  (max (if (string-null? str) 0 (string-maximum-length str))))
+      (if (fix:< i max)
+	  (begin
+	    (set-string-length! str (fix:1+ i))
+	    (string-set! str i char)
+	    str)
+	  (let ((new (string-allocate (fix:+ 10 i))))
+	    (if (not (string-null? str))
+		(begin
+		  (substring-move! str 0 i new 0)
+		  (string-fill! str #\delete)))
+	    (set-string-length! new (fix:1+ i))
+	    (string-set! new i char)
+	    new))))
+
+  (define-integrable (with-binary-line-ending thunk)
+    (let ((outside))
+      (dynamic-wind
+	  (lambda ()
+	    (if (port/open? port)
+		(begin
+		  (set! outside (port/line-ending port))
+		  (port/set-line-ending port 'BINARY))))
+	  thunk
+	  (lambda ()
+	    (if (port/open? port)
+		(begin
+		  (port/set-line-ending port outside)
+		  (set! outside)))))))
+
+  (guarantee-i/o-port port 'default/call-with-pass-phrase)
+  (port/with-output-terminal-mode port 'COOKED
+    (lambda ()
+      (fresh-line port)
+      (newline port)
+      (write-string (canonicalize-prompt prompt ": ") port)
+      (flush-output port)))
+  (let loop ((input ""))
+    (let ((char (with-binary-line-ending
+		 (lambda ()
+		   (port/with-input-terminal-mode port 'RAW
+		     (lambda ()
+		       (read-char port)))))))
+      (cond ((or (eof-object? char)
+		    (char=? char #\return)
+		    (char=? char #\linefeed))
+		(receiver input)
+		(string-fill! input #\delete)
+		(port/with-output-terminal-mode port 'COOKED
+		  (lambda ()
+		    (newline port)))
+		unspecific)
+	    ((or (char=? char #\backspace)
+		 (char=? char #\delete))
+	     (loop (del-char input)))
+	    ((char=? char #\U+15)
+	     (set-string-length! input 0)
+	     (loop input))
+	    (else
+	     (loop (add-char input char)))))))
 
 (define (canonicalize-prompt prompt suffix)
   (if (let ((length (string-length prompt)))
-- 
2.25.1