/[mcclim]/mcclim/Apps/Inspector/inspector.lisp
ViewVC logotype

Contents of /mcclim/Apps/Inspector/inspector.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.45 - (show annotations)
Sun Nov 9 19:58:26 2008 UTC (5 years, 5 months ago) by ahefner
Branch: MAIN
CVS Tags: HEAD
Changes since 1.44: +0 -8 lines
Fit space requirements to output history bounding rectangle automatically
after redisplay and drawing of graphs/tables.
1 ;;; -*- Mode: Lisp; Package: CLOUSEAU -*-
2
3 ;;; (c) copyright 2005 by
4 ;;; Robert Strandh (strandh@labri.fr)
5 ;;; (c) copyright 2005 by
6 ;;; Vincent Arkesteijn
7 ;;; (c) copyright 2005 by
8 ;;; Peter Scott (sketerpot@gmail.com)
9
10 ;;; This library is free software; you can redistribute it and/or
11 ;;; modify it under the terms of the GNU Library General Public
12 ;;; License as published by the Free Software Foundation; either
13 ;;; version 2 of the License, or (at your option) any later version.
14 ;;;
15 ;;; This library is distributed in the hope that it will be useful,
16 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
18 ;;; Library General Public License for more details.
19 ;;;
20 ;;; You should have received a copy of the GNU Library General Public
21 ;;; License along with this library; if not, write to the
22 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
23 ;;; Boston, MA 02111-1307 USA.
24
25 ;;; CLIM inspector application
26
27 (in-package :clouseau)
28
29 (define-modify-macro togglef () not)
30
31 (define-application-frame inspector ()
32 ((dico :initform (make-hash-table) :reader dico)
33 (cons-cell-dico :initform (make-hash-table) :reader cons-cell-dico)
34 (disassembly-dico :initform (make-hash-table) :reader disassembly-dico
35 :documentation "A hash table specifying which
36 functions should display disassembly")
37 (print-length :initform (make-hash-table) :reader print-length
38 :documentation "A hash table mapping list objects to
39 their specific print lengths, if they have one.")
40 (obj :initarg :obj :reader obj
41 :documentation "The object being inspected"))
42 (:pointer-documentation t)
43 (:panes
44 (app :application :width 600 :height 500
45 :scroll-bars nil
46 :text-style (make-text-style :sans-serif :roman :normal)
47 :display-function 'display-app)
48 (int :interactor :width 600 :height 100 :max-height 100))
49 (:layouts
50 (default (vertically () (scrolling () app) int))))
51
52 (defmethod initialize-instance :after ((frame inspector) &rest args)
53 (declare (ignore args))
54 (setf (gethash (obj frame) (dico frame)) t))
55
56 ;; Remember the scrolling state between redisplays.
57 (defmethod redisplay-frame-panes :around ((frame inspector) &key force-p)
58 (declare (ignore force-p))
59 ;; `Make-clim-stream-pane' creates bizarro object hierarchies, so
60 ;; getting the actual scrollable is not obvious.
61 (let* ((scrollable-pane (sheet-parent (find-pane-named frame 'app)))
62 (viewport (pane-viewport scrollable-pane)))
63 (multiple-value-bind (x-displacement y-displacement)
64 (transform-position (sheet-transformation scrollable-pane) 0 0)
65 (call-next-method)
66 (scroll-extent scrollable-pane
67 (min (- x-displacement)
68 (- (bounding-rectangle-width scrollable-pane)
69 (bounding-rectangle-width viewport)))
70 (min (- y-displacement)
71 (- (bounding-rectangle-height scrollable-pane)
72 (bounding-rectangle-height viewport)))))))
73
74 (defun inspector (obj &key (new-process nil))
75 (flet ((run ()
76 (let ((*print-length* 10)
77 (*print-level* 10))
78 (run-frame-top-level
79 (make-application-frame 'inspector :obj obj)))))
80
81 (when (typep *application-frame* 'inspector)
82 (restart-case (error "Clouseau called from inside Clouseau, possibly infinite recursion")
83 (continue ()
84 :report "Continue by starting a new Clouseau instance")
85 (abort-clouseau ()
86 :report "Abort this call to Clouseau"
87 (return-from inspector))))
88 (if new-process
89 (clim-sys:make-process #'run
90 :name (format nil "Inspector Clouseau: ~S"
91 obj))
92 (run))
93 obj))
94
95 (defparameter *inspected-objects* '()
96 "A list of objects which are currently being inspected with
97 INSPECT-OBJECT")
98
99 (defgeneric inspect-object-briefly (object pane)
100 (:documentation "Inspect an object in a short form, displaying this
101 on PANE. For example, rather than displaying all the slots of a class,
102 only the class name would be shown."))
103
104 (defgeneric inspect-object (object pane)
105 (:documentation "Inspect an object, displaying it on PANE. This can
106 be as verbose as you like; the important thing is that all the
107 information is present."))
108
109 (defmethod inspect-object :around (object pane)
110 (cond ((member object *inspected-objects*)
111 (with-output-as-presentation
112 (pane object (presentation-type-of object))
113 (princ "===" pane))) ; Prevent infinite loops
114 ((not (gethash object (dico *application-frame*)))
115 (inspect-object-briefly object pane))
116 (t
117 (let ((*inspected-objects* (cons object *inspected-objects*))
118 (*print-length* (or (gethash object (print-length
119 *application-frame*))
120 *print-length*)))
121 (call-next-method)))))
122
123 ;; This behavior should be overridden by methods for specific object
124 ;; types that have a more informative short representation. For
125 ;; example, the symbol FOO would be printed as "FOO" instead of "...",
126 ;; since that's just as short and more informative. When it's clicked
127 ;; on, it can then go to a more verbose view.
128 (defmethod inspect-object-briefly (object pane)
129 (with-output-as-presentation
130 (pane object (presentation-type-of object))
131 (princ "..." pane)))
132
133 (defmethod inspect-object (object pane)
134 (with-output-as-presentation
135 (pane object (presentation-type-of object))
136 (prin1 object pane)))
137
138
139 (define-presentation-type settable-slot ()
140 :inherit-from t)
141 (define-presentation-type cons ()
142 :inherit-from t)
143 (define-presentation-type long-list-tail ()
144 :inherit-from t)
145
146 (define-presentation-method present (object (type settable-slot)
147 stream
148 (view textual-view)
149 &key acceptably for-context-type)
150 (declare (ignore acceptably for-context-type))
151 (format stream "~s" (cdr object)))
152
153 (defmacro with-heading-style ((stream) &body body)
154 "Cause text output from BODY to be formatted in a heading font. This
155 could be boldface, or a different style, or even another font."
156 `(with-text-face (,stream :bold)
157 ,@body))
158
159 (defmacro inspector-table ((object pane) header &body body)
160 "Present OBJECT in tabular form on PANE, with HEADER evaluated to
161 print a label in a box at the top. BODY should output the rows of the
162 table, possibly using INSPECTOR-TABLE-ROW."
163 (let ((evaluated-pane (gensym "pane"))
164 (evaluated-object (gensym "object")))
165 `(let ((,evaluated-pane ,pane)
166 (,evaluated-object ,object))
167 (with-output-as-presentation
168 (pane ,evaluated-object
169 (presentation-type-of ,evaluated-object)
170 :single-box t)
171 (formatting-table (,evaluated-pane)
172 (formatting-column (,evaluated-pane)
173 (formatting-cell (,evaluated-pane)
174 (surrounding-output-with-border (,evaluated-pane)
175 (with-heading-style (,evaluated-pane)
176 ,header)))
177 (formatting-cell (,evaluated-pane)
178 (formatting-table (,evaluated-pane)
179 ,@body))))
180 (print-documentation (if (eql (class-of ,evaluated-object)
181 (find-class 'standard-class))
182 ,evaluated-object
183 (class-of ,evaluated-object))
184 ,evaluated-pane)))))
185
186 (defmacro inspector-table-row ((pane) left right)
187 "Output a table row with two items, produced by evaluating LEFT and
188 RIGHT, on PANE. This should be used only within INSPECTOR-TABLE."
189 (let ((evaluated-pane (gensym "pane")))
190 `(let ((,evaluated-pane ,pane))
191 (formatting-row (,evaluated-pane)
192 (formatting-cell (,evaluated-pane :align-x :right)
193 (with-heading-style (,evaluated-pane)
194 ,left))
195 (formatting-cell (,evaluated-pane)
196 ,right)))))
197
198 (defmacro inspector-table-rows ((pane) &body rows)
199 "Output a bunch of rows with INSPECTOR-TABLE-ROW on PANE. Each row
200 is a list of a label and a value."
201 (let ((evaluated-pane (gensym "pane")))
202 `(let ((,evaluated-pane ,pane))
203 ,@(loop for row in rows
204 collect (destructuring-bind (label value) row
205 `(inspector-table-row (,evaluated-pane)
206 (princ ,label ,evaluated-pane)
207 (inspect-object ,value ,evaluated-pane)))))))
208
209 ;; The error handler shouldn't be necessary, but it works around an
210 ;; ACL bug and shouldn't mess anything up on other lisps. The warning
211 ;; handler is there in case DOCUMENTATION raises a warning, to tell
212 ;; lisp that we don't care and it shouldn't go alarming the user.
213 (defun print-documentation (object pane)
214 "Print OBJECT's documentation, if any, to PANE"
215 (when (handler-case (documentation object t)
216 (error ())
217 (warning ()))
218 (with-heading-style (pane)
219 (format pane "~&Documentation: "))
220 (princ (documentation object t) pane)))
221
222 (defun display-class-superclasses (class pane)
223 "Display the superclasses of CLASS with an INSPECTOR-TABLE-ROW"
224 (when (clim-mop:class-direct-superclasses class)
225 (inspector-table-row (pane)
226 (princ "Superclasses" pane)
227 (inspect-vertical-list (clim-mop:class-direct-superclasses class)
228 pane))))
229
230 (defun display-class-subclasses (class pane)
231 "Display the subclasses of CLASS with an INSPECTOR-TABLE-ROW"
232 (when (clim-mop:class-direct-subclasses class)
233 (inspector-table-row (pane)
234 (princ "Subclasses" pane)
235 (inspect-vertical-list (clim-mop:class-direct-subclasses class)
236 pane))))
237
238 (defun display-object-slot (object slot pane &key display-lists-vertically)
239 "Display a slot of OBJECT onto PANE in the way normally used when
240 inspecting standard objects. SLOT must be a MOP SLOT-DEFINITION
241 object. If DISPLAY-LISTS-VERTICALLY is t and the slot value is a list,
242 it will be displayed with INSPECT-VERTICAL-LIST."
243 (let ((slot-name (clim-mop:slot-definition-name slot)))
244 (inspector-table-row (pane)
245 (with-output-as-presentation
246 (pane (cons object slot-name) 'settable-slot)
247 (format pane "~a:" slot-name))
248 (if (slot-boundp object slot-name)
249 (let ((slot-value (slot-value object slot-name)))
250 (if (and display-lists-vertically
251 (listp slot-value))
252 (inspect-vertical-list slot-value pane
253 :honor-dico t)
254 (inspect-object slot-value pane)))
255 (format pane "#<unbound slot>")))))
256
257 (defun inspect-structure-or-object (object pane)
258 "Inspect a structure or an object. Since both can be inspected in
259 roughly the same way, the common code is in this function, which is
260 called by the INSPECT-OBJECT methods for both standard objects and
261 structure objects."
262 (let ((class (class-of object)))
263 (inspector-table (object pane)
264 (print (class-name class) pane)
265 ;; Display superclasses and subclasses
266 (display-class-superclasses class pane)
267 (display-class-subclasses class pane)
268 (dolist (slot (reverse (clim-mop:class-slots class)))
269 (display-object-slot object slot pane)))))
270
271 (defun inspect-standard-class (object pane)
272 "Inspect a STANDARD-CLASS. This works almost the same way as
273 inspecting a standard object, but with a few differences. This should
274 also be used to inspect BUILD-IN-CLASSes."
275 (let ((class (class-of object)))
276 (inspector-table (object pane)
277 (print (class-name class) pane)
278 ;; Display superclasses and subclasses
279 (display-class-superclasses class pane)
280 (display-class-subclasses class pane)
281 (dolist (slot (reverse (clim-mop:class-slots class)))
282 (display-object-slot object slot pane
283 :display-lists-vertically t)))))
284
285 ;; Try to print the normal, textual representation of an object, but
286 ;; if that's too long, make an abbreviated "instance of ~S" version.
287 ;; FIXME: should this be removed? It's really ugly.
288 (defparameter *object-representation-max-length* 300
289 "Maximum number of characters of an object's textual representation
290 that are allowed before abbreviation kicks in")
291
292 (defun inspect-structure-or-object-briefly (object pane)
293 (with-output-as-presentation
294 (pane object (presentation-type-of object))
295 (with-text-family (pane :fix)
296 (handler-case
297 (let ((representation (with-output-to-string (string)
298 (prin1 object string))))
299 (if (< (length representation) *object-representation-max-length*)
300 (princ representation pane)
301 (format pane "#<~S ...>" (class-name (class-of object)))))
302 (error ()
303 (format pane "#<unprintable ~S>" (class-name (class-of object))))))))
304
305 (defmethod inspect-object-briefly ((object standard-object) pane)
306 (inspect-structure-or-object-briefly object pane))
307
308 (defmethod inspect-object-briefly ((object structure-object) pane)
309 (inspect-structure-or-object-briefly object pane))
310
311 (defmethod inspect-object-briefly ((object condition) pane)
312 (inspect-structure-or-object-briefly object pane))
313
314 (defmethod inspect-object ((object standard-object) pane)
315 (inspect-structure-or-object object pane))
316
317 (defmethod inspect-object ((object structure-object) pane)
318 (inspect-structure-or-object object pane))
319
320 (defmethod inspect-object ((object standard-class) pane)
321 (inspect-standard-class object pane))
322
323 (defmethod inspect-object ((object built-in-class) pane)
324 (inspect-standard-class object pane))
325
326 (defmethod inspect-object ((object condition) pane)
327 (inspect-structure-or-object object pane))
328
329 (defun inspect-cons-as-cells (object pane)
330 "Inspect a cons cell in a fancy graphical way. The inconvenient part
331 is that this necessarily involves quite a bit of clicking to show a
332 moderately-sized list."
333 (if (null (cdr object))
334 (formatting-table (pane)
335 (formatting-column (pane)
336 (formatting-cell (pane)
337 (with-output-as-presentation
338 (pane object 'cons)
339 (draw-rectangle* pane 0 0 20 10 :filled nil))
340 (draw-line* pane 10 0 10 10)
341 (draw-arrow* pane 5 5 5 30)
342 (draw-line* pane 10 10 20 0))
343 (formatting-cell (pane)
344 (inspect-object (car object) pane))))
345 (formatting-table (pane)
346 (formatting-row (pane)
347 (formatting-cell (pane)
348 (formatting-table (pane)
349 (formatting-column (pane)
350 (formatting-cell (pane)
351 (with-output-as-presentation
352 (pane object 'cons)
353 (draw-rectangle* pane 0 0 20 10 :filled nil))
354 (draw-line* pane 10 0 10 10)
355 (draw-arrow* pane 5 5 5 30)
356 (draw-arrow* pane 15 5 40 5))
357 (formatting-cell (pane)
358 (inspect-object (car object) pane)))))
359 (formatting-cell (pane)
360 (inspect-object (cdr object) pane))))))
361
362 (defun inspect-vertical-list (object pane &key honor-dico)
363 "Inspect a list without the parentheses, putting each element on a
364 new line. This is useful for showing things like direct class
365 subclasses, since displaying those as a plain list looks ugly and is
366 inconvenient to use. If HONOR-DICO is t, this will respect DICO and
367 display '...' if OBJECT is not in DICO."
368 ;; Ordinarily this would be taken care of in the :around method for
369 ;; INSPECT-OBJECT, but since this is not a normal inspection view,
370 ;; we need to do it ourselves. Yes, it would be better if we could
371 ;; find another way to do this.
372 (let ((*print-length* (or (gethash object (print-length
373 *application-frame*))
374 *print-length*)))
375 (if (and honor-dico
376 (not (gethash object (dico *application-frame*))))
377 (inspect-object-briefly object pane)
378 (with-output-as-presentation
379 (pane object 'cons)
380 (formatting-table (pane)
381 (formatting-column (pane)
382 (do
383 ((length 0 (1+ length))
384 (cdr (cdr object) (cdr cdr))
385 (car (car object) (car cdr)))
386 ((cond ((eq nil cdr)
387 (formatting-cell (pane) (inspect-object car pane))
388 t)
389 ((not (consp cdr))
390 (formatting-cell (pane) (inspect-object car pane))
391 (formatting-cell (pane) (princ "." pane))
392 (formatting-cell (pane) (inspect-object cdr pane))
393 t)
394 ((and *print-length* (>= length *print-length*))
395 (with-output-as-presentation
396 (pane object 'long-list-tail)
397 (formatting-cell (pane) (princ "..." pane)))
398 t)
399 (t nil)))
400 (formatting-cell (pane) (inspect-object car pane)))))))))
401
402 (defun inspect-cons-as-list (object pane)
403 "Inspect a cons cell in a traditional, plain-text format. The only
404 difference between this and simply using the Lisp printer is that this
405 code takes advantage of CLIM's tables and presentations to make the
406 list as interactive as you would expect."
407 (with-output-as-presentation
408 (pane object 'cons)
409 (formatting-table (pane)
410 (formatting-row (pane)
411 (formatting-cell (pane)
412 (princ "(" pane))
413 (do
414 ((length 0 (1+ length))
415 (cdr (cdr object) (cdr cdr))
416 (car (car object) (car cdr)))
417 ((cond ((eq nil cdr)
418 (formatting-cell (pane) (inspect-object car pane))
419 (formatting-cell (pane) (princ ")" pane))
420 t)
421 ((not (consp cdr))
422 (formatting-cell (pane) (inspect-object car pane))
423 (formatting-cell (pane) (princ "." pane))
424 (formatting-cell (pane) (inspect-object cdr pane))
425 (formatting-cell (pane) (princ ")" pane))
426 t)
427 ((and *print-length* (>= length *print-length*))
428 (with-output-as-presentation (pane object 'long-list-tail)
429 (formatting-cell (pane) (princ "...)" pane)))
430 t)
431 (t nil)))
432 (formatting-cell (pane) (inspect-object car pane)))))))
433
434 (defmethod inspect-object ((object cons) pane)
435 ;; Decide how to display the cons by looking in cons-cell-dico
436 (if (gethash object (cons-cell-dico *application-frame*))
437 (inspect-cons-as-cells object pane)
438 (inspect-cons-as-list object pane)))
439
440 (defun show-hash-table-status (hash pane &key (message "Usage Graph"))
441 "Show a hash table's status graphically on a given
442 pane. Display a given message, which defaults to 'Usage Graph'."
443 (with-room-for-graphics (pane :height 20)
444 (let* ((my-beige (make-rgb-color 0.9372549 0.8862745 0.8862745))
445 (used-color (make-rgb-color 0.43529412 0.7921569 0.87058824))
446 (text-color (make-rgb-color 0.7176471 0.29803923 0.2))
447 (pattern (make-rectangular-tile
448 (make-pattern #2A((0 1 0 0 0)
449 (1 0 0 0 0)
450 (0 0 0 0 1)
451 (0 0 0 1 0)
452 (0 0 1 0 0))
453 (list my-beige +black+)) 5 5)))
454 (draw-rectangle* pane 0 0 150 20 :filled t :ink my-beige)
455 (draw-rectangle* pane 0 0 (* 150 (/ (hash-table-count hash)
456 (hash-table-size hash)))
457 20 :filled t :ink used-color :line-thickness 0)
458 (draw-rectangle* pane (* 150 (hash-table-rehash-threshold hash)) 0 150 20
459 :filled t :ink pattern :line-thickness 0)
460 (draw-rectangle* pane 0 0 150 20 :filled nil :ink +black+)
461 (draw-text* pane message 7 10 :align-y :center :align-x :left
462 :text-size :small :ink text-color :text-face :italic))))
463
464 (defmethod inspect-object-briefly ((object hash-table) pane)
465 (with-output-as-presentation
466 (pane object (presentation-type-of object))
467 (show-hash-table-status object pane :message "Hash table")))
468 (defmethod inspect-object ((object hash-table) pane)
469 (inspector-table (object pane)
470 (progn (format pane "~A (test: ~A) " 'hash-table (hash-table-test object))
471 (show-hash-table-status object pane))
472 (loop for key being the hash-keys of object
473 do (formatting-row (pane)
474 (formatting-cell (pane :align-x :right)
475 (inspect-object key pane))
476 (formatting-cell (pane) (princ "=" pane))
477 (formatting-cell (pane)
478 (inspect-object (gethash key object) pane))))))
479
480 (defmethod inspect-object ((object generic-function) pane)
481 (inspector-table (object pane)
482 (format pane "Generic Function: ~s"
483 (clim-mop:generic-function-name object))
484 (dolist (method (clim-mop:generic-function-methods object))
485 (with-output-as-presentation
486 (pane method (presentation-type-of method))
487 (formatting-row (pane)
488 (formatting-cell (pane)
489 (with-text-family (pane :fix)
490 (print (clim-mop:method-qualifiers method) pane)))
491 (loop for specializer in (clim-mop:method-specializers method)
492 do (formatting-cell (pane)
493 (if (typep specializer 'clim-mop:eql-specializer)
494 (progn
495 (princ "(EQL " pane)
496 (inspect-object
497 (clim-mop:eql-specializer-object
498 specializer)
499 pane)
500 (princ ")" pane))
501 (inspect-object (class-name specializer)
502 pane)))))))))
503
504 (defun pretty-print-function (fun)
505 "Print a function in a readable way, returning a string. On most
506 implementations this just uses the standard Lisp printer, but it can
507 use implementation-specific functions to be more informative."
508 (flet ((generic-print (fun)
509 (with-output-to-string (string)
510 (prin1 fun string))))
511 ;; If we have SBCL, try to do fancy formatting. If anything goes
512 ;; wrong with that, fall back on ugly standard PRIN1.
513 #+sbcl
514 (unless (typep fun 'generic-function)
515 (let ((fun (sb-kernel:%closure-fun fun)))
516 (handler-case (format nil "~A ~S"
517 (sb-kernel:%simple-fun-name fun)
518 (sb-kernel:%simple-fun-arglist fun))
519 (error () (generic-print fun)))))
520 ;; FIXME: Other Lisp implementations have ways of getting this
521 ;; information. If you want a better inspector on a non-SBCL Lisp,
522 ;; please add code for it and send patches.
523 #-sbcl (generic-print fun)))
524
525 ;; This is ugly. I think CLIM requires there to be a presentation type
526 ;; for every class, so we should use FUNCTION---but I'm not sure how
527 ;; well that will work.
528 (define-presentation-type inspected-function ()
529 :inherit-from t)
530
531 (defmethod inspect-object ((object function) pane)
532 (with-output-as-presentation
533 (pane object 'inspected-function)
534 (with-heading-style (pane)
535 (princ "Function: " pane))
536 (with-text-family (pane :fix)
537 (princ (pretty-print-function object) pane))
538 #+sbcl
539 (unless (typep object 'generic-function)
540 (with-heading-style (pane)
541 (format pane "~&Type: "))
542 (with-text-family (pane :fix)
543 (princ (sb-kernel:%simple-fun-type (sb-kernel:%closure-fun object))
544 pane)))
545 (print-documentation object pane)
546 (when (gethash object (disassembly-dico *application-frame*))
547 (display-disassembly object pane))))
548
549 (defmethod inspect-object-briefly ((object package) pane)
550 ;; Display as 'Package: "PACKAGE-NAME"'. We're doing something a
551 ;; little unusual here by not bolding the "Package:" part. This may
552 ;; be a tad inconsistent, but the other way looks very odd.
553 (with-output-as-presentation
554 (pane object (presentation-type-of object))
555 (princ "Package: " pane)
556 (with-text-family (pane :fix)
557 (princ (package-name object) pane))))
558
559 (defun package-exported-symbols (package)
560 "Return a list of all symbols exported by PACKAGE"
561 (let (symbols)
562 (do-external-symbols (symbol package symbols)
563 (push symbol symbols))))
564
565 (defmethod inspect-object ((object package) pane)
566 (inspector-table (object pane)
567 (format pane "Package: ~S" (package-name object))
568 (inspector-table-row (pane)
569 (princ "Name:" pane)
570 (inspect-object (package-name object) pane))
571 (inspector-table-row (pane)
572 (princ "Nicknames:" pane)
573 (inspect-vertical-list (package-nicknames object) pane))
574 (inspector-table-row (pane)
575 (princ "Used by:")
576 (inspect-vertical-list (package-used-by-list object) pane))
577 (inspector-table-row (pane)
578 (princ "Uses:")
579 (inspect-vertical-list (package-use-list object) pane))
580 (inspector-table-row (pane)
581 (princ "Exports:")
582 (inspect-vertical-list (package-exported-symbols object) pane))))
583
584 (defmethod inspect-object ((object vector) pane)
585 (with-output-as-presentation
586 (pane object (presentation-type-of object))
587 (formatting-table (pane)
588 (formatting-row (pane)
589 (formatting-cell (pane)
590 (princ "#(" pane))
591 (dotimes (i (length object))
592 (formatting-cell (pane)
593 (inspect-object (aref object i) pane)))
594 (formatting-cell (pane)
595 (princ ")" pane))))))
596
597 (defmethod inspect-object-briefly ((object string) pane)
598 (with-output-as-presentation
599 (pane object (presentation-type-of object))
600 (prin1 object)))
601
602 (defmethod inspect-object-briefly ((object number) pane)
603 (with-output-as-presentation
604 (pane object (presentation-type-of object))
605 (prin1 object)))
606
607 (defun inspect-complex (object pane)
608 "Inspect a complex number. Since complex numbers should be inspected
609 the same way briefly and fully, this function can be called by both of
610 them."
611 (with-output-as-presentation
612 (pane object (presentation-type-of object))
613 (formatting-table (pane)
614 (formatting-row (pane)
615 (formatting-cell (pane)
616 (princ "#C(" pane))
617 (formatting-cell (pane)
618 (inspect-object (realpart object) pane))
619 (formatting-cell (pane)
620 (inspect-object (imagpart object) pane))
621 (formatting-cell (pane)
622 (princ ")" pane))))))
623
624 (defmethod inspect-object-briefly ((object complex) pane)
625 (inspect-complex object pane))
626
627 (defmethod inspect-object ((object complex) pane)
628 (inspect-complex object pane))
629
630 (defmethod inspect-object ((object float) pane)
631 (inspector-table (object pane)
632 (format pane "Float ~S" object)
633 (multiple-value-bind (significand exponent sign)
634 (decode-float object)
635 (inspector-table-rows (pane)
636 ("sign:" sign)
637 ("significand:" significand)
638 ("exponent:" exponent)))
639 (inspector-table-rows (pane)
640 ("radix:" (float-radix object)))))
641
642 (defun iso-8601-format (time)
643 "Return the given universal time in ISO 8601 format. This will raise
644 an error if the given time is not a decodable universal time."
645 (multiple-value-bind (sec min hour date month year)
646 (decode-universal-time time 0)
647 (format nil "~4,'0D-~2,'0D-~2,'0DT~2,'0D:~2,'0D:~2,'0DZ"
648 year month date hour min sec)))
649
650 (defmethod inspect-object ((object integer) pane)
651 (flet ((present-in-base (base &key (radix t) (family :fix))
652 (with-text-family (pane family)
653 (formatting-cell (pane)
654 (with-output-as-presentation
655 (pane object (presentation-type-of object))
656 (write object :radix radix :base base :stream pane)))))
657 (print-equals-cell ()
658 (formatting-cell (pane)
659 (princ "=" pane))))
660 (inspector-table (object pane)
661 (format pane "Integer ~S" object)
662 (inspector-table-row (pane)
663 (princ "value:" pane)
664 (formatting-table (pane)
665 (formatting-row (pane)
666 ;; Base 10 should be displayed normally, without the
667 ;; fixed-width font and without the radix.
668 (present-in-base 10 :radix nil :family :sans-serif)
669 (print-equals-cell) ; =
670 (present-in-base 16) ; Hexadecimal
671 (print-equals-cell) ; =
672 (present-in-base 8) ; Octal
673 (print-equals-cell) ; =
674 (present-in-base 2)))) ; Binary
675 (when (<= 0 object 255)
676 (inspector-table-row (pane)
677 (princ "character:" pane)
678 (inspect-object (code-char object) pane)))
679 (inspector-table-row (pane)
680 (princ "length:" pane)
681 (inspect-object (integer-length object) pane))
682 ;; Sometimes we get numbers that can't be interpreted as a
683 ;; time. Those throw an error, and this just isn't printed.
684 (ignore-errors
685 (inspector-table-row (pane)
686 (princ "as time:" pane)
687 (with-text-family (pane :fix)
688 (with-output-as-presentation
689 (pane object (presentation-type-of object))
690 (princ (iso-8601-format object) pane))))))))
691
692 (defmethod inspect-object-briefly ((object symbol) pane)
693 (with-output-as-presentation
694 (pane object (presentation-type-of object))
695 (with-text-family (pane :fix)
696 (prin1 object))))
697
698 (defmethod inspect-object ((object symbol) pane)
699 (inspector-table (object pane)
700 (format pane "Symbol ~S" (symbol-name object))
701 (inspector-table-row (pane)
702 (princ "value:" pane)
703 (if (boundp object)
704 (inspect-object (symbol-value object) pane)
705 (princ "unbound" pane)))
706 (inspector-table-row (pane)
707 (princ "function:" pane)
708 (if (fboundp object)
709 (inspect-object (symbol-function object) pane)
710 (princ "unbound" pane)))
711 ;; This is not, strictly speaking, a property of the
712 ;; symbol. However, this is useful enough that I think it's worth
713 ;; including here, since it can eliminate some minor annoyances.
714 (inspector-table-row (pane)
715 (princ "class:" pane)
716 (if (find-class object nil)
717 (inspect-object (find-class object) pane)
718 (princ "unbound" pane)))
719 (inspector-table-row (pane)
720 (princ "package:" pane)
721 (inspect-object (symbol-package object) pane))
722 (inspector-table-row (pane)
723 (princ "propery list:" pane)
724 (dolist (property (symbol-plist object))
725 (inspect-object property pane)))))
726
727 ;; Characters are so short that displaying them as "..." takes almost
728 ;; as much space as just showing them, and this way is more
729 ;; informative.
730 (defmethod inspect-object-briefly ((object character) pane)
731 (with-output-as-presentation
732 (pane object (presentation-type-of object))
733 (print object pane)))
734 (defmethod inspect-object ((object character) pane)
735 (inspector-table (object pane)
736 (format pane "Character ~S" object)
737 (inspector-table-rows (pane)
738 ("code:" (char-code object))
739 ("int:" (char-int object))
740 ("name:" (char-name object)))))
741
742 (defmethod inspect-object ((object pathname) pane)
743 (inspector-table (object pane)
744 (princ (if (wild-pathname-p object)
745 "Wild pathname"
746 "Pathname"))
747 (inspector-table-rows (pane)
748 ("namestring:" (namestring object))
749 ("host:" (pathname-host object))
750 ("device:" (pathname-device object))
751 ("directory:" (pathname-directory object))
752 ("name:" (pathname-name object))
753 ("type:" (pathname-type object))
754 ("version:" (pathname-version object)))
755 (unless (or (wild-pathname-p object)
756 (not (probe-file object)))
757 (inspector-table-row (pane)
758 (princ "truename:" pane)
759 (inspect-object (truename object) pane)))))
760
761 (defun display-app (frame pane)
762 "Display the APP frame of the inspector"
763 (inspect-object (obj frame) pane))
764
765 (define-inspector-command (com-quit :name t) ()
766 (frame-exit *application-frame*))
767
768 (define-inspector-command (com-inspect :name t) ()
769 (let ((obj (accept t :prompt "Select an object"))
770 (*application-frame* nil)) ; To get around security.
771 (inspector obj :new-process t)))
772
773 (define-inspector-command (com-toggle-show-list-cells :name t)
774 ((obj 'cons :gesture :select :prompt "Select a cons or list"))
775 (togglef (gethash obj (cons-cell-dico *application-frame*))))
776
777 (define-inspector-command (com-show-10-more-items :name t)
778 ((obj 'long-list-tail :gesture :select :prompt "Select a truncated list"))
779 (if (gethash obj (print-length *application-frame*))
780 (incf (gethash obj (print-length *application-frame*)) 10)
781 (setf (gethash obj (print-length *application-frame*))
782 (+ 10 *print-length*))))
783
784 (define-inspector-command (com-toggle-inspect :name t)
785 ((obj t :gesture :select :prompt "Select an object"))
786 (unless (or (eq obj (obj *application-frame*))
787 (null obj))
788 (togglef (gethash obj (dico *application-frame*)))))
789
790 (define-inspector-command (com-remove-method :name t)
791 ((obj 'method :gesture :delete :prompt "Remove method"))
792 (remove-method (clim-mop:method-generic-function obj) obj))
793
794 (define-inspector-command (com-set-slot :name t)
795 ((slot 'settable-slot :gesture :select :prompt "Set slot"))
796 (handler-case (setf (slot-value (car slot) (cdr slot))
797 (accept t :prompt "New slot value"))
798 (simple-parse-error ()
799 (format (get-frame-pane *application-frame* 'int)
800 "~&Command canceled; slot value not set~%"))))
801
802 (defun slot-documentation (class slot)
803 "Returns the documentation of a slot of a class, or nil. There is,
804 unfortunately, no portable way to do this, but the MOP is
805 semi-portable and we can use it. To complicate things even more, some
806 implementations have unpleasant oddities in the way they store slot
807 documentation. For example, in SBCL slot documentation is only
808 available in direct slots."
809 (let ((slot-object (find slot (clim-mop:class-direct-slots class)
810 :key #'clim-mop:slot-definition-name)))
811 (if slot-object
812 (documentation slot-object t)
813 (when (clim-mop:class-direct-superclasses class)
814 (find-if #'identity
815 (mapcar #'(lambda (class)
816 (slot-documentation class slot))
817 (clim-mop:class-direct-superclasses class)))))))
818
819 (define-inspector-command (com-describe-slot :name t)
820 ((slot 'settable-slot :gesture :describe :prompt "Describe slot"))
821 (destructuring-bind (object . slot-name) slot
822 (let* ((stream (get-frame-pane *application-frame* 'int))
823 (class (class-of object))
824 (documentation (handler-bind ((warning #'muffle-warning))
825 (slot-documentation class slot-name)))
826 (slot-object (or (find slot-name (clim-mop:class-direct-slots class)
827 :key #'clim-mop:slot-definition-name)
828 (find slot-name (clim-mop:class-slots class)
829 :key #'clim-mop:slot-definition-name))))
830 (when documentation
831 (with-heading-style (stream)
832 (format stream "~&Documentation: "))
833 (format stream "~A~%" documentation))
834 (with-heading-style (stream)
835 (format stream "~&Type: "))
836 (format stream "~S~%" (clim-mop:slot-definition-type slot-object))
837 (with-heading-style (stream)
838 (format stream "~&Allocation: "))
839 (format stream "~S~%" (clim-mop:slot-definition-allocation slot-object))
840 ;; slot-definition-{readers,writers} only works for direct slot
841 ;; definitions
842 (let ((readers (clim-mop:slot-definition-readers slot-object)))
843 (when readers
844 (with-heading-style (stream)
845 (format stream "~&Readers: "))
846 (present readers (presentation-type-of readers) :stream stream)))
847 (let ((writers (clim-mop:slot-definition-writers slot-object)))
848 (when writers
849 (with-heading-style (stream)
850 (format stream "~&Writers: "))
851 (present writers (presentation-type-of writers) :stream stream))))))
852
853 (define-inspector-command (com-disassemble :name t)
854 ((obj 'inspected-function
855 :prompt "Select a function"))
856 (when (typep obj 'function)
857 (togglef (gethash obj (disassembly-dico *application-frame*)))))
858
859 (define-presentation-to-command-translator disassemble-function
860 (inspected-function com-disassemble inspector
861 :documentation "Toggle Disassembly"
862 :gesture :menu
863 :menu t)
864 (object)
865 (list object))
866
867 (defun tracedp (symbol)
868 "Is SYMBOL currently traced?"
869 (member symbol (trace)))
870
871 (define-inspector-command (com-trace :name t)
872 ((obj 'symbol
873 :prompt "Select an fbound symbol"))
874 (when (fboundp obj)
875 (eval `(trace ,obj))))
876
877 (define-inspector-command (com-untrace :name t)
878 ((obj 'symbol
879 :prompt "Select an fbound symbol"))
880 (when (fboundp obj)
881 (eval `(untrace ,obj))))
882
883 (define-presentation-to-command-translator trace-symbol
884 (symbol com-trace inspector
885 :documentation "Trace"
886 :gesture :menu
887 :menu t
888 :tester ((object) (and object
889 (fboundp object)
890 (not (tracedp object)))))
891 (object)
892 (list object))
893
894 (define-presentation-to-command-translator untrace-symbol
895 (symbol com-untrace inspector
896 :documentation "Untrace"
897 :gesture :menu
898 :menu t
899 :tester ((object) (and object
900 (fboundp object)
901 (tracedp object))))
902 (object)
903 (list object))
904
905 ;; FIXME: This is a horrible hack to gloss over issues that I don't
906 ;; properly understand. See
907 ;; <http://common-lisp.net/pipermail/mcclim-devel/2005-February/003700.html>
908 (defmethod clim:presentation-type-of ((object standard-generic-function))
909 'clim:expression)

  ViewVC Help
Powered by ViewVC 1.1.5