browser,renderer-gtk: Add native-dialogs toggle.

atlas-engineer · Jun 10, 2021 · 99ef351 · 99ef351
1 parent 022f1e8
commit 99ef351
Show file tree

Hide file tree

Showing 2 changed files with 58 additions and 52 deletions.
diff --git a/source/browser.lisp b/source/browser.lisp
@@ -117,6 +117,10 @@ issued by an external program or issued by Control+<button1> in a new window.")
             :reader ready-p
             :documentation "If non-nil, the browser is ready for operation (make
 buffers, load data files, open prompt buffer, etc).")
+   (native-dialogs t
+                   :type boolean
+                   :documentation "Whether to use prompt-buffer-reliant script dialogs and file-chooser.
+If nil, renderer-provided dialogs are used.")
    (session-restore-prompt :always-ask
                            :documentation "Ask whether to restore the session.
 The possible values are `:always-ask', `:always-restore' and `:never-restore'.")

diff --git a/source/renderer-gtk.lisp b/source/renderer-gtk.lisp
@@ -823,62 +823,64 @@ See `gtk-browser's `modifier-translator' slot."
   (gobject:g-signal-connect
    (gtk-object buffer) "script-dialog"
    (lambda (web-view dialog) (declare (ignore web-view))
-     (let ((dialog (gobject:pointer dialog)))
-       (webkit:webkit-script-dialog-ref dialog)
-       (run-thread
-         (case (webkit:webkit-script-dialog-get-dialog-type dialog)
-           (:webkit-script-dialog-alert (echo (webkit:webkit-script-dialog-get-message dialog)))
-           (:webkit-script-dialog-prompt
-            (webkit:webkit-script-dialog-prompt-set-text
-             dialog
-             (first
-              (prompt
-               :input (webkit:webkit-script-dialog-prompt-get-default-text dialog)
-               :prompt (webkit:webkit-script-dialog-get-message dialog)
-               :sources (list (make-instance 'prompter:raw-source))))))
-           ((:webkit-script-dialog-confirm :webkit-script-dialog-before-unload-confirm)
-            (webkit:webkit-script-dialog-confirm-set-confirmed
-             dialog (if-confirm
-                     ((webkit:webkit-script-dialog-get-message dialog))
-                     t nil))))
-         (webkit:webkit-script-dialog-close dialog)))
-     t))
+     (when (native-dialogs *browser*)
+       (let ((dialog (gobject:pointer dialog)))
+         (webkit:webkit-script-dialog-ref dialog)
+         (run-thread
+           (case (webkit:webkit-script-dialog-get-dialog-type dialog)
+             (:webkit-script-dialog-alert (echo (webkit:webkit-script-dialog-get-message dialog)))
+             (:webkit-script-dialog-prompt
+              (webkit:webkit-script-dialog-prompt-set-text
+               dialog
+               (first
+                (prompt
+                 :input (webkit:webkit-script-dialog-prompt-get-default-text dialog)
+                 :prompt (webkit:webkit-script-dialog-get-message dialog)
+                 :sources (list (make-instance 'prompter:raw-source))))))
+             ((:webkit-script-dialog-confirm :webkit-script-dialog-before-unload-confirm)
+              (webkit:webkit-script-dialog-confirm-set-confirmed
+               dialog (if-confirm
+                       ((webkit:webkit-script-dialog-get-message dialog))
+                       t nil))))
+           (webkit:webkit-script-dialog-close dialog))
+         t))))
   (gobject:g-signal-connect
    (gtk-object buffer) "run-file-chooser"
    (lambda (web-view file-chooser-request)
      (declare (ignore web-view))
-     (gobject:g-object-ref (gobject:pointer file-chooser-request))
-     (run-thread
-       (let ((files (mapcar
-                     #'namestring
-                     (prompt :prompt (format
-                                      nil "File~@[s~*~] to input"
-                                      (webkit:webkit-file-chooser-request-select-multiple
-                                       file-chooser-request))
-                             :input (or
-                                     (and
-                                      (webkit:webkit-file-chooser-request-selected-files
-                                       file-chooser-request)
-                                      (first
-                                       (webkit:webkit-file-chooser-request-selected-files
-                                        file-chooser-request)))
-                                     (namestring (uiop:getcwd)))
-                             :sources (list (make-instance 'file-source))))))
-         (when files
-           (webkit:webkit-file-chooser-request-select-files
-            file-chooser-request
-            (cffi:foreign-alloc :string
-                                :initial-contents (if (webkit:webkit-file-chooser-request-select-multiple
-                                                       file-chooser-request)
-                                                      (mapcar #'cffi:foreign-string-alloc files)
-                                                      (list (cffi:foreign-string-alloc (first files))))
-                                :count (if (webkit:webkit-file-chooser-request-select-multiple
-                                            file-chooser-request)
-                                           (length files)
-                                           1)
-                                :null-terminated-p t)))
-         (webkit:webkit-file-chooser-request-cancel file-chooser-request)))
-     t))
+     (when (native-dialogs *browser*)
+       (gobject:g-object-ref (gobject:pointer file-chooser-request))
+       (run-thread
+         (let ((files (mapcar
+                       #'namestring
+                       (prompt :prompt (format
+                                        nil "File~@[s~*~] to input"
+                                        (webkit:webkit-file-chooser-request-select-multiple
+                                         file-chooser-request))
+                               :input (or
+                                       (and
+                                        (webkit:webkit-file-chooser-request-selected-files
+                                         file-chooser-request)
+                                        (first
+                                         (webkit:webkit-file-chooser-request-selected-files
+                                          file-chooser-request)))
+                                       (namestring (uiop:getcwd)))
+                               :sources (list (make-instance 'file-source))))))
+           (when files
+             (webkit:webkit-file-chooser-request-select-files
+              file-chooser-request
+              (cffi:foreign-alloc :string
+                                  :initial-contents (if (webkit:webkit-file-chooser-request-select-multiple
+                                                         file-chooser-request)
+                                                        (mapcar #'cffi:foreign-string-alloc files)
+                                                        (list (cffi:foreign-string-alloc (first files))))
+                                  :count (if (webkit:webkit-file-chooser-request-select-multiple
+                                              file-chooser-request)
+                                             (length files)
+                                             1)
+                                  :null-terminated-p t)))
+           (webkit:webkit-file-chooser-request-cancel file-chooser-request)
+           t)))))
   ;; TLS certificate handling
   (gobject:g-signal-connect
    (gtk-object buffer) "load-failed-with-tls-errors"