Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-18 21:29:19 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

making (chibi term edit-line) portable, using from (chibi snow interface)

Browse source
This commit is contained in:
Alex Shinn 2017-01-23 23:12:58 +09:00
parent 92daa43114
commit ac6d0124c4
4 changed files with 50 additions and 49 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

13
lib/chibi/snow/interface.scm
View file

@ -70,24 +70,19 @@
(history-insert! input-history str)
(check str (proc str) lp)))))))
(define (input-hidden prompt)
(show #t prompt)
(flush-output-port)
(let ((res (with-stty '(not echo) (lambda () (read-line)))))
(show #t "\n")
res))
(define (input-password cfg name prompt1 . o)
(let ((prompt2 (or (and (pair? o) (car o))
(string-append prompt1 " (confirmation): "))))
(let lp ()
(let ((password (input-hidden prompt1)))
(let ((password (edit-line 'hidden?: #t 'prompt: prompt1)))
(newline)
(cond
((equal? password "")
(show #t "password must be non-empty\n")
(lp))
(else
(let ((conf (input-hidden prompt2)))
(let ((conf (edit-line 'hidden?: #t 'prompt: prompt2)))
(newline)
(cond
((not (equal? password conf))
(show #t "password didn't match\n")

35
lib/chibi/snow/interface.sld
View file

@ -4,15 +4,15 @@
restore-history save-history)
(import (scheme base) (scheme char) (scheme read) (scheme write)
(scheme file) (scheme process-context) (srfi 1)
(chibi config) (chibi pathname) (chibi show))
(chibi config) (chibi pathname) (chibi show)
(chibi term edit-line))
(cond-expand
(chibi
(import (chibi filesystem) (chibi stty)))
(import (chibi filesystem)))
(chicken
(import posix stty)
(import posix)
(begin
(define (create-directory* dir) (create-directory dir #t))
(define (edit-line ))))
(define (create-directory* dir) (create-directory dir #t))))
(sagittarius
(import (only (sagittarius) create-directory)
(chibi string))
@ -30,28 +30,5 @@
(and (not (equal? parent dir))
(not (file-exists? parent))
(create-directory* parent mode)
(create-directory dir mode))))))))
(define (with-stty spec thunk)
(thunk)))))
(cond-expand
(chibi
(import (chibi term edit-line)))
(else
(begin
(define (get-key ls key . o)
(let ((x (memq key ls)))
(if (and x (pair? (cdr x))) (cadr x) (and (pair? o) (car o)))))
(define (edit-line . args)
(let ((in (if (and (pair? args) (input-port? (car args)))
(car args)
(current-input-port)))
(out (if (and (eq? in (car args))
(pair? (cdr args))
(output-port? (cadr args)))
(cadr args)
(current-output-port)))
(prompter (get-key args 'prompt: "> ")))
(display (if (procedure? prompter) (prompter) prompter) out)
(flush-output-port out)
(read-line in))))))
(create-directory dir mode)))))))))))
(include "interface.scm"))

22
lib/chibi/term/edit-line.scm
View file

@ -1,6 +1,6 @@
;;;; edit-line.scm - pure scheme line editor
;;
;; Copyright (c) 2011-2012 Alex Shinn. All rights reserved.
;; Copyright (c) 2011-2017 Alex Shinn. All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -11,7 +11,7 @@
(write-char #\[ out)
(if arg (display arg out))
(write-char ch out)
(flush-output out))
(flush-output-port out))
;; we use zero-based columns
(define (terminal-goto-col out n) (terminal-escape out #\G (+ n 1)))
@ -430,7 +430,7 @@
(if (< (buffer-row buf) (buffer-max-row buf))
(terminal-up out (- (buffer-max-row buf) (buffer-row buf))))))
(terminal-goto-col out (buffer-col buf))
(flush-output out)
(flush-output-port out)
(buffer-cleared?-set! buf #f)))
(define (buffer-refresh buf out)
@ -481,7 +481,7 @@
(not (string-index #\newline x))))
;; fast path - append to end of buffer w/o wrapping to next line
(display x out)
(flush-output out)
(flush-output-port out)
(buffer-col-set! buf (+ (buffer-col buf) len))
(buffer-cleared?-set! buf #f))
(else
@ -662,7 +662,7 @@
(((buffer-complete? buf) buf)
(command/end-of-line ch buf out return)
(display "\r\n" out)
(flush-output out)
(flush-output-port out)
(return))
(else
(command/self-insert ch buf out return)))))
@ -679,7 +679,7 @@
(display "^C" out)
(newline out)
(stty out '(icanon isig echo))
(exit))
(return '^C))
(define (command/beep ch buf out return)
(write-char (integer->char 7) out))
@ -785,6 +785,7 @@
(single-line? (get-key args 'single-line?: #f))
(fresh-line (get-key args 'fresh-line: #f))
(no-stty? (get-key args 'no-stty?: #f))
(hidden? (get-key args 'hidden?: #f))
(keymap0 (get-key args 'keymap:
(if (get-key args 'catch-control-c?: #f)
standard-cancel-keymap
@ -797,6 +798,7 @@
(let* ((width (or terminal-width (get-terminal-width out) 80))
(prompt (if (procedure? prompter) (prompter) prompter))
(done? #f)
(tmp-out (if hidden? (open-output-string) out))
(return (lambda o (set! done? (if (pair? o) (car o) #t)))))
;; Maybe start at a fresh line.
(cond
@ -815,7 +817,7 @@
(buffer-single-line?-set! buf single-line?)
(if single-line? (buffer-start-set! buf (buffer-min buf)))
(buffer-refresh buf out)
(flush-output out)
(flush-output-port out)
((if no-stty? (lambda (out f) (f)) with-raw-io)
out
(lambda ()
@ -833,9 +835,9 @@
(buffer-clear buf out)
(print-exception exn out)
(buffer-draw buf out)))
(x ch buf out return))
(flush-output out)
(buffer-refresh buf out)
(x ch buf tmp-out return))
(flush-output-port tmp-out)
(buffer-refresh buf tmp-out)
(if done?
(and (not (eq? done? 'eof)) (buffer->string buf))
(lp keymap)))

29
lib/chibi/term/edit-line.sld
View file

@ -7,5 +7,32 @@
buffer-clear buffer-refresh buffer-draw
buffer-row buffer-col
make-keymap make-standard-keymap)
(import (chibi) (chibi ast) (chibi stty) (chibi process) (srfi 9) (srfi 33))
(import (scheme base) (scheme char) (scheme write))
(cond-expand
((library (srfi 33))
(import (srfi 33)))
(else
(import (srfi 60))))
(cond-expand
(chibi
(import (chibi stty)))
(chicken
(import stty))
(else
(define (with-stty spec thunk)
(thunk))))
(cond-expand
(chibi
(import (only (chibi) protect print-exception)
(chibi ast)))
(else
(begin
(define-syntax protect
(syntax-rules () (protect . x) (guard . x)))
(define (print-exception exn . o)
(let ((out (if (pair? o) (car o) (current-error-port))))
(write exn out)
(newline out)))
(define (exception? x) #f)
(define (exception-kind x) #f))))
(include "edit-line.scm"))