Added prompt-for-string and call-with-pass-phrase.

diff --git a/src/edwin/intmod.scm b/src/edwin/intmod.scm
index e5745bb38a111abf47ccbb0bcc3c608c94a3c1df..04a52beb725d5adefff01a701081d28c26c149c5 100644 (file)
--- 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 d4f0ed90879b0fd6083f968c1f9cabda184702d5..bffa129a4b292ca18fb0ee7797cc02763507f2dc 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -4883,6 +4883,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 3b59d95736a0b79d502ccc8544e7485b71bd3949..9886d9cdb2b9e7a4024f92b7d69707d662edad00 100644 (file)
--- a/src/runtime/usrint.scm
+++ b/src/runtime/usrint.scm
@@ -165,6 +165,110 @@ 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)
+                 (set-string-length! str (string-maximum-length str))
+                 (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)
+               (set-string-length! str (string-maximum-length str))
+               (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)))))))
 \f
 (define (canonicalize-prompt prompt suffix)
   (if (let ((length (string-length prompt)))