lisp/cedet/data-debug.el

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