~ chicken-core (chicken-5) c31ecdad7ac305b03c4ab841a9a307ccd221392f
commit c31ecdad7ac305b03c4ab841a9a307ccd221392f
Author: felix <bunny351@gmail.com>
AuthorDate: Fri May 28 11:56:57 2010 +0200
Commit: felix <bunny351@gmail.com>
CommitDate: Fri May 28 11:56:57 2010 +0200
moved yes-or-no? from setup-api into utils
diff --git a/chicken-install.scm b/chicken-install.scm
index 5645c562..faca7081 100644
--- a/chicken-install.scm
+++ b/chicken-install.scm
@@ -320,7 +320,8 @@
(or *force*
(yes-or-no?
(make-replace-extension-question e+d+v upgrade)
- "no") ) )
+ "no"
+ abort: abort-setup) ) )
(let ([ueggs (unzip1 upgrade)])
(print " upgrade: " (string-intersperse ueggs ", "))
(for-each
@@ -396,7 +397,8 @@
(not (yes-or-no?
(string-append
"You specified `-no-install', but this extension has dependencies"
- " that are required for building. Do you still want to install them?"))))
+ " that are required for building. Do you still want to install them?")
+ abort: abort-setup)))
(print "aborting installation.")
(cleanup)
(exit 1)))
diff --git a/chicken-uninstall.scm b/chicken-uninstall.scm
index 7a7f35db..7bd1366d 100644
--- a/chicken-uninstall.scm
+++ b/chicken-uninstall.scm
@@ -69,7 +69,8 @@
'("About to delete the following extensions:\n\n")
(map (cut string-append " " <> "\n") eggs)
'("\nDo you want to proceed?")))
- default: "no")))
+ default: "no"
+ abort: abort-setup)))
(define (uninstall pats)
(let ((eggs (gather-eggs pats)))
diff --git a/manual/Unit utils b/manual/Unit utils
index 3def9017..d4515bbe 100644
--- a/manual/Unit utils
+++ b/manual/Unit utils
@@ -95,6 +95,24 @@ if the match succeeds. If no match could be found, {{#f}} is returned.
input line and should return a non-false value on success.
+=== Asking the user for confirmation
+
+==== yes-or-no?
+
+<procedure>(yes-or-no? MESSAGE #!key default title abort)</procedure>
+
+Prints the string {{MESSAGE}} and asks for entering "yes", "no" or "abort".
+If running under Windows in GUI mode, then a suitable dialog box is shown.
+Returns either {{#t}} or {{#f}} depending on whether {{yes}} or {{no}}
+was entered. The {{default}} keyword argument specifies the default
+answer that is effective if the user just presses ENTER (or the default
+button in case of a dialog box). {{title}} specifies the text shown
+in the caption of the dialog box and is ignored when not running in
+GUI mode. {{abort}} should be a zero-argument procedure that is
+called when the user selects "abort". The default value for {{abort}}
+is the {{reset}} procedure.
+
+
Previous: [[Unit posix]]
Next: [[Unit tcp]]
diff --git a/setup-api.scm b/setup-api.scm
index 018f51ed..4093aebb 100644
--- a/setup-api.scm
+++ b/setup-api.scm
@@ -48,7 +48,7 @@
chicken-prefix ;XXX remove at some stage from exports
find-library find-header
program-path remove-file*
- patch yes-or-no? abort-setup
+ patch abort-setup
setup-root-directory create-directory/parents
test-compile try-compile run-verbose
extra-features
@@ -174,21 +174,6 @@
(define abort-setup (make-parameter (cut exit 1)))
-(define (yes-or-no? str #!key default (abort (abort-setup)))
- (let loop ()
- (printf "~%~A (yes/no/abort) " str)
- (when default (printf "[~A] " default))
- (flush-output)
- (let ((ln (read-line)))
- (cond ((eof-object? ln) (set! ln "abort"))
- ((and default (string=? "" ln)) (set! ln default)) )
- (cond ((string-ci=? "yes" ln) #t)
- ((string-ci=? "no" ln) #f)
- ((string-ci=? "abort" ln) (abort))
- (else
- (printf "~%Please enter \"yes\", \"no\" or \"abort\".~%")
- (loop) ) ) ) ) )
-
(define (patch which rx subst)
(when (setup-verbose-mode) (printf "patching ~A ...~%" which))
(if (list? which)
diff --git a/tests/scrutiny.expected b/tests/scrutiny.expected
index e2d77ff8..9c5c82a8 100644
--- a/tests/scrutiny.expected
+++ b/tests/scrutiny.expected
@@ -45,4 +45,4 @@ Warning: at toplevel:
Warning: at toplevel:
g89: in procedure call to `g89', expected a value of type `(procedure () *)', but were given a value of type `fixnum'
-Warning: redefinition of standard binding `car'
+Warning: redefinition of standard binding: car
diff --git a/types.db b/types.db
index c00375ae..a6b39ffb 100644
--- a/types.db
+++ b/types.db
@@ -1398,5 +1398,4 @@
(compile-file (procedure compile-file (string #!rest) string))
(compile-file-options (procedure compile-file-options (#!optional list) list))
(scan-input-lines (procedure scan-input-lines (* #!optional port) *))
-
-;; missing: setup-api, setup-download
+(yes-or-no? (procedure yes-or-no? (string #!rest) *))
diff --git a/utils.import.scm b/utils.import.scm
index 24c710f6..5c27ba6a 100644
--- a/utils.import.scm
+++ b/utils.import.scm
@@ -30,4 +30,5 @@
system*
qs
compile-file
- scan-input-lines))
+ scan-input-lines
+ yes-or-no?))
diff --git a/utils.scm b/utils.scm
index 318c1f46..8bc9522b 100644
--- a/utils.scm
+++ b/utils.scm
@@ -127,3 +127,69 @@
(and (not (eof-object? ln))
(or (rx ln)
(loop)))))))))
+
+
+;; Ask for confirmation
+
+#>
+#if defined(_WIN32) && !defined(__CYGWIN__)
+# include <windows.h>
+# define C_HAS_MESSAGE_BOX 1
+static int
+C_confirmation_dialog(char *msg, char *caption, int def)
+{
+ int d = 0, r;
+
+ switch(def) {
+ case 0: d = MB_DEFBUTTON1; break;
+ case 1: d = MB_DEFBUTTON2; break;
+ case 2: d = MB_DEFBUTTON3;
+ }
+
+ r = MessageBox(NULL, msg, caption, MB_YESNOCANCEL | MB_ICONQUESTION | d);
+
+ switch(r) {
+ case IDYES: return 1;
+ case IDNO: return 0;
+ default: return -1;
+ }
+}
+#else
+# define C_HAS_MESSAGE_BOX 0
+static int
+C_confirmation_dialog(char *msg, char *caption, int def) { return -1; }
+#endif
+<#
+
+(define-foreign-variable C_HAS_MESSAGE_BOX bool)
+
+(define yes-or-no?
+ (let ((dialog (foreign-lambda int "C_confirmation_dialog" c-string c-string int)))
+ (lambda (str #!key default title (abort reset))
+ (define (get-input)
+ (if C_HAS_MESSAGE_BOX
+ (let ((r (dialog
+ str
+ (or title "CHICKEN Runtime")
+ (cond ((string-ci=? default "yes") 0)
+ ((string-ci=? default "no") 1)
+ (else 2)))))
+ (case r
+ ((0) "no")
+ ((1) "yes")
+ (else "abort")))
+ (string-trim-both (read-line))))
+ (let loop ()
+ (printf "~%~A (yes/no/abort) " str)
+ (when default (printf "[~A] " default))
+ (flush-output)
+ (let ((ln (get-input)))
+ (cond ((eof-object? ln) (set! ln "abort"))
+ ((and default (string=? "" ln)) (set! ln default)) )
+ (cond ((string-ci=? "yes" ln) #t)
+ ((string-ci=? "no" ln) #f)
+ ((string-ci=? "abort" ln) (abort))
+ (else
+ (printf "~%Please enter \"yes\", \"no\" or \"abort\".~%")
+ (loop) ) ) ) ) ) ) )
+
Trap