[elpa] externals/xelb b700406 7/7: Merge branch 'medranocalvo/xcb-logging' into externals/xelb

[Chris Feng]

branch: externals/xelb
commit b700406b2ece067d6d6f4fdd51a6bd29cc7ef3a9
Merge: 6656f4d 7758613
Author: Chris Feng <address@hidden>
Commit: Chris Feng <address@hidden>

    Merge branch 'medranocalvo/xcb-logging' into externals/xelb
---
 xcb-debug.el | 110 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 xcb-types.el |  46 ++++++++++++++++++-------
 xcb.el       |   7 ++--
 3 files changed, 147 insertions(+), 16 deletions(-)

diff --git a/xcb-debug.el b/xcb-debug.el
new file mode 100644
index 0000000..f2c1507
--- /dev/null
+++ b/xcb-debug.el
@@ -0,0 +1,110 @@
+;;; xcb-debug.el --- Debugging helpers for XELB  -*- lexical-binding: t -*-
+
+;; Copyright (C) 2018 Free Software Foundation, Inc.
+
+;; Author: Adrián Medraño Calvo <address@hidden>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This module collects functions that help in debugging XELB.
+
+;;; Code:
+
+(defvar xcb-debug:buffer "*XELB-DEBUG*" "Buffer to write debug messages to.")
+
+(defvar xcb-debug:backtrace-start-frame 5
+  "From which frame to start collecting backtraces.")
+
+(defun xcb-debug:-call-stack ()
+  "Return the current call stack frames."
+  (let (frames frame
+        ;; No need to acount for our setq, while, let, ...
+        (index xcb-debug:backtrace-start-frame))
+    (while (setq frame (backtrace-frame index))
+      (push frame frames)
+      (cl-incf index))
+    (cl-remove-if-not 'car frames)))
+
+(defmacro xcb-debug:compile-time-function-name ()
+  "Get the name of outermost definition at expansion time."
+  (let* ((frame (cl-find-if
+                (lambda (frame)
+                  (ignore-errors
+                    (let ((clause (car (cl-third frame))))
+                      (or (equal clause 'defalias)
+                          (equal clause 'cl-defmethod)))))
+                (reverse (xcb-debug:-call-stack))))
+        (defn (cl-third frame))
+        (deftype (car defn)))
+    (cl-case deftype
+      ((defalias) (symbol-name (cl-cadadr defn)))
+      ((cl-defmethod) (symbol-name (cadr defn)))
+      (t "<unknown function>"))))
+
+(defmacro xcb-debug:-with-debug-buffer (&rest forms)
+  "Evaluate FORMS making sure `xcb-debug:buffer' is correctly updated."
+  `(with-current-buffer (get-buffer-create xcb-debug:buffer)
+     (let (windows-eob)
+       ;; Note windows whose point is at EOB.
+       (dolist (w (get-buffer-window-list xcb-debug:buffer t 'nomini))
+         (when (= (window-point w) (point-max))
+           (push w windows-eob)))
+       (save-excursion
+         (goto-char (point-max))
+         ,@forms)
+       ;; Restore point.
+       (dolist (w windows-eob)
+         (set-window-point w (point-max))))))
+
+(defun xcb-debug:message (format-string &rest objects)
+  "Print a message to `xcb-debug:buffer'.
+
+The FORMAT-STRING argument follows the speficies how to print each of
+the passed OBJECTS.  See `format' for details."
+  (xcb-debug:-with-debug-buffer
+   (insert (apply #'format format-string objects))))
+
+(defmacro xcb-debug:backtrace ()
+  "Print a backtrace to the `xcb-debug:buffer'."
+  '(xcb-debug:-with-debug-buffer
+    (let ((standard-output (get-buffer-create xcb-debug:buffer)))
+      (backtrace))))
+
+(defmacro xcb-debug:backtrace-on-error (&rest forms)
+  "Evaluate FORMS.  Printing a backtrace if an error is signaled."
+  `(let ((debug-on-error t)
+         (debugger (lambda (&rest _) (xcb-debug:backtrace))))
+     ,@forms))
+
+(defun xcb-debug:clear ()
+  "Clear the debug buffer."
+  (interactive)
+  (xcb-debug:-with-debug-buffer
+   (erase-buffer)))
+
+(defun xcb-debug:mark ()
+  "Insert a mark in the debug buffer."
+  (interactive)
+  (xcb-debug:-with-debug-buffer
+   (insert "\n")))
+
+
+
+(provide 'xcb-debug)
+
+;;; xcb-debug.el ends here
diff --git a/xcb-types.el b/xcb-types.el
index 1343dfa..d368f34 100644
--- a/xcb-types.el
+++ b/xcb-types.el
@@ -51,14 +51,31 @@
 (eval-when-compile (require 'cl-lib))
 (require 'cl-generic)
 (require 'eieio)
-
-(eval-when-compile
-  (defvar xcb:debug-on nil "Non-nil to turn on debug."))
-
-(defmacro xcb:-log (format-string &rest args)
-  "Print debug info."
-  (when xcb:debug-on
-    `(message (concat "[XELB LOG] " ,format-string) ,@args)))
+(require 'xcb-debug)
+
+(defvar xcb:debug-on nil "Non-nil to turn on debug.")
+
+(defun xcb:debug-toggle (&optional arg)
+  "Toggle XELB debugging output.
+When ARG is positive, turn debugging on; when negative off.  When
+ARG is nil, toggle debugging output."
+  (interactive
+   (list (or current-prefix-arg 'toggle)))
+  (setq xcb:debug-on (if (eq arg 'toggle)
+                         (not xcb:debug-on)
+                       (> 0 arg))))
+
+(defmacro xcb:-log (&optional format-string &rest objects)
+  "Emit a message prepending the name of the function being executed.
+
+FORMAT-STRING is a string specifying the message to output, as in
+`format'.  The OBJECTS arguments specify the substitutions."
+  (unless format-string (setq format-string ""))
+  `(when xcb:debug-on
+     (xcb-debug:message ,(concat "%s:\t" format-string "\n")
+                        (xcb-debug:compile-time-function-name)
+                        ,@objects)
+     nil))
 
 ;;;; Fix backward compatibility issues with Emacs 24
 
@@ -452,11 +469,11 @@ Consider let-bind it rather than change its global 
value."))
 (defclass xcb:--struct ()
   nil)
 
-(cl-defmethod slot-unbound ((_object xcb:--struct) _class _slot-name _fn)
-  (xcb:-log "unbount-slot: %s" (list (eieio-class-name _class)
-                                     (eieio-object-name _object)
-                                    _slot-name _fn))
-  nil)
+(cl-defmethod slot-unbound ((object xcb:--struct) class slot-name fn)
+  (unless (eq fn #'oref-default)
+    (xcb:-log "unbound-slot: %s" (list (eieio-class-name class)
+                                       (eieio-object-name object)
+                                      slot-name fn))))
 
 (defclass xcb:-struct (xcb:--struct)
   ((~lsb :initarg :~lsb
@@ -779,6 +796,9 @@ This method auto-pads short results to 32 bytes."
   ((~size :initarg :~size :type xcb:-ignore)) ;Size of the largest member.
   :documentation "Union type.")
 ;;
+(cl-defmethod slot-unbound ((_object xcb:-union) _class _slot-name _fn)
+  nil)
+;;
 (cl-defmethod xcb:marshal ((obj xcb:-union))
   "Return the byte-array representation of union OBJ.
 
diff --git a/xcb.el b/xcb.el
index f633d6b..ebb3702 100644
--- a/xcb.el
+++ b/xcb.el
@@ -408,8 +408,9 @@ Concurrency is disabled as it breaks the orders of errors, 
replies and events."
               (setq data (aref event 1)
                     synthetic (aref event 2))
               (dolist (listener (aref event 0))
-                (with-demoted-errors "[XELB ERROR] %S"
-                  (funcall listener data synthetic)))))
+                (unwind-protect
+                    (xcb-debug:backtrace-on-error
+                     (funcall listener data synthetic))))))
         (cl-decf event-lock)))))
 
 (cl-defmethod xcb:disconnect ((obj xcb:connection))
@@ -564,7 +565,7 @@ classes of EVENT (since they have the same event number)."
               last-seen-sequence 0))
       (setf request-cache (vconcat cache msg)
             request-sequence (1+ request-sequence))
-      (xcb:-log "Cache request #%d: %s" request-sequence request)
+      (xcb:-log "Cache request #%d: %s" request-sequence msg)
       request-sequence)))
 
 (cl-defmethod xcb:-+request ((obj xcb:connection) request)