Mercurial > emacs
annotate lisp/cedet/data-debug.el @ 110682:ba6a1c230532
gnus-html.el (gnus-html-prefetch-images): Adjust regexp to avoid regexp backtrace overflows.
author | Katsumi Yamaoka <yamaoka@jpl.org> |
---|---|
date | Fri, 01 Oct 2010 13:33:03 +0000 |
parents | 280c8ae2476d |
children | 417b1e4d63cd |
rev | line source |
---|---|
105241 | 1 ;;; data-debug.el --- Datastructure Debugger |
2 | |
106815 | 3 ;; Copyright (C) 2007, 2008, 2009, 2010 Free Software Foundation, Inc. |
105241 | 4 |
5 ;; Author: Eric M. Ludlam <zappo@gnu.org> | |
6 ;; Version: 0.2 | |
7 ;; Keywords: OO, lisp | |
110015
280c8ae2476d
Add "Package:" file headers to denote built-in packages.
Chong Yidong <cyd@stupidchicken.com>
parents:
107167
diff
changeset
|
8 ;; Package: cedet |
105241 | 9 |
10 ;; This file is part of GNU Emacs. | |
11 | |
12 ;; GNU Emacs is free software: you can redistribute it and/or modify | |
13 ;; it under the terms of the GNU General Public License as published by | |
14 ;; the Free Software Foundation, either version 3 of the License, or | |
15 ;; (at your option) any later version. | |
16 | |
17 ;; GNU Emacs is distributed in the hope that it will be useful, | |
18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
20 ;; GNU General Public License for more details. | |
21 | |
22 ;; You should have received a copy of the GNU General Public License | |
23 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. | |
24 | |
25 ;;; Commentary: | |
26 ;; | |
27 ;; Provide a simple way to investigate particularly large and complex | |
28 ;; data structures. | |
29 ;; | |
30 ;; The best way to get started is to bind M-: to 'data-debug-eval-expression. | |
31 ;; | |
32 ;; (global-set-key "\M-:" 'data-debug-eval-expression) | |
33 ;; | |
34 ;; If you write functions with complex output that need debugging, you | |
35 ;; can make them interactive with data-debug-show-stuff. For example: | |
36 ;; | |
37 ;; (defun my-complex-output-fcn () | |
38 ;; "Calculate something complicated at point, and return it." | |
39 ;; (interactive) ;; function not normally interactive | |
40 ;; (let ((stuff (do-stuff))) | |
41 ;; (when (interactive-p) | |
42 ;; (data-debug-show-stuff stuff "myStuff")) | |
43 ;; stuff)) | |
44 | |
45 (require 'font-lock) | |
46 (require 'ring) | |
47 | |
48 ;;; Code: | |
49 | |
50 ;;; Compatibility | |
51 ;; | |
52 (if (featurep 'xemacs) | |
53 (eval-and-compile | |
54 (defalias 'data-debug-overlay-properties 'extent-properties) | |
55 (defalias 'data-debug-overlay-p 'extentp) | |
56 (if (not (fboundp 'propertize)) | |
57 (defun dd-propertize (string &rest properties) | |
58 "Mimic 'propertize' in from Emacs 23." | |
59 (add-text-properties 0 (length string) properties string) | |
60 string | |
61 ) | |
62 (defalias 'dd-propertize 'propertize)) | |
63 ) | |
64 ;; Regular Emacs | |
65 (eval-and-compile | |
66 (defalias 'data-debug-overlay-properties 'overlay-properties) | |
67 (defalias 'data-debug-overlay-p 'overlayp) | |
68 (defalias 'dd-propertize 'propertize) | |
69 ) | |
70 ) | |
71 | |
72 ;;; GENERIC STUFF | |
73 ;; | |
74 (defun data-debug-insert-property-list (proplist prefix &optional parent) | |
75 "Insert the property list PROPLIST. | |
76 Each line starts with PREFIX. | |
77 The attributes belong to the tag PARENT." | |
78 (while proplist | |
79 (let ((pretext (concat (symbol-name (car proplist)) " : "))) | |
80 (data-debug-insert-thing (car (cdr proplist)) | |
81 prefix | |
82 pretext | |
83 parent)) | |
84 (setq proplist (cdr (cdr proplist))))) | |
85 | |
86 ;;; overlays | |
87 ;; | |
88 (defun data-debug-insert-overlay-props (overlay prefix) | |
89 "Insert all the parts of OVERLAY. | |
90 PREFIX specifies what to insert at the start of each line." | |
91 (let ((attrprefix (concat (make-string (length prefix) ? ) "# ")) | |
92 (proplist (data-debug-overlay-properties overlay))) | |
93 (data-debug-insert-property-list | |
94 proplist attrprefix) | |
95 ) | |
96 ) | |
97 | |
98 (defun data-debug-insert-overlay-from-point (point) | |
99 "Insert the overlay found at the overlay button at POINT." | |
100 (let ((overlay (get-text-property point 'ddebug)) | |
101 (indent (get-text-property point 'ddebug-indent)) | |
102 start | |
103 ) | |
104 (end-of-line) | |
105 (setq start (point)) | |
106 (forward-char 1) | |
107 (data-debug-insert-overlay-props overlay | |
108 (concat (make-string indent ? ) | |
109 "| ")) | |
110 (goto-char start) | |
111 )) | |
112 | |
113 (defun data-debug-insert-overlay-button (overlay prefix prebuttontext) | |
114 "Insert a button representing OVERLAY. | |
105325 | 115 PREFIX is the text that precedes the button. |
105241 | 116 PREBUTTONTEXT is some text between prefix and the overlay button." |
117 (let ((start (point)) | |
118 (end nil) | |
119 (str (format "%s" overlay)) | |
120 (tip nil)) | |
121 (insert prefix prebuttontext str) | |
122 (setq end (point)) | |
123 (put-text-property (- end (length str)) end 'face 'font-lock-comment-face) | |
124 (put-text-property start end 'ddebug overlay) | |
125 (put-text-property start end 'ddebug-indent(length prefix)) | |
126 (put-text-property start end 'ddebug-prefix prefix) | |
127 (put-text-property start end 'help-echo tip) | |
128 (put-text-property start end 'ddebug-function | |
129 'data-debug-insert-overlay-from-point) | |
130 (insert "\n") | |
131 ) | |
132 ) | |
133 | |
134 ;;; overlay list | |
135 ;; | |
136 (defun data-debug-insert-overlay-list (overlaylist prefix) | |
137 "Insert all the parts of OVERLAYLIST. | |
138 PREFIX specifies what to insert at the start of each line." | |
139 (while overlaylist | |
140 (data-debug-insert-overlay-button (car overlaylist) | |
141 prefix | |
142 "") | |
143 (setq overlaylist (cdr overlaylist)))) | |
144 | |
145 (defun data-debug-insert-overlay-list-from-point (point) | |
146 "Insert the overlay found at the overlay list button at POINT." | |
147 (let ((overlaylist (get-text-property point 'ddebug)) | |
148 (indent (get-text-property point 'ddebug-indent)) | |
149 start | |
150 ) | |
151 (end-of-line) | |
152 (setq start (point)) | |
153 (forward-char 1) | |
154 (data-debug-insert-overlay-list overlaylist | |
155 (concat (make-string indent ? ) | |
156 "* ")) | |
157 (goto-char start) | |
158 )) | |
159 | |
160 (defun data-debug-insert-overlay-list-button (overlaylist | |
161 prefix | |
162 prebuttontext) | |
163 "Insert a button representing OVERLAYLIST. | |
105325 | 164 PREFIX is the text that precedes the button. |
105241 | 165 PREBUTTONTEXT is some text between prefix and the overlay list button." |
166 (let ((start (point)) | |
167 (end nil) | |
168 (str (format "#<overlay list: %d entries>" (length overlaylist))) | |
169 (tip nil)) | |
170 (insert prefix prebuttontext str) | |
171 (setq end (point)) | |
172 (put-text-property (- end (length str)) end 'face 'font-lock-comment-face) | |
173 (put-text-property start end 'ddebug overlaylist) | |
174 (put-text-property start end 'ddebug-indent(length prefix)) | |
175 (put-text-property start end 'ddebug-prefix prefix) | |
176 (put-text-property start end 'help-echo tip) | |
177 (put-text-property start end 'ddebug-function | |
178 'data-debug-insert-overlay-list-from-point) | |
179 (insert "\n") | |
180 ) | |
181 ) | |
182 | |
183 ;;; buffers | |
184 ;; | |
185 (defun data-debug-insert-buffer-props (buffer prefix) | |
186 "Insert all the parts of BUFFER. | |
187 PREFIX specifies what to insert at the start of each line." | |
188 (let ((attrprefix (concat (make-string (length prefix) ? ) "# ")) | |
189 (proplist | |
190 (list :filename (buffer-file-name buffer) | |
191 :live (buffer-live-p buffer) | |
192 :modified (buffer-modified-p buffer) | |
193 :size (buffer-size buffer) | |
194 :process (get-buffer-process buffer) | |
195 :localvars (buffer-local-variables buffer) | |
196 ))) | |
197 (data-debug-insert-property-list | |
198 proplist attrprefix) | |
199 ) | |
200 ) | |
201 | |
202 (defun data-debug-insert-buffer-from-point (point) | |
203 "Insert the buffer found at the buffer button at POINT." | |
204 (let ((buffer (get-text-property point 'ddebug)) | |
205 (indent (get-text-property point 'ddebug-indent)) | |
206 start | |
207 ) | |
208 (end-of-line) | |
209 (setq start (point)) | |
210 (forward-char 1) | |
211 (data-debug-insert-buffer-props buffer | |
212 (concat (make-string indent ? ) | |
213 "| ")) | |
214 (goto-char start) | |
215 )) | |
216 | |
217 (defun data-debug-insert-buffer-button (buffer prefix prebuttontext) | |
218 "Insert a button representing BUFFER. | |
105325 | 219 PREFIX is the text that precedes the button. |
105241 | 220 PREBUTTONTEXT is some text between prefix and the buffer button." |
221 (let ((start (point)) | |
222 (end nil) | |
223 (str (format "%S" buffer)) | |
224 (tip nil)) | |
225 (insert prefix prebuttontext str) | |
226 (setq end (point)) | |
227 (put-text-property (- end (length str)) end 'face 'font-lock-comment-face) | |
228 (put-text-property start end 'ddebug buffer) | |
229 (put-text-property start end 'ddebug-indent(length prefix)) | |
230 (put-text-property start end 'ddebug-prefix prefix) | |
231 (put-text-property start end 'help-echo tip) | |
232 (put-text-property start end 'ddebug-function | |
233 'data-debug-insert-buffer-from-point) | |
234 (insert "\n") | |
235 ) | |
236 ) | |
237 | |
238 ;;; buffer list | |
239 ;; | |
240 (defun data-debug-insert-buffer-list (bufferlist prefix) | |
241 "Insert all the parts of BUFFERLIST. | |
242 PREFIX specifies what to insert at the start of each line." | |
243 (while bufferlist | |
244 (data-debug-insert-buffer-button (car bufferlist) | |
245 prefix | |
246 "") | |
247 (setq bufferlist (cdr bufferlist)))) | |
248 | |
249 (defun data-debug-insert-buffer-list-from-point (point) | |
250 "Insert the buffer found at the buffer list button at POINT." | |
251 (let ((bufferlist (get-text-property point 'ddebug)) | |
252 (indent (get-text-property point 'ddebug-indent)) | |
253 start | |
254 ) | |
255 (end-of-line) | |
256 (setq start (point)) | |
257 (forward-char 1) | |
258 (data-debug-insert-buffer-list bufferlist | |
259 (concat (make-string indent ? ) | |
260 "* ")) | |
261 (goto-char start) | |
262 )) | |
263 | |
264 (defun data-debug-insert-buffer-list-button (bufferlist | |
265 prefix | |
266 prebuttontext) | |
267 "Insert a button representing BUFFERLIST. | |
105325 | 268 PREFIX is the text that precedes the button. |
105241 | 269 PREBUTTONTEXT is some text between prefix and the buffer list button." |
270 (let ((start (point)) | |
271 (end nil) | |
272 (str (format "#<buffer list: %d entries>" (length bufferlist))) | |
273 (tip nil)) | |
274 (insert prefix prebuttontext str) | |
275 (setq end (point)) | |
276 (put-text-property (- end (length str)) end 'face 'font-lock-comment-face) | |
277 (put-text-property start end 'ddebug bufferlist) | |
278 (put-text-property start end 'ddebug-indent(length prefix)) | |
279 (put-text-property start end 'ddebug-prefix prefix) | |
280 (put-text-property start end 'help-echo tip) | |
281 (put-text-property start end 'ddebug-function | |
282 'data-debug-insert-buffer-list-from-point) | |
283 (insert "\n") | |
284 ) | |
285 ) | |
286 | |
287 ;;; processes | |
288 ;; | |
289 (defun data-debug-insert-process-props (process prefix) | |
290 "Insert all the parts of PROCESS. | |
291 PREFIX specifies what to insert at the start of each line." | |
292 (let ((attrprefix (concat (make-string (length prefix) ? ) "# ")) | |
293 (id (process-id process)) | |
294 (tty (process-tty-name process)) | |
295 (pcontact (process-contact process t)) | |
296 (proplist (process-plist process))) | |
297 (data-debug-insert-property-list | |
298 (append | |
299 (if id (list 'id id)) | |
300 (if tty (list 'tty tty)) | |
301 (if pcontact pcontact) | |
302 proplist) | |
303 attrprefix) | |
304 ) | |
305 ) | |
306 | |
307 (defun data-debug-insert-process-from-point (point) | |
308 "Insert the process found at the process button at POINT." | |
309 (let ((process (get-text-property point 'ddebug)) | |
310 (indent (get-text-property point 'ddebug-indent)) | |
311 start | |
312 ) | |
313 (end-of-line) | |
314 (setq start (point)) | |
315 (forward-char 1) | |
316 (data-debug-insert-process-props process | |
317 (concat (make-string indent ? ) | |
318 "| ")) | |
319 (goto-char start) | |
320 )) | |
321 | |
322 (defun data-debug-insert-process-button (process prefix prebuttontext) | |
323 "Insert a button representing PROCESS. | |
105325 | 324 PREFIX is the text that precedes the button. |
105241 | 325 PREBUTTONTEXT is some text between prefix and the process button." |
326 (let ((start (point)) | |
327 (end nil) | |
328 (str (format "%S : %s" process (process-status process))) | |
329 (tip nil)) | |
330 (insert prefix prebuttontext str) | |
331 (setq end (point)) | |
332 (put-text-property (- end (length str)) end 'face 'font-lock-comment-face) | |
333 (put-text-property start end 'ddebug process) | |
334 (put-text-property start end 'ddebug-indent(length prefix)) | |
335 (put-text-property start end 'ddebug-prefix prefix) | |
336 (put-text-property start end 'help-echo tip) | |
337 (put-text-property start end 'ddebug-function | |
338 'data-debug-insert-process-from-point) | |
339 (insert "\n") | |
340 ) | |
341 ) | |
342 | |
343 ;;; Rings | |
344 ;; | |
345 ;; A ring (like kill-ring, or whatever.) | |
346 (defun data-debug-insert-ring-contents (ring prefix) | |
347 "Insert all the parts of RING. | |
348 PREFIX specifies what to insert at the start of each line." | |
349 (let ((len (ring-length ring)) | |
350 (idx 0) | |
351 ) | |
352 (while (< idx len) | |
353 (data-debug-insert-thing (ring-ref ring idx) prefix "") | |
354 (setq idx (1+ idx)) | |
355 ))) | |
356 | |
357 (defun data-debug-insert-ring-items-from-point (point) | |
358 "Insert the ring found at the ring button at POINT." | |
359 (let ((ring (get-text-property point 'ddebug)) | |
360 (indent (get-text-property point 'ddebug-indent)) | |
361 start | |
362 ) | |
363 (end-of-line) | |
364 (setq start (point)) | |
365 (forward-char 1) | |
366 (data-debug-insert-ring-contents ring | |
367 (concat (make-string indent ? ) | |
368 "} ")) | |
369 (goto-char start) | |
370 )) | |
371 | |
372 (defun data-debug-insert-ring-button (ring | |
373 prefix | |
374 prebuttontext) | |
375 "Insert a button representing RING. | |
105325 | 376 PREFIX is the text that precedes the button. |
105241 | 377 PREBUTTONTEXT is some text between prefix and the stuff list button." |
378 (let* ((start (point)) | |
379 (end nil) | |
380 (str (format "#<RING: %d, %d max>" | |
381 (ring-length ring) | |
382 (ring-size ring))) | |
383 (ringthing | |
384 (if (= (ring-length ring) 0) nil (ring-ref ring 0))) | |
385 (tip (format "Ring max-size %d, length %d." | |
386 (ring-size ring) | |
387 (ring-length ring))) | |
388 ) | |
389 (insert prefix prebuttontext str) | |
390 (setq end (point)) | |
391 (put-text-property (- end (length str)) end 'face 'font-lock-type-face) | |
392 (put-text-property start end 'ddebug ring) | |
393 (put-text-property start end 'ddebug-indent(length prefix)) | |
394 (put-text-property start end 'ddebug-prefix prefix) | |
395 (put-text-property start end 'help-echo tip) | |
396 (put-text-property start end 'ddebug-function | |
397 'data-debug-insert-ring-items-from-point) | |
398 (insert "\n") | |
399 ) | |
400 ) | |
401 | |
402 | |
403 ;;; Hash-table | |
404 ;; | |
405 | |
406 (defun data-debug-insert-hash-table (hash-table prefix) | |
407 "Insert the contents of HASH-TABLE inserting PREFIX before each element." | |
408 (maphash | |
409 (lambda (key value) | |
410 (data-debug-insert-thing | |
411 key prefix | |
412 (dd-propertize "key " 'face font-lock-comment-face)) | |
413 (data-debug-insert-thing | |
414 value prefix | |
415 (dd-propertize "val " 'face font-lock-comment-face))) | |
416 hash-table)) | |
417 | |
418 (defun data-debug-insert-hash-table-from-point (point) | |
419 "Insert the contents of the hash-table button at POINT." | |
420 (let ((hash-table (get-text-property point 'ddebug)) | |
421 (indent (get-text-property point 'ddebug-indent)) | |
422 start) | |
423 (end-of-line) | |
424 (setq start (point)) | |
425 (forward-char 1) | |
426 (data-debug-insert-hash-table | |
427 hash-table | |
428 (concat (make-string indent ? ) "> ")) | |
429 (goto-char start)) | |
430 ) | |
431 | |
432 (defun data-debug-insert-hash-table-button (hash-table prefix prebuttontext) | |
433 "Insert HASH-TABLE as expandable button with recursive prefix PREFIX and PREBUTTONTEXT in front of the button text." | |
434 (let ((string (dd-propertize (format "%s" hash-table) | |
435 'face 'font-lock-keyword-face))) | |
436 (insert (dd-propertize | |
437 (concat prefix prebuttontext string) | |
438 'ddebug hash-table | |
439 'ddebug-indent (length prefix) | |
440 'ddebug-prefix prefix | |
441 'help-echo | |
442 (format "Hash-table\nTest: %s\nWeakness: %s\nElements: %d (of %d)" | |
443 (hash-table-test hash-table) | |
444 (if (hash-table-weakness hash-table) "yes" "no") | |
445 (hash-table-count hash-table) | |
446 (hash-table-size hash-table)) | |
447 'ddebug-function | |
448 'data-debug-insert-hash-table-from-point) | |
449 "\n")) | |
450 ) | |
451 | |
452 ;;; Widget | |
453 ;; | |
454 ;; Widgets have a long list of properties | |
455 (defun data-debug-insert-widget-properties (widget prefix) | |
456 "Insert the contents of WIDGET inserting PREFIX before each element." | |
457 (let ((type (car widget)) | |
458 (rest (cdr widget))) | |
459 (while rest | |
460 (data-debug-insert-thing (car (cdr rest)) | |
461 prefix | |
462 (concat | |
463 (dd-propertize (format "%s" (car rest)) | |
464 'face font-lock-comment-face) | |
465 " : ")) | |
466 (setq rest (cdr (cdr rest)))) | |
467 )) | |
468 | |
469 (defun data-debug-insert-widget-from-point (point) | |
470 "Insert the contents of the widget button at POINT." | |
471 (let ((widget (get-text-property point 'ddebug)) | |
472 (indent (get-text-property point 'ddebug-indent)) | |
473 start) | |
474 (end-of-line) | |
475 (setq start (point)) | |
476 (forward-char 1) | |
477 (data-debug-insert-widget-properties | |
478 widget (concat (make-string indent ? ) "# ")) | |
479 (goto-char start)) | |
480 ) | |
481 | |
482 (defun data-debug-insert-widget (widget prefix prebuttontext) | |
483 "Insert one WIDGET. | |
484 A Symbol is a simple thing, but this provides some face and prefix rules. | |
105325 | 485 PREFIX is the text that precedes the button. |
105241 | 486 PREBUTTONTEXT is some text between prefix and the thing." |
487 (let ((string (dd-propertize (format "#<WIDGET %s>" (car widget)) | |
488 'face 'font-lock-keyword-face))) | |
489 (insert (dd-propertize | |
490 (concat prefix prebuttontext string) | |
491 'ddebug widget | |
492 'ddebug-indent (length prefix) | |
493 'ddebug-prefix prefix | |
494 'help-echo | |
495 (format "Widget\nType: %s\n# Properties: %d" | |
496 (car widget) | |
497 (/ (1- (length widget)) 2)) | |
498 'ddebug-function | |
499 'data-debug-insert-widget-from-point) | |
500 "\n"))) | |
501 | |
502 ;;; list of stuff | |
503 ;; | |
504 ;; just a list. random stuff inside. | |
505 (defun data-debug-insert-stuff-list (stufflist prefix) | |
506 "Insert all the parts of STUFFLIST. | |
507 PREFIX specifies what to insert at the start of each line." | |
508 (while stufflist | |
509 (data-debug-insert-thing | |
510 ;; Some lists may put a value in the CDR | |
511 (if (listp stufflist) (car stufflist) stufflist) | |
512 prefix | |
513 "") | |
514 (setq stufflist | |
515 (if (listp stufflist) | |
516 (cdr-safe stufflist) | |
517 nil)))) | |
518 | |
519 (defun data-debug-insert-stuff-list-from-point (point) | |
520 "Insert the stuff found at the stuff list button at POINT." | |
521 (let ((stufflist (get-text-property point 'ddebug)) | |
522 (indent (get-text-property point 'ddebug-indent)) | |
523 start | |
524 ) | |
525 (end-of-line) | |
526 (setq start (point)) | |
527 (forward-char 1) | |
528 (data-debug-insert-stuff-list stufflist | |
529 (concat (make-string indent ? ) | |
530 "> ")) | |
531 (goto-char start) | |
532 )) | |
533 | |
534 (defun data-debug-insert-stuff-list-button (stufflist | |
535 prefix | |
536 prebuttontext) | |
537 "Insert a button representing STUFFLIST. | |
105325 | 538 PREFIX is the text that precedes the button. |
105241 | 539 PREBUTTONTEXT is some text between prefix and the stuff list button." |
540 (let ((start (point)) | |
541 (end nil) | |
542 (str | |
543 (condition-case nil | |
544 (format "#<list o' stuff: %d entries>" (safe-length stufflist)) | |
545 (error "#<list o' stuff>"))) | |
546 (tip (if (or (listp (car stufflist)) | |
547 (vectorp (car stufflist))) | |
548 "" | |
549 (format "%s" stufflist)))) | |
550 (insert prefix prebuttontext str) | |
551 (setq end (point)) | |
552 (put-text-property (- end (length str)) end 'face 'font-lock-variable-name-face) | |
553 (put-text-property start end 'ddebug stufflist) | |
554 (put-text-property start end 'ddebug-indent (length prefix)) | |
555 (put-text-property start end 'ddebug-prefix prefix) | |
556 (put-text-property start end 'help-echo tip) | |
557 (put-text-property start end 'ddebug-function | |
558 'data-debug-insert-stuff-list-from-point) | |
559 (insert "\n") | |
560 ) | |
561 ) | |
562 | |
563 ;;; vector of stuff | |
564 ;; | |
565 ;; just a vector. random stuff inside. | |
566 (defun data-debug-insert-stuff-vector (stuffvector prefix) | |
567 "Insert all the parts of STUFFVECTOR. | |
568 PREFIX specifies what to insert at the start of each line." | |
569 (let ((idx 0)) | |
570 (while (< idx (length stuffvector)) | |
571 (data-debug-insert-thing | |
572 ;; Some vectors may put a value in the CDR | |
573 (aref stuffvector idx) | |
574 prefix | |
575 "") | |
576 (setq idx (1+ idx))))) | |
577 | |
578 (defun data-debug-insert-stuff-vector-from-point (point) | |
579 "Insert the stuff found at the stuff vector button at POINT." | |
580 (let ((stuffvector (get-text-property point 'ddebug)) | |
581 (indent (get-text-property point 'ddebug-indent)) | |
582 start | |
583 ) | |
584 (end-of-line) | |
585 (setq start (point)) | |
586 (forward-char 1) | |
587 (data-debug-insert-stuff-vector stuffvector | |
588 (concat (make-string indent ? ) | |
589 "[ ")) | |
590 (goto-char start) | |
591 )) | |
592 | |
593 (defun data-debug-insert-stuff-vector-button (stuffvector | |
594 prefix | |
595 prebuttontext) | |
596 "Insert a button representing STUFFVECTOR. | |
105325 | 597 PREFIX is the text that precedes the button. |
105241 | 598 PREBUTTONTEXT is some text between prefix and the stuff vector button." |
599 (let* ((start (point)) | |
600 (end nil) | |
601 (str (format "#<vector o' stuff: %d entries>" (length stuffvector))) | |
602 (tip str)) | |
603 (insert prefix prebuttontext str) | |
604 (setq end (point)) | |
605 (put-text-property (- end (length str)) end 'face 'font-lock-variable-name-face) | |
606 (put-text-property start end 'ddebug stuffvector) | |
607 (put-text-property start end 'ddebug-indent (length prefix)) | |
608 (put-text-property start end 'ddebug-prefix prefix) | |
609 (put-text-property start end 'help-echo tip) | |
610 (put-text-property start end 'ddebug-function | |
611 'data-debug-insert-stuff-vector-from-point) | |
612 (insert "\n") | |
613 ) | |
614 ) | |
615 | |
616 ;;; Symbol | |
617 ;; | |
618 | |
619 (defun data-debug-insert-symbol-from-point (point) | |
620 "Insert attached properties and possibly the value of symbol at POINT." | |
621 (let ((symbol (get-text-property point 'ddebug)) | |
622 (indent (get-text-property point 'ddebug-indent)) | |
623 start) | |
624 (end-of-line) | |
625 (setq start (point)) | |
626 (forward-char 1) | |
627 (when (and (not (fboundp symbol)) (boundp symbol)) | |
628 (data-debug-insert-thing | |
629 (symbol-value symbol) | |
630 (concat (make-string indent ? ) "> ") | |
631 (concat | |
632 (dd-propertize "value" | |
633 'face 'font-lock-comment-face) | |
634 " "))) | |
635 (data-debug-insert-property-list | |
636 (symbol-plist symbol) | |
637 (concat (make-string indent ? ) "> ")) | |
638 (goto-char start)) | |
639 ) | |
640 | |
641 (defun data-debug-insert-symbol-button (symbol prefix prebuttontext) | |
642 "Insert a button representing SYMBOL. | |
105325 | 643 PREFIX is the text that precedes the button. |
644 PREBUTTONTEXT is some text between prefix and the symbol button." | |
105241 | 645 (let ((string |
646 (cond ((fboundp symbol) | |
647 (dd-propertize (concat "#'" (symbol-name symbol)) | |
648 'face 'font-lock-function-name-face)) | |
649 ((boundp symbol) | |
650 (dd-propertize (concat "'" (symbol-name symbol)) | |
651 'face 'font-lock-variable-name-face)) | |
652 (t (format "'%s" symbol))))) | |
653 (insert (dd-propertize | |
654 (concat prefix prebuttontext string) | |
655 'ddebug symbol | |
656 'ddebug-indent (length prefix) | |
657 'ddebug-prefix prefix | |
658 'help-echo "" | |
659 'ddebug-function | |
660 'data-debug-insert-symbol-from-point) | |
661 "\n")) | |
662 ) | |
663 | |
664 ;;; String | |
665 (defun data-debug-insert-string (thing prefix prebuttontext) | |
666 "Insert one symbol THING. | |
667 A Symbol is a simple thing, but this provides some face and prefix rules. | |
105325 | 668 PREFIX is the text that precedes the button. |
105241 | 669 PREBUTTONTEXT is some text between prefix and the thing." |
670 (let ((newstr thing)) | |
671 (while (string-match "\n" newstr) | |
672 (setq newstr (replace-match "\\n" t t newstr))) | |
673 (while (string-match "\t" newstr) | |
674 (setq newstr (replace-match "\\t" t t newstr))) | |
675 (insert prefix prebuttontext | |
676 (dd-propertize (format "\"%s\"" newstr) | |
677 'face font-lock-string-face) | |
678 "\n" ))) | |
679 | |
680 ;;; Number | |
681 (defun data-debug-insert-number (thing prefix prebuttontext) | |
682 "Insert one symbol THING. | |
683 A Symbol is a simple thing, but this provides some face and prefix rules. | |
105325 | 684 PREFIX is the text that precedes the button. |
105241 | 685 PREBUTTONTEXT is some text between prefix and the thing." |
686 (insert prefix prebuttontext | |
687 (dd-propertize (format "%S" thing) | |
688 'face font-lock-string-face) | |
689 "\n")) | |
690 | |
691 ;;; Lambda Expression | |
692 (defun data-debug-insert-lambda-expression (thing prefix prebuttontext) | |
693 "Insert one lambda expression THING. | |
694 A Symbol is a simple thing, but this provides some face and prefix rules. | |
105325 | 695 PREFIX is the text that precedes the button. |
105241 | 696 PREBUTTONTEXT is some text between prefix and the thing." |
697 (let ((txt (prin1-to-string thing))) | |
698 (data-debug-insert-simple-thing | |
699 txt prefix prebuttontext 'font-lock-keyword-face)) | |
700 ) | |
701 | |
702 ;;; nil thing | |
703 (defun data-debug-insert-nil (thing prefix prebuttontext) | |
704 "Insert one simple THING with a face. | |
105325 | 705 PREFIX is the text that precedes the button. |
105241 | 706 PREBUTTONTEXT is some text between prefix and the thing. |
707 FACE is the face to use." | |
708 (insert prefix prebuttontext) | |
709 (insert ": ") | |
710 (let ((start (point)) | |
711 (end nil)) | |
712 (insert "nil") | |
713 (setq end (point)) | |
714 (insert "\n" ) | |
715 (put-text-property start end 'face 'font-lock-variable-name-face) | |
716 )) | |
717 | |
718 ;;; simple thing | |
719 (defun data-debug-insert-simple-thing (thing prefix prebuttontext face) | |
720 "Insert one simple THING with a face. | |
105325 | 721 PREFIX is the text that precedes the button. |
105241 | 722 PREBUTTONTEXT is some text between prefix and the thing. |
723 FACE is the face to use." | |
724 (insert prefix prebuttontext) | |
725 (let ((start (point)) | |
726 (end nil)) | |
727 (insert (format "%s" thing)) | |
728 (setq end (point)) | |
729 (insert "\n" ) | |
730 (put-text-property start end 'face face) | |
731 )) | |
732 | |
733 ;;; custom thing | |
734 (defun data-debug-insert-custom (thingstring prefix prebuttontext face) | |
735 "Insert one simple THINGSTRING with a face. | |
736 Use for simple items that need a custom insert. | |
105325 | 737 PREFIX is the text that precedes the button. |
105241 | 738 PREBUTTONTEXT is some text between prefix and the thing. |
739 FACE is the face to use." | |
740 (insert prefix prebuttontext) | |
741 (let ((start (point)) | |
742 (end nil)) | |
743 (insert thingstring) | |
744 (setq end (point)) | |
745 (insert "\n" ) | |
746 (put-text-property start end 'face face) | |
747 )) | |
748 | |
749 | |
750 (defvar data-debug-thing-alist | |
751 '( | |
752 ;; nil | |
753 (null . data-debug-insert-nil) | |
754 | |
755 ;; Overlay | |
756 (data-debug-overlay-p . data-debug-insert-overlay-button) | |
757 | |
758 ;; Overlay list | |
759 ((lambda (thing) (and (consp thing) (data-debug-overlay-p (car thing)))) . | |
760 data-debug-insert-overlay-list-button) | |
761 | |
762 ;; Buffer | |
763 (bufferp . data-debug-insert-buffer-button) | |
764 | |
765 ;; Buffer list | |
766 ((lambda (thing) (and (consp thing) (bufferp (car thing)))) . | |
767 data-debug-insert-buffer-list-button) | |
768 | |
769 ;; Process | |
770 (processp . data-debug-insert-process-button) | |
771 | |
772 ;; String | |
773 (stringp . data-debug-insert-string) | |
774 | |
775 ;; Number | |
776 (numberp . data-debug-insert-number) | |
777 | |
778 ;; Symbol | |
779 (symbolp . data-debug-insert-symbol-button) | |
780 | |
781 ;; Ring | |
782 (ring-p . data-debug-insert-ring-button) | |
783 | |
784 ;; Lambda Expression | |
785 ((lambda (thing) (and (consp thing) (eq (car thing) 'lambda))) . | |
786 data-debug-insert-lambda-expression) | |
787 | |
788 ;; Hash-table | |
789 (hash-table-p . data-debug-insert-hash-table-button) | |
790 | |
791 ;; Widgets | |
792 (widgetp . data-debug-insert-widget) | |
793 | |
794 ;; List of stuff | |
795 (listp . data-debug-insert-stuff-list-button) | |
796 | |
797 ;; Vector of stuff | |
798 (vectorp . data-debug-insert-stuff-vector-button) | |
799 ) | |
800 "Alist of methods used to insert things into an Ddebug buffer.") | |
801 | |
802 ;; An augmentation function for the thing alist. | |
803 (defun data-debug-add-specialized-thing (predicate fcn) | |
804 "Add a new specialized thing to display with data-debug. | |
805 PREDICATE is a function that returns t if a thing is this new type. | |
806 FCN is a function that will display stuff in the data debug buffer." | |
807 (let ((entry (cons predicate fcn)) | |
808 ;; Specialized entries show up AFTER nil, | |
809 ;; but before listp, vectorp, symbolp, and | |
810 ;; other general things. Splice it into | |
811 ;; the beginning. | |
812 (first (nthcdr 0 data-debug-thing-alist)) | |
813 (second (nthcdr 1 data-debug-thing-alist)) | |
814 ) | |
815 (when (not (member entry data-debug-thing-alist)) | |
816 (setcdr first (cons entry second))))) | |
817 | |
818 ;; uber insert method | |
819 (defun data-debug-insert-thing (thing prefix prebuttontext &optional parent) | |
820 "Insert THING with PREFIX. | |
821 PREBUTTONTEXT is some text to insert between prefix and the thing | |
822 that is not included in the indentation calculation of any children. | |
823 If PARENT is non-nil, it is somehow related as a parent to thing." | |
824 (when (catch 'done | |
825 (dolist (test data-debug-thing-alist) | |
826 (when (funcall (car test) thing) | |
827 (condition-case nil | |
828 (funcall (cdr test) thing prefix prebuttontext parent) | |
829 (error | |
830 (funcall (cdr test) thing prefix prebuttontext))) | |
831 (throw 'done nil)) | |
832 ) | |
833 nil) | |
834 (data-debug-insert-simple-thing (format "%S" thing) | |
835 prefix | |
836 prebuttontext | |
837 'bold))) | |
838 | |
839 ;;; MAJOR MODE | |
840 ;; | |
841 ;; The Ddebug major mode provides an interactive space to explore | |
842 ;; complicated data structures. | |
843 ;; | |
844 (defgroup data-debug nil | |
845 "data-debug group." | |
107167
f6b8c73548b3
Minor tweaks to custom groups.
Chong Yidong <cyd@stupidchicken.com>
parents:
106815
diff
changeset
|
846 :group 'extensions) |
105241 | 847 |
848 (defvar data-debug-mode-syntax-table | |
849 (let ((table (make-syntax-table (standard-syntax-table)))) | |
850 (modify-syntax-entry ?\; ". 12" table) ;; SEMI, Comment start ;; | |
851 (modify-syntax-entry ?\n ">" table) ;; Comment end | |
852 (modify-syntax-entry ?\" "\"" table) ;; String | |
853 (modify-syntax-entry ?\- "_" table) ;; Symbol | |
854 (modify-syntax-entry ?\\ "\\" table) ;; Quote | |
855 (modify-syntax-entry ?\` "'" table) ;; Prefix ` (backquote) | |
856 (modify-syntax-entry ?\' "'" table) ;; Prefix ' (quote) | |
857 (modify-syntax-entry ?\, "'" table) ;; Prefix , (comma) | |
858 | |
859 table) | |
860 "Syntax table used in data-debug macro buffers.") | |
861 | |
862 (defvar data-debug-map | |
863 (let ((km (make-sparse-keymap))) | |
864 (define-key km [mouse-2] 'data-debug-expand-or-contract-mouse) | |
865 (define-key km " " 'data-debug-expand-or-contract) | |
866 (define-key km "\C-m" 'data-debug-expand-or-contract) | |
867 (define-key km "n" 'data-debug-next) | |
868 (define-key km "p" 'data-debug-prev) | |
869 (define-key km "N" 'data-debug-next-expando) | |
870 (define-key km "P" 'data-debug-prev-expando) | |
871 km) | |
872 "Keymap used in data-debug.") | |
873 | |
874 (defcustom data-debug-mode-hook nil | |
875 "*Hook run when data-debug starts." | |
876 :group 'data-debug | |
877 :type 'hook) | |
878 | |
879 (defun data-debug-mode () | |
880 "Major-mode for the Analyzer debugger. | |
881 | |
882 \\{data-debug-map}" | |
883 (interactive) | |
884 (kill-all-local-variables) | |
885 (setq major-mode 'data-debug-mode | |
886 mode-name "DATA-DEBUG" | |
887 comment-start ";;" | |
888 comment-end "") | |
889 (set (make-local-variable 'comment-start-skip) | |
890 "\\(\\(^\\|[^\\\\\n]\\)\\(\\\\\\\\\\)*\\);+ *") | |
891 (set-syntax-table data-debug-mode-syntax-table) | |
892 (use-local-map data-debug-map) | |
893 (run-hooks 'data-debug-hook) | |
894 (buffer-disable-undo) | |
895 (set (make-local-variable 'font-lock-global-modes) nil) | |
896 (font-lock-mode -1) | |
897 ) | |
898 | |
899 ;;;###autoload | |
900 (defun data-debug-new-buffer (name) | |
901 "Create a new data-debug buffer with NAME." | |
902 (let ((b (get-buffer-create name))) | |
903 (pop-to-buffer b) | |
904 (set-buffer b) | |
905 (erase-buffer) | |
906 (data-debug-mode) | |
907 b)) | |
908 | |
909 ;;; Ddebug mode commands | |
910 ;; | |
911 (defun data-debug-next () | |
912 "Go to the next line in the Ddebug buffer." | |
913 (interactive) | |
914 (forward-line 1) | |
915 (beginning-of-line) | |
916 (skip-chars-forward " *-><[]" (point-at-eol))) | |
917 | |
918 (defun data-debug-prev () | |
919 "Go to the next line in the Ddebug buffer." | |
920 (interactive) | |
921 (forward-line -1) | |
922 (beginning-of-line) | |
923 (skip-chars-forward " *-><[]" (point-at-eol))) | |
924 | |
925 (defun data-debug-next-expando () | |
926 "Go to the next line in the Ddebug buffer. | |
927 Contract the current line (if open) and expand the line | |
928 we move to." | |
929 (interactive) | |
930 (data-debug-contract-current-line) | |
931 (data-debug-next) | |
932 (data-debug-expand-current-line) | |
933 ) | |
934 | |
935 (defun data-debug-prev-expando () | |
936 "Go to the previous line in the Ddebug buffer. | |
937 Contract the current line (if open) and expand the line | |
938 we move to." | |
939 (interactive) | |
940 (data-debug-contract-current-line) | |
941 (data-debug-prev) | |
942 (data-debug-expand-current-line) | |
943 ) | |
944 | |
945 (defun data-debug-current-line-expanded-p () | |
946 "Return non-nil if the current line is expanded." | |
947 (let ((ti (current-indentation)) | |
948 (ni (condition-case nil | |
949 (save-excursion | |
950 (end-of-line) | |
951 (forward-char 1) | |
952 (current-indentation)) | |
953 (error 0)))) | |
954 (> ni ti))) | |
955 | |
956 (defun data-debug-line-expandable-p () | |
957 "Return non-nil if the current line is expandable. | |
958 Lines that are not expandable are assumed to not be contractable." | |
959 (not (get-text-property (point) 'ddebug-noexpand))) | |
960 | |
961 (defun data-debug-expand-current-line () | |
962 "Expand the current line (if possible). | |
963 Do nothing if already expanded." | |
964 (when (or (not (data-debug-line-expandable-p)) | |
965 (not (data-debug-current-line-expanded-p))) | |
966 ;; If the next line is the same or less indentation, expand. | |
967 (let ((fcn (get-text-property (point) 'ddebug-function))) | |
968 (when fcn | |
969 (funcall fcn (point)) | |
970 (beginning-of-line) | |
971 )))) | |
972 | |
973 (defun data-debug-contract-current-line () | |
974 "Contract the current line (if possible). | |
975 Do nothing if already expanded." | |
976 (when (and (data-debug-current-line-expanded-p) | |
977 ;; Don't contract if the current line is not expandable. | |
978 (get-text-property (point) 'ddebug-function)) | |
979 (let ((ti (current-indentation)) | |
980 ) | |
981 ;; If next indentation is larger, collapse. | |
982 (end-of-line) | |
983 (forward-char 1) | |
984 (let ((start (point)) | |
985 (end nil)) | |
986 (condition-case nil | |
987 (progn | |
988 ;; Keep checking indentation | |
989 (while (or (> (current-indentation) ti) | |
990 (looking-at "^\\s-*$")) | |
991 (end-of-line) | |
992 (forward-char 1)) | |
993 (setq end (point)) | |
994 ) | |
995 (error (setq end (point-max)))) | |
996 (delete-region start end) | |
997 (forward-char -1) | |
998 (beginning-of-line))))) | |
999 | |
1000 (defun data-debug-expand-or-contract () | |
1001 "Expand or contract anything at the current point." | |
1002 (interactive) | |
1003 (if (and (data-debug-line-expandable-p) | |
1004 (data-debug-current-line-expanded-p)) | |
1005 (data-debug-contract-current-line) | |
1006 (data-debug-expand-current-line)) | |
1007 (skip-chars-forward " *-><[]" (point-at-eol))) | |
1008 | |
1009 (defun data-debug-expand-or-contract-mouse (event) | |
1010 "Expand or contract anything at event EVENT." | |
1011 (interactive "e") | |
1012 (let* ((win (car (car (cdr event)))) | |
1013 ) | |
1014 (select-window win t) | |
1015 (save-excursion | |
1016 ;(goto-char (window-start win)) | |
1017 (mouse-set-point event) | |
1018 (data-debug-expand-or-contract)) | |
1019 )) | |
1020 | |
1021 ;;; GENERIC STRUCTURE DUMP | |
1022 ;; | |
1023 (defun data-debug-show-stuff (stuff name) | |
1024 "Data debug STUFF in a buffer named *NAME DDebug*." | |
1025 (data-debug-new-buffer (concat "*" name " DDebug*")) | |
1026 (data-debug-insert-thing stuff "?" "") | |
1027 (goto-char (point-min)) | |
1028 (when (data-debug-line-expandable-p) | |
1029 (data-debug-expand-current-line))) | |
1030 | |
1031 ;;; DEBUG COMMANDS | |
1032 ;; | |
1033 ;; Various commands for displaying complex data structures. | |
1034 | |
1035 (defun data-debug-edebug-expr (expr) | |
105325 | 1036 "Dump out the contents of some expression EXPR in edebug with ddebug." |
105241 | 1037 (interactive |
1038 (list (let ((minibuffer-completing-symbol t)) | |
1039 (read-from-minibuffer "Eval: " | |
1040 nil read-expression-map t | |
1041 'read-expression-history)) | |
1042 )) | |
1043 (let ((v (eval expr))) | |
1044 (if (not v) | |
1045 (message "Expression %s is nil." expr) | |
1046 (data-debug-show-stuff v "expression")))) | |
1047 | |
1048 (defun data-debug-eval-expression (expr) | |
1049 "Evaluate EXPR and display the value. | |
1050 If the result is something simple, show it in the echo area. | |
1051 If the result is a list or vector, then use the data debugger to display it." | |
1052 (interactive | |
1053 (list (let ((minibuffer-completing-symbol t)) | |
1054 (read-from-minibuffer "Eval: " | |
1055 nil read-expression-map t | |
1056 'read-expression-history)) | |
1057 )) | |
1058 | |
1059 (if (null eval-expression-debug-on-error) | |
1060 (setq values (cons (eval expr) values)) | |
1061 (let ((old-value (make-symbol "t")) new-value) | |
1062 ;; Bind debug-on-error to something unique so that we can | |
1063 ;; detect when evaled code changes it. | |
1064 (let ((debug-on-error old-value)) | |
1065 (setq values (cons (eval expr) values)) | |
1066 (setq new-value debug-on-error)) | |
1067 ;; If evaled code has changed the value of debug-on-error, | |
1068 ;; propagate that change to the global binding. | |
1069 (unless (eq old-value new-value) | |
1070 (setq debug-on-error new-value)))) | |
1071 | |
1072 (if (or (consp (car values)) (vectorp (car values))) | |
1073 (let ((v (car values))) | |
1074 (data-debug-show-stuff v "Expression")) | |
1075 ;; Old style | |
1076 (prog1 | |
1077 (prin1 (car values) t) | |
1078 (let ((str (eval-expression-print-format (car values)))) | |
1079 (if str (princ str t)))))) | |
1080 | |
1081 (provide 'data-debug) | |
1082 | |
1083 (if (featurep 'eieio) | |
1084 (require 'eieio-datadebug)) | |
1085 | |
105377 | 1086 ;; arch-tag: 4807227d-08e7-45c4-8ea5-9e4595c3bfb1 |
105241 | 1087 ;;; data-debug.el ends here |