[clfswm-cvs] [clfswm-git]CLFSWM - A(nother) Common Lisp FullScreen Window Manager branch master updated. R-1106-117-g81a310c
Philippe Brochard
pbrochard at common-lisp.net
Sat Sep 29 21:42:29 UTC 2012
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "CLFSWM - A(nother) Common Lisp FullScreen Window Manager".
The branch, master has been updated
via 81a310cac49b418d7671c424713449e67cd870a3 (commit)
from 20de0ab6d1a1d62284df039859b7244f508f14d0 (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 81a310cac49b418d7671c424713449e67cd870a3
Author: Philippe Brochard <pbrochard at common-lisp.net>
Date: Sat Sep 29 23:42:14 2012 +0200
src/xlib-util.lisp (with-xlib-protect): Limit X errors ignored to prevent freezes and add a backtrace system.
diff --git a/ChangeLog b/ChangeLog
index 8f50e9d..18a40ce 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,8 @@
+2012-09-29 Philippe Brochard <pbrochard at common-lisp.net>
+
+ * src/xlib-util.lisp (with-xlib-protect): Limit X errors ignored
+ to prevent freezes and add a backtrace system.
+
2012-09-23 Philippe Brochard <pbrochard at common-lisp.net>
* src/clfswm.lisp (configure-request handler): To be ICCCM
diff --git a/load.lisp b/load.lisp
index 9d2f5f0..d8e063d 100644
--- a/load.lisp
+++ b/load.lisp
@@ -35,7 +35,7 @@
#+CMU
(setf ext:*gc-verbose* nil)
-#+SBCL
+#+(or SBCL ECL)
(require :asdf)
#+(or CMU ECL)
diff --git a/src/clfswm.lisp b/src/clfswm.lisp
index 2af439e..119dd4d 100644
--- a/src/clfswm.lisp
+++ b/src/clfswm.lisp
@@ -44,7 +44,9 @@
window root-x root-y *fun-press*)))
(define-handler main-mode :configure-request (stack-mode window x y width height border-width value-mask)
- (let ((to-send-conf-notify-p nil))
+ (let ((old-width (x-drawable-height window))
+ (old-height (x-drawable-height window))
+ (old-border (x-drawable-border-width window)))
(labels ((has-x (mask) (= 1 (logand mask 1)))
(has-y (mask) (= 2 (logand mask 2)))
(has-w (mask) (= 4 (logand mask 4)))
@@ -52,14 +54,10 @@
(has-bw (mask) (= 16 (logand mask 16)))
(has-stackmode (mask) (= 64 (logand mask 64)))
(adjust-from-request ()
- (when (has-x value-mask) (setf (x-drawable-x window) x
- to-send-conf-notify-p t))
- (when (has-y value-mask) (setf (x-drawable-y window) y
- to-send-conf-notify-p t))
- (when (has-h value-mask) (setf (x-drawable-height window) height
- to-send-conf-notify-p nil))
- (when (has-w value-mask) (setf (x-drawable-width window) width
- to-send-conf-notify-p nil))))
+ (when (has-x value-mask) (setf (x-drawable-x window) x))
+ (when (has-y value-mask) (setf (x-drawable-y window) y))
+ (when (has-h value-mask) (setf (x-drawable-height window) height))
+ (when (has-w value-mask) (setf (x-drawable-width window) width))))
(when window
(xlib:with-state (window)
(when (has-bw value-mask)
@@ -71,12 +69,6 @@
(adapt-child-to-parent window parent)
(adjust-from-request)))
(adjust-from-request)))
- (when to-send-conf-notify-p
- ;; To be ICCCM compliant, send a fake configuration notify event only when
- ;; the window has moved and not when it has been resized.
- (send-configuration-notify window (x-drawable-x window) (x-drawable-y window)
- (x-drawable-width window) (x-drawable-height window)
- (x-drawable-border-width window)))
(when (has-stackmode value-mask)
(case stack-mode
(:above
@@ -85,7 +77,15 @@
(is-in-current-child-p window))
(raise-window window)
(focus-window window)
- (focus-all-children window (find-parent-frame window (find-current-root)))))))))))))
+ (focus-all-children window (find-parent-frame window (find-current-root)))))))))
+ (unless (or (/= old-width (x-drawable-width window))
+ (/= old-height (x-drawable-height window))
+ (/= old-border (x-drawable-border-width window)))
+ ;; To be ICCCM compliant, send a fake configuration notify event only when
+ ;; the window has moved and not when it has been resized or the border width has changed.
+ (send-configuration-notify window (x-drawable-x window) (x-drawable-y window)
+ (x-drawable-width window) (x-drawable-height window)
+ (x-drawable-border-width window)))))))
(define-handler main-mode :map-request (window send-event-p)
@@ -209,7 +209,8 @@
:height (xlib:screen-height *screen*)
:depth (xlib:screen-root-depth *screen*)
:drawable *root*)
- *in-second-mode* nil)
+ *in-second-mode* nil
+ *x-error-count* 0)
(store-root-background)
(init-modifier-list)
(xgrab-init-pointer)
diff --git a/src/tools.lisp b/src/tools.lisp
index a5edfdd..7082b56 100644
--- a/src/tools.lisp
+++ b/src/tools.lisp
@@ -39,7 +39,7 @@
:copy-hash-table
:nfuncall
:pfuncall
- :symbol-search
+ :symbol-search
:create-symbol :create-symbol-in-package
:call-hook
:add-new-hook
@@ -92,6 +92,7 @@
:first-position
:find-free-number
:date-string
+ :write-backtrace
:do-execute
:do-shell :fdo-shell
:getenv
@@ -216,6 +217,7 @@
(apply function args)))
+
(defun symbol-search (search symbol)
"Search the string 'search' in the symbol name of 'symbol'"
(search search (symbol-name symbol) :test #'string-equal))
@@ -814,7 +816,7 @@ Useful for re-using the &REST arg after removing some options."
#+lucid (apply #'lcl:run-program prog :wait wait :arguments args opts)
#+sbcl (apply #'sb-ext:run-program prog args :wait wait :output *standard-output* opts)
#+ecl (apply #'ext:run-program prog args opts)
- #+ccl (apply #'ccl:run-program prog args opts :wait wait)
+ #+ccl (ccl:run-program prog args :wait wait)
#-(or allegro clisp cmu gcl liquid lispworks lucid sbcl ecl ccl)
(error 'not-implemented :proc (list 'run-prog prog opts)))
@@ -1044,6 +1046,31 @@ Useful for re-using the &REST arg after removing some options."
hour minute second
(nth day days) (nth (1- month) months) date year)))))
+;;;
+;;; Backtrace function
+;;;
+(defun write-backtrace (filename &optional other-info clear)
+ (when (and clear (probe-file filename))
+ (delete-file filename))
+ (with-open-file (stream filename :direction :output :if-exists :append
+ :if-does-not-exist :create)
+ (let ((*standard-output* stream)
+ (*debug-io* stream))
+ (format t "================== New backtrace ==================~%")
+ (format t "--- ~A ---~%" (date-string))
+ (format t "Lisp: ~A ; Version: ~A~2%" (lisp-implementation-type)
+ (lisp-implementation-version))
+ #+clisp (system::print-backtrace)
+ #+(or cmucl scl) (debug:backtrace)
+ #+sbcl (sb-debug:backtrace)
+ #+(or mcl ccl) (ccl:print-call-history :detailed-p nil)
+ #-(or clisp cmucl scl sbcl mcl ccl) (format t "Backtrace not defined~%")
+ (when other-info
+ (format t "~A~%" other-info))
+ (format t "--- log end ---~%")))
+ (format t "Backtrace logged in file: ~A~%" filename))
+
+
;;;
;;; System information functions
diff --git a/src/xlib-util.lisp b/src/xlib-util.lisp
index cfc1f82..3edacaa 100644
--- a/src/xlib-util.lisp
+++ b/src/xlib-util.lisp
@@ -69,19 +69,34 @@ Window types are in +WINDOW-TYPES+.")
+(defparameter *x-error-count* 0)
+(defparameter *max-x-error-count* 10000)
+(defparameter *clfswm-x-error-filename* "/tmp/clfswm-backtrace.error")
+
+
(defmacro with-xlib-protect ((&optional name tag) &body body)
"Prevent Xlib errors"
- #-:xlib-debug (declare (ignore name tag))
`(handler-case
(with-simple-restart (top-level "Return to clfswm's top level")
- , at body)
+ , at body
+ (setf *x-error-count* 0))
(xlib::x-error (c)
- #-:xlib-debug (declare (ignore c))
+ (incf *x-error-count*)
+ (when (> *x-error-count* *max-x-error-count*)
+ (format t "Xlib error: ~A ~A: ~A~%" ,name (if ,tag ,tag ',body) c)
+ (force-output)
+ (write-backtrace *clfswm-x-error-filename*
+ (format nil "~%------- Additional information ---------
+Xlib error: ~A ~A: ~A
+Body: ~A
+
+Features: ~A"
+ ,name ,tag c ',body
+ *features*))
+ (error "Too many X errors: ~A (logged in ~A)" c *clfswm-x-error-filename*))
#+:xlib-debug
(progn
- (if ,tag
- (format t "Xlib error: ~A ~A: ~A~%" ,name ,tag c)
- (format t "Xlib error: ~A ~A: ~A~%" ,name ',body c))
+ (format t "Xlib error: ~A ~A: ~A~%" ,name (if ,tag ,tag ',body) c)
(force-output)))))
-----------------------------------------------------------------------
Summary of changes:
ChangeLog | 5 +++++
load.lisp | 2 +-
src/clfswm.lisp | 35 ++++++++++++++++++-----------------
src/tools.lisp | 31 +++++++++++++++++++++++++++++--
src/xlib-util.lisp | 27 +++++++++++++++++++++------
5 files changed, 74 insertions(+), 26 deletions(-)
hooks/post-receive
--
CLFSWM - A(nother) Common Lisp FullScreen Window Manager
More information about the clfswm-cvs
mailing list