- made the event-queue optionally blocking (block the caller thread if empty).

- added parent window to the dialog.

src/gui/client/program-events.lisp

@@ -18,4 +18,4 @@
   (bt:make-thread (lambda ()
                     (loop while (events-loop-running-p) do
                       (when (not (ev:stop-event-dispatching-p))
-                        (ev:dispatch-program-events))))))
+                        (ev:dispatch-program-events-or-wait))))))

src/package.lisp

@@ -1592,6 +1592,8 @@
    :reinitialize-id
    :events-queue
    :lock
+   :push-event-unblock
+   :pop-event-block
    :push-event
    :event-available-p
    :pop-event
@@ -1703,7 +1705,8 @@
    :send-to-pipe-event
    :print-mentions-event
    :delete-all-notifications-event
-   :dispatch-program-events))
+   :dispatch-program-events
+   :dispatch-program-events-or-wait))
 
 (defpackage :api-pleroma
   (:use
@@ -3249,6 +3252,19 @@
    :stop-events-loop
    :start-events-loop))
 
+(defpackage :client-main-window
+  (:use
+   :cl
+   :config
+   :constants
+   :text-utils
+   :misc-utils)
+  (:local-nicknames (:re :cl-ppcre)
+                    (:a  :alexandria)
+                    (:ev :program-events))
+  (:export
+   :init-main-window))
+
 (defpackage :main
   (:use
    :cl

src/program-events.lisp

@@ -102,7 +102,15 @@
   ((lock
     :initform (bt:make-recursive-lock)
     :initarg  :lock
-    :accessor lock)))
+    :accessor lock)
+   (blocking-lock
+    :initform (bt:make-lock)
+    :initarg  :blocking-lock
+    :accessor blocking-lock)
+   (condition-variable
+    :initform (bt:make-condition-variable)
+    :initarg  :condition-variable
+    :accessor condition-variable)))
 
 (defun queue-compare-predicate (a b)
   (let ((same-priority-p (= (priority a)
@@ -143,6 +151,19 @@
           (next-id))
     object))
 
+(defun pop-event-block ()
+  (with-lock ((blocking-lock *events-queue*))
+    (loop while (emptyp *events-queue*)
+          do
+             (bt:condition-wait (condition-variable *events-queue*)
+                                (blocking-lock *events-queue*)))
+    (pop-element *events-queue*)))
+
+(defun push-event-unblock (value)
+  (with-lock ((blocking-lock *events-queue*))
+    (push-element *events-queue* value)
+    (bt:condition-notify (condition-variable *events-queue*))))
+
 (defun push-event (event)
   (wrapped-in-lock (*events-queue*)
     (if *process-events-immediately*
@@ -1790,3 +1811,15 @@
             (push-event bypassable-event)
             (process-event event))
           (process-event bypassable-event)))))
+
+(defun dispatch-program-events-or-wait ()
+  (when (event-available-p)
+    (let ((bypassable-event (pop-event-block)))
+      (if (and (= (priority bypassable-event)
+                  +minimum-event-priority+)
+               (event-available-p))
+          (let ((event (pop-event-block)))
+            (reinitialize-id bypassable-event)
+            (push-event-unblock bypassable-event)
+            (process-event event))
+          (process-event bypassable-event)))))

src/tests/program-events-tests.lisp

@@ -82,15 +82,15 @@
     (client-events:start-events-loop)
     (let ((res nil))
       (bt:make-thread (lambda ()
-                        (sleep 1)
+                        (sleep 3)
+                        (format t "push!~%")
                         (setf res (push-function-and-wait-results #'callback))))
       (map 'nil
            (lambda (a)
              (sleep 1)
-             (push-event (make-instance 'function-event
-                                        :payload (lambda () (format t "~a~%" a)))))
+             (push-event-unblock (make-instance 'function-event
+                                                :payload (lambda () (format t "~a~%" a)))))
            (loop for i from 0 to 10 collect i))
-      (sleep 20)
       (client-events:stop-events-loop)
       res)))
 

src/windows.lisp

@@ -535,7 +535,7 @@ list of strings (the text lines)."
                              buttons))
          (message        (join-with-strings lines (format nil "~%")))
          (dialog-window  (make-instance 'c-dlg:msgbox
-                                        ;:parent               parent
+                                        :parent               parent
                                         :stacked              nil
                                         :center               t
                                         :message              message