X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=gtk%2Fgtk.high-level.lisp;h=977007f236dc75c02e206b450327768e51582200;hb=804b4c8f24b3725eb90f29d7e6910b2598b68771;hp=d5ba06df6589cd027d7d0c133ec6c19381f66974;hpb=7b8a41181b0880374e278f39fb5bd1186d405b22;p=cl-gtk2.git

diff --git a/gtk/gtk.high-level.lisp b/gtk/gtk.high-level.lisp
index d5ba06d..977007f 100644
--- a/gtk/gtk.high-level.lisp
+++ b/gtk/gtk.high-level.lisp
@@ -1,16 +1,26 @@
 (in-package :gtk)
 
+(define-condition gtk-call-aborted (error)
+  ((condition :initarg :condition :reader gtk-call-aborted-condition))
+  (:report (lambda (c stream)
+             (format stream "Call within main loop aborted because of error:~%~A" (gtk-call-aborted-condition c)))))
+
 (defun call-within-main-loop-and-wait (fn)
   (let ((lock (bt:make-lock))
         (cv (bt:make-condition-variable))
+        error
         result)
     (bt:with-lock-held (lock)
       (within-main-loop
-        (setf result (multiple-value-list (funcall fn)))
+        (handler-case
+            (setf result (multiple-value-list (funcall fn)))
+          (error (e) (setf error e)))
         (bt:with-lock-held (lock)
           (bt:condition-notify cv)))
       (bt:condition-wait cv lock)
-      (values-list result))))
+      (if error
+          (error 'gtk-call-aborted :condition error)
+          (values-list result)))))
 
 (export 'call-within-main-loop-and-wait)
 
@@ -78,9 +88,8 @@
   (declare (ignore colon-modifier-p at-sign-modifier-p))
   (let ((seconds (mod (truncate seconds) 60))
         (minutes (mod (truncate seconds 60) 60))
-        (hours (truncate seconds 3600))
-        (milliseconds (truncate (mod (* seconds 1000) 1000))))
-    (format stream "~2,'0D:~2,'0D:~2,'0D.~3,'0D" hours minutes seconds milliseconds)))
+        (hours (truncate seconds 3600)))
+    (format stream "~2,'0D:~2,'0D:~2,'0D" hours minutes seconds)))
 
 (defun update-progress-bar-text (bar &optional (lower-frac 0.0))
   (let* ((elapsed (coerce (/ (- (get-internal-real-time)
@@ -133,4 +142,16 @@
             (with-progress-bar ("Texts" 10)
               (loop
                  repeat 10
-                 do (with-progress-bar-action (sleep 1))))))))
\ No newline at end of file
+                 do (with-progress-bar-action (sleep 1))))))))
+
+(defun show-message (message &key (buttons :ok) (message-type :info) (use-markup nil))
+  (let ((dialog (make-instance 'message-dialog
+                               :text message
+                               :buttons buttons
+                               :message-type message-type
+                               :use-markup use-markup)))
+    (prog1
+        (dialog-run dialog)
+      (object-destroy dialog))))
+
+(export 'show-message)