summaryrefslogtreecommitdiff
path: root/gnu/installer/newt/page.scm
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2020-01-22 22:57:14 +0100
committerLudovic Courtès <ludo@gnu.org>2020-03-05 23:40:22 +0100
commit63b8c089c1596cd3e814ac13e1a8b3fa45bb2b54 (patch)
treea60aa9c44ad5e7b51ef4621e5b5609f9552cf100 /gnu/installer/newt/page.scm
parent5ce84b1713b847c860345fc9199c44e3e6d513bb (diff)
installer: Implement a dialog on /var/guix/installer-socket.
This will allow us to automate testing of the installer. * gnu/installer/utils.scm (%client-socket-file) (current-server-socket, current-clients): New variables. (open-server-socket, call-with-server-socket): New procedure. (with-server-socket): New macro. (run-shell-command): Add call to 'send-to-clients'. Select on both current-input-port and current-clients. * gnu/installer/steps.scm (run-installer-steps): Wrap 'call-with-prompt' in 'with-socket-server'. Call 'sigaction' for SIGPIPE. * gnu/installer/newt/page.scm (watch-clients!, close-port-and-reuse-fd) (run-form-with-clients, send-to-clients): New procedures. (draw-info-page): Add call to 'run-form-with-clients'. (run-input-page): Likewise. Handle EXIT-REASON equal to 'exit-fd-ready. (run-confirmation-page): Likewise. (run-listbox-selection-page): Likewise. Define 'choice->item' and use it. (run-checkbox-tree-page): Likewise. (run-file-textbox-page): Add call to 'run-form-with-clients'. Handle 'exit-fd-ready'. * gnu/installer/newt/partition.scm (run-disk-page): Pass #:client-callback-procedure to 'run-listbox-selection-page'. * gnu/installer/newt/user.scm (run-user-page): Call 'run-form-with-clients'. Handle 'exit-fd-ready'. * gnu/installer/newt/welcome.scm (run-menu-page): Define 'choice->item' and use it. Call 'run-form-with-clients'. * gnu/installer/newt/final.scm (run-install-success-page) (run-install-failed-page): When (current-clients) is non-empty, call 'send-to-clients' without displaying a choice window.
Diffstat (limited to 'gnu/installer/newt/page.scm')
-rw-r--r--gnu/installer/newt/page.scm582
1 files changed, 381 insertions, 201 deletions
diff --git a/gnu/installer/newt/page.scm b/gnu/installer/newt/page.scm
index 8aea5a1109..c01124aa0d 100644
--- a/gnu/installer/newt/page.scm
+++ b/gnu/installer/newt/page.scm
@@ -19,6 +19,7 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (gnu installer newt page)
+ #:use-module (gnu installer steps)
#:use-module (gnu installer utils)
#:use-module (gnu installer newt utils)
#:use-module (guix i18n)
@@ -26,7 +27,10 @@
#:use-module (ice-9 match)
#:use-module (ice-9 receive)
#:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
+ #:use-module (srfi srfi-34)
+ #:use-module (srfi srfi-35)
#:use-module (newt)
#:export (draw-info-page
draw-connecting-page
@@ -36,7 +40,9 @@
run-listbox-selection-page
run-scale-page
run-checkbox-tree-page
- run-file-textbox-page))
+ run-file-textbox-page
+
+ run-form-with-clients))
;;; Commentary:
;;;
@@ -49,9 +55,123 @@
;;;
;;; Code:
+(define* (watch-clients! form #:optional (clients (current-clients)))
+ "Have FORM watch the file descriptors corresponding to current client
+connections. Consequently, FORM may exit with the 'exit-fd-ready' reason."
+ (when (current-server-socket)
+ (form-watch-fd form (fileno (current-server-socket))
+ FD-READ))
+
+ (for-each (lambda (client)
+ (form-watch-fd form (fileno client)
+ (logior FD-READ FD-EXCEPT)))
+ clients))
+
+(define close-port-and-reuse-fd
+ (let ((bit-bucket #f))
+ (lambda (port)
+ "Close PORT and redirect its underlying FD to point to a valid open file
+descriptor."
+ (let ((fd (fileno port)))
+ (unless bit-bucket
+ (set! bit-bucket (car (pipe))))
+ (close-port port)
+
+ ;; FIXME: We're leaking FD.
+ (dup2 (fileno bit-bucket) fd)))))
+
+(define* (run-form-with-clients form exp)
+ "Run FORM such as it watches the file descriptors beneath CLIENTS after
+sending EXP to all the clients.
+
+Automatically restart the form when it exits with 'exit-fd-ready but without
+an actual client reply--e.g., it got a connection request or a client
+disconnect.
+
+Like 'run-form', return two values: the exit reason, and an \"argument\"."
+ (define* (discard-client! port #:optional errno)
+ (if errno
+ (syslog "removing client ~d due to ~s~%"
+ (fileno port) (strerror errno))
+ (syslog "removing client ~d due to EOF~%"
+ (fileno port)))
+
+ ;; XXX: Watch out! There's no 'form-unwatch-fd' procedure in Newt so we
+ ;; cheat: we keep PORT's file descriptor open, but make it a duplicate of
+ ;; a valid but inactive FD. Failing to do that, 'run-form' would
+ ;; select(2) on the now-closed port and keep spinning as select(2) returns
+ ;; EBADF.
+ (close-port-and-reuse-fd port)
+
+ (current-clients (delq port (current-clients)))
+ (close-port port))
+
+ (define title
+ ;; Title of FORM.
+ (match exp
+ (((? symbol? tag) alist ...)
+ (match (assq 'title alist)
+ ((_ title) title)
+ (_ tag)))
+ (((? symbol? tag) _ ...)
+ tag)
+ (_
+ 'unknown)))
+
+ ;; Send EXP to all the currently-connected clients.
+ (send-to-clients exp)
+
+ (let loop ()
+ (syslog "running form ~s (~s) with ~d clients~%"
+ form title (length (current-clients)))
+
+ ;; Call 'watch-clients!' within the loop because there might be new
+ ;; clients.
+ (watch-clients! form)
+
+ (let-values (((reason argument) (run-form form)))
+ (match reason
+ ('exit-fd-ready
+ (match (fdes->ports argument)
+ ((port _ ...)
+ (if (memq port (current-clients))
+
+ ;; Read a reply from a client or handle its departure.
+ (catch 'system-error
+ (lambda ()
+ (match (read port)
+ ((? eof-object? eof)
+ (discard-client! port)
+ (loop))
+ (obj
+ (syslog "form ~s (~s): client ~d replied ~s~%"
+ form title (fileno port) obj)
+ (values 'exit-fd-ready obj))))
+ (lambda args
+ (discard-client! port (system-error-errno args))
+ (loop)))
+
+ ;; Accept a new client and send it EXP.
+ (match (accept port)
+ ((client . _)
+ (syslog "accepting new client ~d while on form ~s~%"
+ (fileno client) form)
+ (catch 'system-error
+ (lambda ()
+ (write exp client)
+ (newline client)
+ (force-output client)
+ (current-clients (cons client (current-clients))))
+ (lambda _
+ (close-port client)))
+ (loop)))))))
+ (_
+ (values reason argument))))))
+
(define (draw-info-page text title)
"Draw an informative page with the given TEXT as content. Set the title of
this page to TITLE."
+ (send-to-clients `(info (title ,title) (text ,text)))
(let* ((text-box
(make-reflowed-textbox -1 -1 text 40
#:flags FLAG-BORDER))
@@ -126,20 +246,25 @@ input box, such as FLAG-PASSWORD."
(G_ "Empty input")))))
(let loop ()
(receive (exit-reason argument)
- (run-form form)
- (let ((input (entry-value input-entry)))
- (if (and (not allow-empty-input?)
- (eq? exit-reason 'exit-component)
- (string=? input ""))
- (begin
- ;; Display the error page.
- (error-page)
- ;; Set the focus back to the input input field.
- (set-current-component form input-entry)
- (loop))
- (begin
- (destroy-form-and-pop form)
- input))))))))
+ (run-form-with-clients form
+ `(input (title ,title) (text ,text)
+ (default ,default-text)))
+ (let ((input (if (eq? exit-reason 'exit-fd-ready)
+ argument
+ (entry-value input-entry))))
+ (cond ((not input) ;client disconnect or something
+ (loop))
+ ((and (not allow-empty-input?)
+ (eq? exit-reason 'exit-component)
+ (string=? input ""))
+ ;; Display the error page.
+ (error-page)
+ ;; Set the focus back to the input input field.
+ (set-current-component form input-entry)
+ (loop))
+ (else
+ (destroy-form-and-pop form)
+ input))))))))
(define (run-error-page text title)
"Run a page to inform the user of an error. The page contains the given TEXT
@@ -160,7 +285,8 @@ of the page is set to TITLE."
(newt-set-color COLORSET-ROOT "white" "red")
(add-components-to-form form text-box ok-button)
(make-wrapped-grid-window grid title)
- (run-form form)
+ (run-form-with-clients form
+ `(error (title ,title) (text ,text)))
;; Restore the background to its original color.
(newt-set-color COLORSET-ROOT "white" "blue")
(destroy-form-and-pop form)))
@@ -187,17 +313,23 @@ of the page is set to TITLE."
(make-wrapped-grid-window grid title)
(receive (exit-reason argument)
- (run-form form)
+ (run-form-with-clients form
+ `(confirmation (title ,title)
+ (text ,text)))
(dynamic-wind
(const #t)
(lambda ()
- (case exit-reason
- ((exit-component)
+ (match exit-reason
+ ('exit-component
(cond
((components=? argument ok-button)
#t)
((components=? argument exit-button)
- (exit-button-procedure))))))
+ (exit-button-procedure))))
+ ('exit-fd-ready
+ (if argument
+ #t
+ (exit-button-procedure)))))
(lambda ()
(destroy-form-and-pop form))))))
@@ -222,6 +354,8 @@ of the page is set to TITLE."
(const #t))
(listbox-callback-procedure
identity)
+ (client-callback-procedure
+ listbox-callback-procedure)
(hotkey-callback-procedure
(const #t)))
"Run a page asking the user to select an item in a listbox. The page
@@ -254,9 +388,9 @@ Each time the listbox current item changes, call SKIP-ITEM-PROCEDURE? with the
current listbox item as argument. If it returns #t, skip the element and jump
to the next/previous one depending on the previous item, otherwise do
nothing."
-
- (define (fill-listbox listbox items)
- "Append the given ITEMS to LISTBOX, once they have been converted to text
+ (let loop ()
+ (define (fill-listbox listbox items)
+ "Append the given ITEMS to LISTBOX, once they have been converted to text
with LISTBOX-ITEM->TEXT. Each item appended to the LISTBOX is given a key by
newt. Save this key by returning an association list under the form:
@@ -264,144 +398,165 @@ newt. Save this key by returning an association list under the form:
where NEWT-LISTBOX-KEY is the key returned by APPEND-ENTRY-TO-LISTBOX, when
ITEM was inserted into LISTBOX."
- (map (lambda (item)
- (let* ((text (listbox-item->text item))
- (key (append-entry-to-listbox listbox text)))
- (cons key item)))
- items))
-
- (define (sort-listbox-items listbox-items)
- "Return LISTBOX-ITEMS sorted using the 'string-locale<?' procedure on the text
+ (map (lambda (item)
+ (let* ((text (listbox-item->text item))
+ (key (append-entry-to-listbox listbox text)))
+ (cons key item)))
+ items))
+
+ (define (sort-listbox-items listbox-items)
+ "Return LISTBOX-ITEMS sorted using the 'string-locale<?' procedure on the text
corresponding to each item in the list."
- (let* ((items (map (lambda (item)
- (cons item (listbox-item->text item)))
- listbox-items))
- (sorted-items
- (sort items (lambda (a b)
- (let ((text-a (cdr a))
- (text-b (cdr b)))
- (string-locale<? text-a text-b))))))
- (map car sorted-items)))
-
- ;; Store the last selected listbox item's key.
- (define last-listbox-key (make-parameter #f))
-
- (define (previous-key keys key)
- (let ((index (list-index (cut eq? key <>) keys)))
- (and index
- (> index 0)
- (list-ref keys (- index 1)))))
-
- (define (next-key keys key)
- (let ((index (list-index (cut eq? key <>) keys)))
- (and index
- (< index (- (length keys) 1))
- (list-ref keys (+ index 1)))))
-
- (define (set-default-item listbox listbox-keys default-item)
- "Set the default item of LISTBOX to DEFAULT-ITEM. LISTBOX-KEYS is the
+ (let* ((items (map (lambda (item)
+ (cons item (listbox-item->text item)))
+ listbox-items))
+ (sorted-items
+ (sort items (lambda (a b)
+ (let ((text-a (cdr a))
+ (text-b (cdr b)))
+ (string-locale<? text-a text-b))))))
+ (map car sorted-items)))
+
+ ;; Store the last selected listbox item's key.
+ (define last-listbox-key (make-parameter #f))
+
+ (define (previous-key keys key)
+ (let ((index (list-index (cut eq? key <>) keys)))
+ (and index
+ (> index 0)
+ (list-ref keys (- index 1)))))
+
+ (define (next-key keys key)
+ (let ((index (list-index (cut eq? key <>) keys)))
+ (and index
+ (< index (- (length keys) 1))
+ (list-ref keys (+ index 1)))))
+
+ (define (set-default-item listbox listbox-keys default-item)
+ "Set the default item of LISTBOX to DEFAULT-ITEM. LISTBOX-KEYS is the
association list returned by the FILL-LISTBOX procedure. It is used because
the current listbox item has to be selected by key."
- (for-each (match-lambda
- ((key . item)
- (when (equal? item default-item)
- (set-current-listbox-entry-by-key listbox key))))
- listbox-keys))
-
- (let* ((listbox (make-listbox
- -1 -1
- listbox-height
- (logior FLAG-SCROLL FLAG-BORDER FLAG-RETURNEXIT
- (if listbox-allow-multiple?
- FLAG-MULTIPLE
- 0))))
- (form (make-form #:flags FLAG-NOF12))
- (info-textbox
- (make-reflowed-textbox -1 -1 info-text
- info-textbox-width
- #:flags FLAG-BORDER))
- (button (make-button -1 -1 button-text))
- (button2 (and button2-text
- (make-button -1 -1 button2-text)))
- (grid (vertically-stacked-grid
- GRID-ELEMENT-COMPONENT info-textbox
- GRID-ELEMENT-COMPONENT listbox
- GRID-ELEMENT-SUBGRID
- (apply
- horizontal-stacked-grid
- GRID-ELEMENT-COMPONENT button
- `(,@(if button2
- (list GRID-ELEMENT-COMPONENT button2)
- '())))))
- (sorted-items (if sort-listbox-items?
- (sort-listbox-items listbox-items)
- listbox-items))
- (keys (fill-listbox listbox sorted-items)))
-
- ;; On every listbox element change, check if we need to skip it. If yes,
- ;; depending on the 'last-listbox-key', jump forward or backward. If no,
- ;; do nothing.
- (add-component-callback
- listbox
- (lambda (component)
- (let* ((current-key (current-listbox-entry listbox))
- (listbox-keys (map car keys))
- (last-key (last-listbox-key))
- (item (assoc-ref keys current-key))
- (prev-key (previous-key listbox-keys current-key))
- (next-key (next-key listbox-keys current-key)))
- ;; Update last-listbox-key before a potential call to
- ;; set-current-listbox-entry-by-key, because it will immediately
- ;; cause this callback to be called for the new entry.
- (last-listbox-key current-key)
- (when (skip-item-procedure? item)
- (when (eq? prev-key last-key)
- (if next-key
- (set-current-listbox-entry-by-key listbox next-key)
- (set-current-listbox-entry-by-key listbox prev-key)))
- (when (eq? next-key last-key)
- (if prev-key
- (set-current-listbox-entry-by-key listbox prev-key)
- (set-current-listbox-entry-by-key listbox next-key)))))))
-
- (when listbox-default-item
- (set-default-item listbox keys listbox-default-item))
-
- (when allow-delete?
- (form-add-hotkey form KEY-DELETE))
+ (for-each (match-lambda
+ ((key . item)
+ (when (equal? item default-item)
+ (set-current-listbox-entry-by-key listbox key))))
+ listbox-keys))
+
+ (let* ((listbox (make-listbox
+ -1 -1
+ listbox-height
+ (logior FLAG-SCROLL FLAG-BORDER FLAG-RETURNEXIT
+ (if listbox-allow-multiple?
+ FLAG-MULTIPLE
+ 0))))
+ (form (make-form #:flags FLAG-NOF12))
+ (info-textbox
+ (make-reflowed-textbox -1 -1 info-text
+ info-textbox-width
+ #:flags FLAG-BORDER))
+ (button (make-button -1 -1 button-text))
+ (button2 (and button2-text
+ (make-button -1 -1 button2-text)))
+ (grid (vertically-stacked-grid
+ GRID-ELEMENT-COMPONENT info-textbox
+ GRID-ELEMENT-COMPONENT listbox
+ GRID-ELEMENT-SUBGRID
+ (apply
+ horizontal-stacked-grid
+ GRID-ELEMENT-COMPONENT button
+ `(,@(if button2
+ (list GRID-ELEMENT-COMPONENT button2)
+ '())))))
+ (sorted-items (if sort-listbox-items?
+ (sort-listbox-items listbox-items)
+ listbox-items))
+ (keys (fill-listbox listbox sorted-items)))
+
+ (define (choice->item str)
+ ;; Return the item that corresponds to STR.
+ (match (find (match-lambda
+ ((key . item)
+ (string=? str (listbox-item->text item))))
+ keys)
+ ((key . item) item)
+ (#f (raise (condition (&installer-step-abort))))))
+
+ ;; On every listbox element change, check if we need to skip it. If yes,
+ ;; depending on the 'last-listbox-key', jump forward or backward. If no,
+ ;; do nothing.
+ (add-component-callback
+ listbox
+ (lambda (component)
+ (let* ((current-key (current-listbox-entry listbox))
+ (listbox-keys (map car keys))
+ (last-key (last-listbox-key))
+ (item (assoc-ref keys current-key))
+ (prev-key (previous-key listbox-keys current-key))
+ (next-key (next-key listbox-keys current-key)))
+ ;; Update last-listbox-key before a potential call to
+ ;; set-current-listbox-entry-by-key, because it will immediately
+ ;; cause this callback to be called for the new entry.
+ (last-listbox-key current-key)
+ (when (skip-item-procedure? item)
+ (when (eq? prev-key last-key)
+ (if next-key
+ (set-current-listbox-entry-by-key listbox next-key)
+ (set-current-listbox-entry-by-key listbox prev-key)))
+ (when (eq? next-key last-key)
+ (if prev-key
+ (set-current-listbox-entry-by-key listbox prev-key)
+ (set-current-listbox-entry-by-key listbox next-key)))))))
+
+ (when listbox-default-item
+ (set-default-item listbox keys listbox-default-item))
+
+ (when allow-delete?
+ (form-add-hotkey form KEY-DELETE))
- (add-form-to-grid grid form #t)
- (make-wrapped-grid-window grid title)
+ (add-form-to-grid grid form #t)
+ (make-wrapped-grid-window grid title)
- (receive (exit-reason argument)
- (run-form form)
- (dynamic-wind
- (const #t)
- (lambda ()
- (case exit-reason
- ((exit-component)
- (cond
- ((components=? argument button)
- (button-callback-procedure))
- ((and button2
- (components=? argument button2))
- (button2-callback-procedure))
- ((components=? argument listbox)
- (if listbox-allow-multiple?
- (let* ((entries (listbox-selection listbox))
- (items (map (lambda (entry)
- (assoc-ref keys entry))
- entries)))
- (listbox-callback-procedure items))
- (let* ((entry (current-listbox-entry listbox))
- (item (assoc-ref keys entry)))
- (listbox-callback-procedure item))))))
- ((exit-hotkey)
- (let* ((entry (current-listbox-entry listbox))
- (item (assoc-ref keys entry)))
- (hotkey-callback-procedure argument item)))))
- (lambda ()
- (destroy-form-and-pop form))))))
+ (receive (exit-reason argument)
+ (run-form-with-clients form
+ `(list-selection (title ,title)
+ (multiple-choices?
+ ,listbox-allow-multiple?)
+ (items
+ ,(map listbox-item->text
+ listbox-items))))
+ (dynamic-wind
+ (const #t)
+ (lambda ()
+ (match exit-reason
+ ('exit-component
+ (cond
+ ((components=? argument button)
+ (button-callback-procedure))
+ ((and button2
+ (components=? argument button2))
+ (button2-callback-procedure))
+ ((components=? argument listbox)
+ (if listbox-allow-multiple?
+ (let* ((entries (listbox-selection listbox))
+ (items (map (lambda (entry)
+ (assoc-ref keys entry))
+ entries)))
+ (listbox-callback-procedure items))
+ (let* ((entry (current-listbox-entry listbox))
+ (item (assoc-ref keys entry)))
+ (listbox-callback-procedure item))))))
+ ('exit-fd-ready
+ (let* ((choice argument)
+ (item (if listbox-allow-multiple?
+ (map choice->item choice)
+ (choice->item choice))))
+ (client-callback-procedure item)))
+ ('exit-hotkey
+ (let* ((entry (current-listbox-entry listbox))
+ (item (assoc-ref keys entry)))
+ (hotkey-callback-procedure argument item)))))
+ (lambda ()
+ (destroy-form-and-pop form)))))))
(define* (run-scale-page #:key
title
@@ -498,48 +653,65 @@ ITEMS when 'Ok' is pressed."
items
selection))
- (let* ((checkbox-tree
- (make-checkboxtree -1 -1
- checkbox-tree-height
- FLAG-BORDER))
- (info-textbox
- (make-reflowed-textbox -1 -1 info-text
- info-textbox-width
- #:flags FLAG-BORDER))
- (ok-button (make-button -1 -1 (G_ "OK")))
- (exit-button (make-button -1 -1 (G_ "Exit")))
- (grid (vertically-stacked-grid
- GRID-ELEMENT-COMPONENT info-textbox
- GRID-ELEMENT-COMPONENT checkbox-tree
- GRID-ELEMENT-SUBGRID
- (horizontal-stacked-grid
- GRID-ELEMENT-COMPONENT ok-button
- GRID-ELEMENT-COMPONENT exit-button)))
- (keys (fill-checkbox-tree checkbox-tree items))
- (form (make-form #:flags FLAG-NOF12)))
+ (let loop ()
+ (let* ((checkbox-tree
+ (make-checkboxtree -1 -1
+ checkbox-tree-height
+ FLAG-BORDER))
+ (info-textbox
+ (make-reflowed-textbox -1 -1 info-text
+ info-textbox-width
+ #:flags FLAG-BORDER))
+ (ok-button (make-button -1 -1 (G_ "OK")))
+ (exit-button (make-button -1 -1 (G_ "Exit")))
+ (grid (vertically-stacked-grid
+ GRID-ELEMENT-COMPONENT info-textbox
+ GRID-ELEMENT-COMPONENT checkbox-tree
+ GRID-ELEMENT-SUBGRID
+ (horizontal-stacked-grid
+ GRID-ELEMENT-COMPONENT ok-button
+ GRID-ELEMENT-COMPONENT exit-button)))
+ (keys (fill-checkbox-tree checkbox-tree items))
+ (form (make-form #:flags FLAG-NOF12)))
- (add-form-to-grid grid form #t)
- (make-wrapped-grid-window grid title)
+ (define (choice->item str)
+ ;; Return the item that corresponds to STR.
+ (match (find (match-lambda
+ ((key . item)
+ (string=? str (item->text item))))
+ keys)
+ ((key . item) item)
+ (#f (raise (condition (&installer-step-abort))))))
- (receive (exit-reason argument)
- (run-form form)
- (dynamic-wind
- (const #t)
- (lambda ()
- (case exit-reason
- ((exit-component)
- (cond
- ((components=? argument ok-button)
- (let* ((entries (current-checkbox-selection checkbox-tree))
- (current-items (map (lambda (entry)
- (assoc-ref keys entry))
- entries)))
- (ok-button-callback-procedure)
- current-items))
- ((components=? argument exit-button)
- (exit-button-callback-procedure))))))
- (lambda ()
- (destroy-form-and-pop form))))))
+ (add-form-to-grid grid form #t)
+ (make-wrapped-grid-window grid title)
+
+ (receive (exit-reason argument)
+ (run-form-with-clients form
+ `(checkbox-list (title ,title)
+ (text ,info-text)
+ (items
+ ,(map item->text items))))
+ (dynamic-wind
+ (const #t)
+
+ (lambda ()
+ (match exit-reason
+ ('exit-component
+ (cond
+ ((components=? argument ok-button)
+ (let* ((entries (current-checkbox-selection checkbox-tree))
+ (current-items (map (lambda (entry)
+ (assoc-ref keys entry))
+ entries)))
+ (ok-button-callback-procedure)
+ current-items))
+ ((components=? argument exit-button)
+ (exit-button-callback-procedure))))
+ ('exit-fd-ready
+ (map choice->item argument))))
+ (lambda ()
+ (destroy-form-and-pop form)))))))
(define* (edit-file file #:key locale)
"Spawn an editor for FILE."
@@ -606,13 +778,16 @@ ITEMS when 'Ok' is pressed."
text))
(receive (exit-reason argument)
- (run-form form)
+ (run-form-with-clients form
+ `(file-dialog (title ,title)
+ (text ,info-text)
+ (file ,file)))
(define result
(dynamic-wind
(const #t)
(lambda ()
- (case exit-reason
- ((exit-component)
+ (match exit-reason
+ ('exit-component
(cond
((components=? argument ok-button)
(ok-button-callback-procedure))
@@ -621,10 +796,15 @@ ITEMS when 'Ok' is pressed."
(exit-button-callback-procedure))
((and edit-button?
(components=? argument edit-button))
- (edit-file file))))))
+ (edit-file file))))
+ ('exit-fd-ready
+ (if argument
+ (ok-button-callback-procedure)
+ (exit-button-callback-procedure)))))
(lambda ()
(destroy-form-and-pop form))))
- (if (components=? argument edit-button)
+ (if (and (eq? exit-reason 'exit-component)
+ (components=? argument edit-button))
(loop) ;recurse in tail position
result)))))