| 1 | ;; Common Lisp bindings for GTK+ 2.x |
| 2 | ;; Copyright 2005 Espen S. Johnsen <espen@users.sf.net> |
| 3 | ;; |
| 4 | ;; Permission is hereby granted, free of charge, to any person obtaining |
| 5 | ;; a copy of this software and associated documentation files (the |
| 6 | ;; "Software"), to deal in the Software without restriction, including |
| 7 | ;; without limitation the rights to use, copy, modify, merge, publish, |
| 8 | ;; distribute, sublicense, and/or sell copies of the Software, and to |
| 9 | ;; permit persons to whom the Software is furnished to do so, subject to |
| 10 | ;; the following conditions: |
| 11 | ;; |
| 12 | ;; The above copyright notice and this permission notice shall be |
| 13 | ;; included in all copies or substantial portions of the Software. |
| 14 | ;; |
| 15 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, |
| 16 | ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF |
| 17 | ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. |
| 18 | ;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY |
| 19 | ;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, |
| 20 | ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE |
| 21 | ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. |
| 22 | |
| 23 | ;; $Id: ginspect.lisp,v 1.9 2006-02-09 22:34:09 espen Exp $ |
| 24 | |
| 25 | #+sbcl(require :gtk) |
| 26 | #+cmu(asdf:oos 'asdf:load-op :gtk) |
| 27 | |
| 28 | (defpackage "GINSPECT" |
| 29 | (:use "COMMON-LISP" "GLIB" "GTK" #+cmu"PCL" #+sbcl"SB-PCL") |
| 30 | (:export "GINSPECT" "GINSPECT-TOPLEVELS")) |
| 31 | |
| 32 | (in-package "GINSPECT") |
| 33 | |
| 34 | (defvar *ginspect-unbound-object-marker* |
| 35 | #+cmu (gensym "UNBOUND-OBJECT-") |
| 36 | #+sbcl sb-impl::*inspect-unbound-object-marker*) |
| 37 | |
| 38 | |
| 39 | (defgeneric insert-object (object store parent &optional prefix)) |
| 40 | (defgeneric insert-parts (object store parent)) |
| 41 | (defgeneric object-has-parts-p (object)) |
| 42 | (defgeneric decompose-describe-object (object)) |
| 43 | |
| 44 | |
| 45 | ;; A container to hold lisp objects "inside" the tree store |
| 46 | (defclass object-container (gobject) |
| 47 | ((object :initarg :object)) |
| 48 | (:metaclass gobject-class)) |
| 49 | |
| 50 | |
| 51 | (defun ginspect (object) |
| 52 | (let* ((store (make-instance 'tree-store |
| 53 | :column-types '(string string gobject boolean) |
| 54 | :column-names '(name pprinted object expanded))) |
| 55 | (view (make-instance 'tree-view :model store :headers-visible nil))) |
| 56 | |
| 57 | (let ((column (make-instance 'tree-view-column)) |
| 58 | (name (make-instance 'cell-renderer-text)) |
| 59 | (object (make-instance 'cell-renderer-text))) |
| 60 | (tree-view-append-column view column) |
| 61 | (cell-layout-pack column name :expand nil) |
| 62 | (cell-layout-add-attribute column name 'text (column-index store 'name)) |
| 63 | (cell-layout-pack column object :expand t) |
| 64 | (cell-layout-add-attribute column object 'text (column-index store 'pprinted))) |
| 65 | |
| 66 | (insert-object object store nil) |
| 67 | |
| 68 | (signal-connect view 'row-expanded |
| 69 | #'(lambda (iter path) |
| 70 | (when (setf |
| 71 | (tree-model-value store iter 'expanded) |
| 72 | (not (tree-model-value store iter 'expanded))) |
| 73 | (multiple-value-bind (valid child-iter) |
| 74 | (tree-model-iter-children store iter) |
| 75 | ;; Remove old children |
| 76 | (when valid |
| 77 | (loop while (tree-store-remove store child-iter)))) |
| 78 | (let ((container (tree-model-value store iter 'object))) |
| 79 | (insert-parts (slot-value container 'object) store iter)) |
| 80 | (tree-view-expand-row view path nil)))) |
| 81 | |
| 82 | (make-instance 'dialog |
| 83 | :title "Object Inspector" :show-children t :visible t |
| 84 | :default-width 600 :default-height 600 |
| 85 | :button (list "gtk-close" #'widget-destroy :object t) |
| 86 | :child (make-instance 'scrolled-window |
| 87 | :hscrollbar-policy :automatic :child view)))) |
| 88 | |
| 89 | |
| 90 | (defmethod decompose-describe-object ((object t)) |
| 91 | #+cmu |
| 92 | (destructuring-bind (description named-p &rest parts) |
| 93 | (inspect::describe-parts object) |
| 94 | (if (equal parts (list object)) |
| 95 | (values description nil nil) |
| 96 | (values description named-p parts))) |
| 97 | #+sbcl(sb-impl::inspected-parts object)) |
| 98 | |
| 99 | (defmethod decompose-describe-object ((object (eql t))) |
| 100 | (values (call-next-method) nil nil)) |
| 101 | |
| 102 | (defmethod decompose-describe-object ((object (eql nil))) |
| 103 | (values (call-next-method) nil nil)) |
| 104 | |
| 105 | (defun propper-list-p (object) |
| 106 | (and (listp object) (null (cdr (last object))))) |
| 107 | |
| 108 | (defmethod decompose-describe-object ((object cons)) |
| 109 | (if (propper-list-p object) |
| 110 | (values (call-next-method) nil object) |
| 111 | (values "The object is a CONS." nil (list (car object) (cdr object))))) |
| 112 | |
| 113 | (defmethod decompose-describe-object ((object #+cmu alien:system-area-pointer |
| 114 | #+sbcl sb-alien:system-area-pointer)) |
| 115 | (values "The object is a SYSTEM-AREA-POINTER" nil nil)) |
| 116 | |
| 117 | (defmethod decompose-describe-object ((object (eql *ginspect-unbound-object-marker*))) |
| 118 | (values "The slot is unbound" nil nil)) |
| 119 | |
| 120 | #+cmu |
| 121 | (defmethod decompose-describe-object ((object symbol)) |
| 122 | (values |
| 123 | (call-next-method) t |
| 124 | (list |
| 125 | (cons "Name" (symbol-name object)) |
| 126 | (cons "Package" (symbol-package object)) |
| 127 | (cons "Value" (if (boundp object) |
| 128 | (symbol-value object) |
| 129 | *ginspect-unbound-object-marker*)) |
| 130 | (cons "Function" (if (fboundp object) |
| 131 | (symbol-function object) |
| 132 | *ginspect-unbound-object-marker*)) |
| 133 | (cons "Plist" (symbol-plist object))))) |
| 134 | |
| 135 | #+cmu |
| 136 | (defmethod decompose-describe-object ((object standard-object)) |
| 137 | (values |
| 138 | (call-next-method) t |
| 139 | (loop |
| 140 | for slotd in (class-slots (class-of object)) |
| 141 | collect (let* ((slot-name (pcl:slot-definition-name slotd)) |
| 142 | (slot-value (if (slot-boundp object slot-name) |
| 143 | (slot-value object slot-name) |
| 144 | *ginspect-unbound-object-marker*))) |
| 145 | (cons (string slot-name) slot-value))))) |
| 146 | |
| 147 | |
| 148 | (defmethod object-has-parts-p ((object t)) |
| 149 | (nth-value 2 (decompose-describe-object object))) |
| 150 | |
| 151 | (defmethod object-has-parts-p ((object cons)) |
| 152 | t) |
| 153 | |
| 154 | (defmethod object-has-parts-p ((object standard-object)) |
| 155 | (class-slots (class-of object))) |
| 156 | |
| 157 | (defmethod object-has-parts-p ((object vector)) |
| 158 | (not (zerop (length object)))) |
| 159 | |
| 160 | |
| 161 | (defmethod object-to-string ((object t)) |
| 162 | (with-output-to-string (stream) |
| 163 | (write object :stream stream :lines 1 :right-margin 80))) |
| 164 | |
| 165 | (defmethod object-to-string ((object (eql *ginspect-unbound-object-marker*))) |
| 166 | "<unbound>") |
| 167 | |
| 168 | (defmethod insert-object ((object t) store parent &optional (name "")) |
| 169 | (let ((container (make-instance 'object-container :object object)) |
| 170 | (has-parts (object-has-parts-p object))) |
| 171 | (let ((iter (tree-store-append store parent |
| 172 | (vector name (object-to-string object) |
| 173 | container (not has-parts))))) |
| 174 | (when has-parts |
| 175 | ;; Insert dummy child |
| 176 | (tree-store-append store iter (vector "" "" container t)))))) |
| 177 | |
| 178 | (defmethod insert-parts :around ((object t) store parent) |
| 179 | (when (object-has-parts-p object) |
| 180 | (call-next-method))) |
| 181 | |
| 182 | (defmethod insert-parts ((object t) store parent) |
| 183 | (multiple-value-bind (description named-p parts) |
| 184 | (decompose-describe-object object) |
| 185 | (declare (ignore description)) |
| 186 | (loop |
| 187 | for part in parts |
| 188 | do (if named-p |
| 189 | (insert-object (cdr part) store parent (string (car part))) |
| 190 | (insert-object part store parent))))) |
| 191 | |
| 192 | |
| 193 | (defun ginspect-toplevels () |
| 194 | (ginspect (window-list-toplevels))) |