* emacs-lisp/eieio-speedbar.el:
* emacs-lisp/eieio.el: New files.
+ * cedet/cedet-cscope.el:
+ * cedet/cedet-files.el:
+ * cedet/cedet-global.el:
+ * cedet/cedet-idutils.el:
+ * cedet/data-debug.el:
+ * cedet/inversion.el:
+ * cedet/pulse.el: New files.
+
2009-09-27 Chong Yidong <cyd@stupidchicken.com>
* menu-bar.el: Remove menu-bar-ediff-misc-menu from the Tools
--- /dev/null
+;;; cedet-cscope.el --- CScope support for CEDET
+
+;;; Copyright (C) 2009 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <zappo@gnu.org>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Support using CScope for symbol lookups.
+
+;;; Code:
+
+(declare-function inversion-check-version "inversion")
+
+(defvar cedet-cscope-min-version "16.0"
+ "Minimum version of CScope required.")
+
+(defcustom cedet-cscope-command "cscope"
+ "Command name for the CScope executable."
+ :type 'string
+ :group 'cedet)
+
+(defun cedet-cscope-search (searchtext texttype type scope)
+ "Perform a search with CScope, return the created buffer.
+SEARCHTEXT is text to find.
+TEXTTYPE is the type of text, such as 'regexp, 'string, 'tagname,
+'tagregexp, or 'tagcompletions.
+TYPE is the type of search, meaning that SEARCHTEXT is compared to
+filename, tagname (tags table), references (uses of a tag) , or
+symbol (uses of something not in the tag table.)
+SCOPE is the scope of the search, such as 'project or 'subdirs."
+ ;; CScope is an interactive program. It uses number flags
+ ;; in order to perform command line searches. Useful for this
+ ;; tool are:
+ ;;
+ ;; -0 = Find C symbol
+ ;; -1 = Find global definition
+ ;; -3 = Find references
+ ;; -6 = Find egrep pattern
+ ;; -7 = Find file
+ (let ((idx (cond ((eq type 'file)
+ "-7")
+ ;; Non files are symbols and such
+ ((eq texttype 'tagname)
+ "-1")
+ ((eq texttype 'tagregexp)
+ "-0")
+ ((eq texttype 'tagcompletions)
+ (setq searchtext (concat "^" searchtext ".*"))
+ "-1")
+ ((eq texttype 'regexp)
+ "-5")
+ (t
+ "-3")
+ )
+ )
+ )
+ (cedet-cscope-call (list "-d" "-L" idx searchtext))))
+
+(defun cedet-cscope-call (flags)
+ "Call CScope with the list of FLAGS."
+ (let ((b (get-buffer-create "*CEDET CScope*"))
+ (cd default-directory)
+ )
+ (save-excursion
+ (set-buffer b)
+ (setq default-directory cd)
+ (erase-buffer))
+ (apply 'call-process cedet-cscope-command
+ nil b nil
+ flags)
+ b))
+
+(defun cedet-cscope-expand-filename (filename)
+ "Expand the FILENAME with CScope.
+Return a fully qualified filename."
+ (interactive "sFile: ")
+ (let* ((ans1 (save-excursion
+ (set-buffer (cedet-cscope-call (list "-d" "-L" "-7" filename)))
+ (goto-char (point-min))
+ (if (looking-at "[^ \n]*cscope: ")
+ (error "CScope not available")
+ (split-string (buffer-string) "\n" t))))
+ (ans2 (mapcar (lambda (hit)
+ (expand-file-name (car (split-string hit " "))))
+ ans1)))
+ (when (interactive-p)
+ (if ans2
+ (if (= (length ans2) 1)
+ (message "%s" (car ans2))
+ (message "%s + %d others" (car ans2)
+ (length (cdr ans2))))
+ (error "No file found")))
+ ans2))
+
+(defun cedet-cscope-support-for-directory (&optional dir)
+ "Return non-nil if CScope has a support file for DIR.
+If DIR is not supplied, use the current default directory.
+This works by running cscope on a bogus symbol, and looking for
+the error code."
+ (save-excursion
+ (let ((default-directory (or dir default-directory)))
+ (set-buffer (cedet-cscope-call (list "-d" "-L" "-7" "moose")))
+ (goto-char (point-min))
+ (if (looking-at "[^ \n]*cscope: ")
+ nil
+ t))))
+
+(defun cedet-cscope-version-check (&optional noerror)
+ "Check the version of the installed CScope command.
+If optional programatic argument NOERROR is non-nil, then
+instead of throwing an error if CScope isn't available, then
+return nil."
+ (interactive)
+ (require 'inversion)
+ (let ((b (condition-case nil
+ (cedet-cscope-call (list "-V"))
+ (error nil)))
+ (rev nil))
+ (if (not b)
+ (progn
+ (when (interactive-p)
+ (message "CScope not found."))
+ nil)
+ (save-excursion
+ (set-buffer b)
+ (goto-char (point-min))
+ (re-search-forward "cscope: version \\([0-9.]+\\)" nil t)
+ (setq rev (match-string 1))
+ (if (inversion-check-version rev nil cedet-cscope-min-version)
+ (if noerror
+ nil
+ (error "Version of CScope is %s. Need at least %s"
+ rev cedet-cscope-min-version))
+ ;; Else, return TRUE, as in good enough.
+ (when (interactive-p)
+ (message "CScope %s - Good enough for CEDET." rev))
+ t)))))
+
+(provide 'cedet-cscope)
+
+;;; cedet-cscope.el ends here
--- /dev/null
+;;; cedet-files.el --- Common routines dealing with file names.
+
+;;; Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <eric@siege-engine.com>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Various useful routines for dealing with file names in the tools
+;; which are a part of CEDET.
+
+;;; Code:
+
+(defun cedet-directory-name-to-file-name (referencedir &optional testmode)
+ "Convert the REFERENCEDIR (a full path name) into a filename.
+Convert directory seperation characters into ! characters.
+Optional argument TESTMODE is used by tests to avoid conversion
+to the file's truename, and dodging platform tricks."
+ (let ((file referencedir))
+ ;; Expand to full file name
+ (when (not testmode)
+ (setq file (file-truename file)))
+ ;; If FILE is a directory, then force it to end in /.
+ (when (file-directory-p file)
+ (setq file (file-name-as-directory file)))
+ ;; Handle Windows Special cases
+ (when (or (memq system-type '(windows-nt ms-dos)) testmode)
+ ;; Replace any invalid file-name characters (for the
+ ;; case of backing up remote files).
+ (when (not testmode)
+ (setq file (expand-file-name (convert-standard-filename file))))
+ ;; Normalize DOSish file names.
+ (if (eq (aref file 1) ?:)
+ (setq file (concat "/"
+ "drive_"
+ (char-to-string (downcase (aref file 0)))
+ (if (eq (aref file 2) ?/)
+ ""
+ "/")
+ (substring file 2)))))
+ ;; Make the name unique by substituting directory
+ ;; separators. It may not really be worth bothering about
+ ;; doubling `!'s in the original name...
+ (setq file (subst-char-in-string
+ ?/ ?!
+ (replace-regexp-in-string "!" "!!" file)))
+ file))
+
+(defun cedet-file-name-to-directory-name (referencefile &optional testmode)
+ "Reverse the process of `cedet-directory-name-to-file-name'.
+Convert REFERENCEFILE to a directory name replacing ! with /.
+Optional TESTMODE is used in tests to avoid doing some platform
+specific conversions during tests."
+ (let ((file referencefile))
+ ;; Replace the ! with /
+ (setq file (subst-char-in-string ?! ?/ file))
+ ;; Occurances of // meant there was once a single !.
+ (setq file (replace-regexp-in-string "//" "!" file))
+
+ ;; Handle Windows special cases
+ (when (or (memq system-type '(windows-nt ms-dos)) testmode)
+
+ ;; Handle drive letters from DOSish file names.
+ (when (string-match "^/drive_\\([a-z]\\)/" file)
+ (let ((driveletter (match-string 1 file))
+ )
+ (setq file (concat driveletter ":"
+ (substring file (match-end 1))))))
+
+ ;; Handle the \\file\name nomenclature on some windows boxes.
+ (when (string-match "^!" file)
+ (setq file (concat "//" (substring file 1)))))
+ file))
+
+(provide 'cedet-files)
+
+;;; cedet-files.el ends here
--- /dev/null
+;;; cedet-global.el --- GNU Global support for CEDET.
+
+;; Copyright (C) 2008, 2009 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <eric@siege-engine.com>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Basic support for calling GNU Global, and testing version numbers.
+
+(declare-function inversion-check-version "inversion")
+
+(defvar cedet-global-min-version "5.0"
+ "Minimum version of GNU global required.")
+
+(defcustom cedet-global-command "global"
+ "Command name for the GNU Global executable."
+ :type 'string
+ :group 'cedet)
+
+;;; Code:
+(defun cedet-gnu-global-search (searchtext texttype type scope)
+ "Perform a search with GNU Global, return the created buffer.
+SEARCHTEXT is text to find.
+TEXTTYPE is the type of text, such as 'regexp, 'string, 'tagname,
+'tagregexp, or 'tagcompletions.
+TYPE is the type of search, meaning that SEARCHTEXT is compared to
+filename, tagname (tags table), references (uses of a tag) , or
+symbol (uses of something not in the tag table.)
+SCOPE is the scope of the search, such as 'project or 'subdirs."
+ (let ((flgs (cond ((eq type 'file)
+ "-a")
+ (t "-xa")))
+ (scopeflgs (cond
+ ((eq scope 'project)
+ ""
+ )
+ ((eq scope 'target)
+ "l")))
+ (stflag (cond ((or (eq texttype 'tagname)
+ (eq texttype 'tagregexp))
+ "")
+ ((eq texttype 'tagcompletions)
+ "c")
+ ((eq texttype 'regexp)
+ "g")
+ (t "r"))))
+ (cedet-gnu-global-call (list (concat flgs scopeflgs stflag)
+ searchtext))))
+
+(defun cedet-gnu-global-call (flags)
+ "Call GNU Global with the list of FLAGS."
+ (let ((b (get-buffer-create "*CEDET Global*"))
+ (cd default-directory))
+ (save-excursion
+ (set-buffer b)
+ (setq default-directory cd)
+ (erase-buffer))
+ (apply 'call-process cedet-global-command
+ nil b nil
+ flags)
+ b))
+
+(defun cedet-gnu-global-expand-filename (filename)
+ "Expand the FILENAME with GNU Global.
+Return a fully qualified filename."
+ (interactive "sFile: ")
+ (let ((ans (save-excursion
+ (set-buffer (cedet-gnu-global-call (list "-Pa" filename)))
+ (goto-char (point-min))
+ (if (looking-at "global: ")
+ (error "GNU Global not available")
+ (split-string (buffer-string) "\n" t)))))
+ (when (interactive-p)
+ (if ans
+ (if (= (length ans) 1)
+ (message "%s" (car ans))
+ (message "%s + %d others" (car ans)
+ (length (cdr ans))))
+ (error "No file found")))
+ ans))
+
+(defun cedet-gnu-global-show-root ()
+ "Show the root of a GNU Global area under the current buffer."
+ (interactive)
+ (message "%s" (cedet-gnu-global-root)))
+
+(defun cedet-gnu-global-root (&optional dir)
+ "Return the root of any GNU Global scanned project.
+If a default starting DIR is not specified, the current buffer's
+`default-directory' is used."
+ (let ((default-directory (or dir default-directory)))
+ (save-excursion
+ (set-buffer (cedet-gnu-global-call (list "-pq")))
+ (goto-char (point-min))
+ (when (not (eobp))
+ (file-name-as-directory
+ (buffer-substring (point) (point-at-eol)))))))
+
+(defun cedet-gnu-global-version-check (&optional noerror)
+ "Check the version of the installed GNU Global command.
+If optional programatic argument NOERROR is non-nil, then
+instead of throwing an error if Global isn't available, then
+return nil."
+ (interactive)
+ (require 'inversion)
+ (let ((b (condition-case nil
+ (cedet-gnu-global-call (list "--version"))
+ (error nil)))
+ (rev nil))
+ (if (not b)
+ (progn
+ (when (interactive-p)
+ (message "GNU Global not found."))
+ nil)
+ (save-excursion
+ (set-buffer b)
+ (goto-char (point-min))
+ (re-search-forward "GNU GLOBAL \\([0-9.]+\\)" nil t)
+ (setq rev (match-string 1))
+ (if (inversion-check-version rev nil cedet-global-min-version)
+ (if noerror
+ nil
+ (error "Version of GNU Global is %s. Need at least %s"
+ rev cedet-global-min-version))
+ ;; Else, return TRUE, as in good enough.
+ (when (interactive-p)
+ (message "GNU Global %s - Good enough for CEDET." rev))
+ t)))))
+
+(defun cedet-gnu-global-scan-hits (buffer)
+ "Scan all the hits from the GNU Global output BUFFER."
+ (let ((hits nil)
+ (r1 "^\\([^ ]+\\) +\\([0-9]+\\) \\([^ ]+\\) "))
+ (save-excursion
+ (set-buffer buffer)
+ (goto-char (point-min))
+ (while (re-search-forward r1 nil t)
+ (setq hits (cons (cons (string-to-number (match-string 2))
+ (match-string 3))
+ hits)))
+ ;; Return the results
+ (nreverse hits))))
+
+(provide 'cedet-global)
+
+;;; cedet-global.el ends here
--- /dev/null
+;;; cedet-idutils.el --- ID Utils support for CEDET.
+
+;;; Copyright (C) 2009 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <eric@siege-engine.com>
+;; Version: 0.2
+;; Keywords: OO, lisp
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Basic support calling ID Utils functions, and checking version
+;; numbers.
+
+;;; Code:
+
+(declare-function inversion-check-version "inversion")
+
+(defvar cedet-idutils-min-version "4.0"
+ "Minimum version of ID Utils required.")
+
+(defcustom cedet-idutils-file-command "fnid"
+ "Command name for the ID Utils executable for searching file names."
+ :type 'string
+ :group 'cedet)
+
+(defcustom cedet-idutils-token-command "lid"
+ "Command name for the ID Utils executable for searching for tokens."
+ :type 'string
+ :group 'cedet)
+
+(defun cedet-idutils-search (searchtext texttype type scope)
+ "Perform a search with IDUtils, return the created buffer.
+SEARCHTEXT is text to find.
+TEXTTYPE is the type of text, such as 'regexp, 'string, 'tagname,
+'tagregexp, or 'tagcompletions.
+TYPE is the type of search, meaning that SEARCHTEXT is compared to
+filename, tagname (tags table), references (uses of a tag) , or
+symbol (uses of something not in the tag table.)
+SCOPE is the scope of the search, such as 'project or 'subdirs.
+Note: Scope is not yet supported."
+ (if (eq type 'file)
+ ;; Calls for file stuff is very simple.
+ (cedet-idutils-fnid-call (list searchtext))
+ ;; Calls for text searches is more complex.
+ (let* ((resultflg (if (eq texttype 'tagcompletions)
+ (list "--key=token")
+ (list "--result=grep")))
+ (scopeflgs nil) ; (cond ((eq scope 'project) "" ) ((eq scope 'target) "l")))
+ (stflag (cond ((or (eq texttype 'tagname)
+ (eq texttype 'tagregexp))
+ (list "-r" "-w"))
+ ((eq texttype 'tagcompletions)
+ ;; Add regex to search text for beginning of char.
+ (setq searchtext (concat "^" searchtext))
+ (list "-r" "-s" ))
+ ((eq texttype 'regexp)
+ (list "-r"))
+ ;; t means 'symbol
+ (t (list "-l" "-w"))))
+ )
+ (cedet-idutils-lid-call (append resultflg scopeflgs stflag
+ (list searchtext))))))
+
+(defun cedet-idutils-fnid-call (flags)
+ "Call ID Utils fnid with the list of FLAGS.
+Return the created buffer with with program output."
+ (let ((b (get-buffer-create "*CEDET fnid*"))
+ (cd default-directory)
+ )
+ (save-excursion
+ (set-buffer b)
+ (setq default-directory cd)
+ (erase-buffer))
+ (apply 'call-process cedet-idutils-file-command
+ nil b nil
+ flags)
+ b))
+
+(defun cedet-idutils-lid-call (flags)
+ "Call ID Utils lid with the list of FLAGS.
+Return the created buffer with with program output."
+ (let ((b (get-buffer-create "*CEDET lid*"))
+ (cd default-directory)
+ )
+ (save-excursion
+ (set-buffer b)
+ (setq default-directory cd)
+ (erase-buffer))
+ (apply 'call-process cedet-idutils-token-command
+ nil b nil
+ flags)
+ b))
+
+;;; UTIL CALLS
+;;
+(defun cedet-idutils-expand-filename (filename)
+ "Expand the FILENAME with IDUtils.
+Return a filename relative to the default directory."
+ (interactive "sFile: ")
+ (let ((ans (save-excursion
+ (set-buffer (cedet-idutils-fnid-call (list filename)))
+ (goto-char (point-min))
+ (if (looking-at "[^ \n]*fnid: ")
+ (error "ID Utils not available")
+ (split-string (buffer-string) "\n" t)))))
+ (setq ans (mapcar 'expand-file-name ans))
+ (when (interactive-p)
+ (if ans
+ (if (= (length ans) 1)
+ (message "%s" (car ans))
+ (message "%s + %d others" (car ans)
+ (length (cdr ans))))
+ (error "No file found")))
+ ans))
+
+(defun cedet-idutils-support-for-directory (&optional dir)
+ "Return non-nil if IDUtils has a support file for DIR.
+If DIR is not supplied, use the current default directory.
+This works by running lid on a bogus symbol, and looking for
+the error code."
+ (save-excursion
+ (let ((default-directory (or dir default-directory)))
+ (condition-case nil
+ (progn
+ (set-buffer (cedet-idutils-fnid-call '("moose")))
+ (goto-char (point-min))
+ (if (looking-at "[^ \n]*fnid: ")
+ nil
+ t))
+ (error nil)))))
+
+(defun cedet-idutils-version-check (&optional noerror)
+ "Check the version of the installed ID Utils command.
+If optional programatic argument NOERROR is non-nil, then
+instead of throwing an error if Global isn't available, then
+return nil."
+ (interactive)
+ (require 'inversion)
+ (let ((b (condition-case nil
+ (cedet-idutils-fnid-call (list "--version"))
+ (error nil)))
+ (rev nil))
+ (if (not b)
+ (progn
+ (when (interactive-p)
+ (message "ID Utils not found."))
+ nil)
+ (save-excursion
+ (set-buffer b)
+ (goto-char (point-min))
+ (re-search-forward "fnid - \\([0-9.]+\\)" nil t)
+ (setq rev (match-string 1))
+ (if (inversion-check-version rev nil cedet-idutils-min-version)
+ (if noerror
+ nil
+ (error "Version of ID Utis is %s. Need at least %s"
+ rev cedet-idutils-min-version))
+ ;; Else, return TRUE, as in good enough.
+ (when (interactive-p)
+ (message "ID Utils %s - Good enough for CEDET." rev))
+ t)))))
+
+
+(provide 'cedet-idutils)
+
+;;; cedet-idutils.el ends here
--- /dev/null
+;;; data-debug.el --- Datastructure Debugger
+
+;; Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <zappo@gnu.org>
+;; Version: 0.2
+;; Keywords: OO, lisp
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Provide a simple way to investigate particularly large and complex
+;; data structures.
+;;
+;; The best way to get started is to bind M-: to 'data-debug-eval-expression.
+;;
+;; (global-set-key "\M-:" 'data-debug-eval-expression)
+;;
+;; If you write functions with complex output that need debugging, you
+;; can make them interactive with data-debug-show-stuff. For example:
+;;
+;; (defun my-complex-output-fcn ()
+;; "Calculate something complicated at point, and return it."
+;; (interactive) ;; function not normally interactive
+;; (let ((stuff (do-stuff)))
+;; (when (interactive-p)
+;; (data-debug-show-stuff stuff "myStuff"))
+;; stuff))
+
+(require 'font-lock)
+(require 'ring)
+
+;;; Code:
+
+;;; Compatibility
+;;
+(if (featurep 'xemacs)
+ (eval-and-compile
+ (defalias 'data-debug-overlay-properties 'extent-properties)
+ (defalias 'data-debug-overlay-p 'extentp)
+ (if (not (fboundp 'propertize))
+ (defun dd-propertize (string &rest properties)
+ "Mimic 'propertize' in from Emacs 23."
+ (add-text-properties 0 (length string) properties string)
+ string
+ )
+ (defalias 'dd-propertize 'propertize))
+ )
+ ;; Regular Emacs
+ (eval-and-compile
+ (defalias 'data-debug-overlay-properties 'overlay-properties)
+ (defalias 'data-debug-overlay-p 'overlayp)
+ (defalias 'dd-propertize 'propertize)
+ )
+ )
+
+;;; GENERIC STUFF
+;;
+(defun data-debug-insert-property-list (proplist prefix &optional parent)
+ "Insert the property list PROPLIST.
+Each line starts with PREFIX.
+The attributes belong to the tag PARENT."
+ (while proplist
+ (let ((pretext (concat (symbol-name (car proplist)) " : ")))
+ (data-debug-insert-thing (car (cdr proplist))
+ prefix
+ pretext
+ parent))
+ (setq proplist (cdr (cdr proplist)))))
+
+;;; overlays
+;;
+(defun data-debug-insert-overlay-props (overlay prefix)
+ "Insert all the parts of OVERLAY.
+PREFIX specifies what to insert at the start of each line."
+ (let ((attrprefix (concat (make-string (length prefix) ? ) "# "))
+ (proplist (data-debug-overlay-properties overlay)))
+ (data-debug-insert-property-list
+ proplist attrprefix)
+ )
+ )
+
+(defun data-debug-insert-overlay-from-point (point)
+ "Insert the overlay found at the overlay button at POINT."
+ (let ((overlay (get-text-property point 'ddebug))
+ (indent (get-text-property point 'ddebug-indent))
+ start
+ )
+ (end-of-line)
+ (setq start (point))
+ (forward-char 1)
+ (data-debug-insert-overlay-props overlay
+ (concat (make-string indent ? )
+ "| "))
+ (goto-char start)
+ ))
+
+(defun data-debug-insert-overlay-button (overlay prefix prebuttontext)
+ "Insert a button representing OVERLAY.
+PREFIX is the text that preceeds the button.
+PREBUTTONTEXT is some text between prefix and the overlay button."
+ (let ((start (point))
+ (end nil)
+ (str (format "%s" overlay))
+ (tip nil))
+ (insert prefix prebuttontext str)
+ (setq end (point))
+ (put-text-property (- end (length str)) end 'face 'font-lock-comment-face)
+ (put-text-property start end 'ddebug overlay)
+ (put-text-property start end 'ddebug-indent(length prefix))
+ (put-text-property start end 'ddebug-prefix prefix)
+ (put-text-property start end 'help-echo tip)
+ (put-text-property start end 'ddebug-function
+ 'data-debug-insert-overlay-from-point)
+ (insert "\n")
+ )
+ )
+
+;;; overlay list
+;;
+(defun data-debug-insert-overlay-list (overlaylist prefix)
+ "Insert all the parts of OVERLAYLIST.
+PREFIX specifies what to insert at the start of each line."
+ (while overlaylist
+ (data-debug-insert-overlay-button (car overlaylist)
+ prefix
+ "")
+ (setq overlaylist (cdr overlaylist))))
+
+(defun data-debug-insert-overlay-list-from-point (point)
+ "Insert the overlay found at the overlay list button at POINT."
+ (let ((overlaylist (get-text-property point 'ddebug))
+ (indent (get-text-property point 'ddebug-indent))
+ start
+ )
+ (end-of-line)
+ (setq start (point))
+ (forward-char 1)
+ (data-debug-insert-overlay-list overlaylist
+ (concat (make-string indent ? )
+ "* "))
+ (goto-char start)
+ ))
+
+(defun data-debug-insert-overlay-list-button (overlaylist
+ prefix
+ prebuttontext)
+ "Insert a button representing OVERLAYLIST.
+PREFIX is the text that preceeds the button.
+PREBUTTONTEXT is some text between prefix and the overlay list button."
+ (let ((start (point))
+ (end nil)
+ (str (format "#<overlay list: %d entries>" (length overlaylist)))
+ (tip nil))
+ (insert prefix prebuttontext str)
+ (setq end (point))
+ (put-text-property (- end (length str)) end 'face 'font-lock-comment-face)
+ (put-text-property start end 'ddebug overlaylist)
+ (put-text-property start end 'ddebug-indent(length prefix))
+ (put-text-property start end 'ddebug-prefix prefix)
+ (put-text-property start end 'help-echo tip)
+ (put-text-property start end 'ddebug-function
+ 'data-debug-insert-overlay-list-from-point)
+ (insert "\n")
+ )
+ )
+
+;;; buffers
+;;
+(defun data-debug-insert-buffer-props (buffer prefix)
+ "Insert all the parts of BUFFER.
+PREFIX specifies what to insert at the start of each line."
+ (let ((attrprefix (concat (make-string (length prefix) ? ) "# "))
+ (proplist
+ (list :filename (buffer-file-name buffer)
+ :live (buffer-live-p buffer)
+ :modified (buffer-modified-p buffer)
+ :size (buffer-size buffer)
+ :process (get-buffer-process buffer)
+ :localvars (buffer-local-variables buffer)
+ )))
+ (data-debug-insert-property-list
+ proplist attrprefix)
+ )
+ )
+
+(defun data-debug-insert-buffer-from-point (point)
+ "Insert the buffer found at the buffer button at POINT."
+ (let ((buffer (get-text-property point 'ddebug))
+ (indent (get-text-property point 'ddebug-indent))
+ start
+ )
+ (end-of-line)
+ (setq start (point))
+ (forward-char 1)
+ (data-debug-insert-buffer-props buffer
+ (concat (make-string indent ? )
+ "| "))
+ (goto-char start)
+ ))
+
+(defun data-debug-insert-buffer-button (buffer prefix prebuttontext)
+ "Insert a button representing BUFFER.
+PREFIX is the text that preceeds the button.
+PREBUTTONTEXT is some text between prefix and the buffer button."
+ (let ((start (point))
+ (end nil)
+ (str (format "%S" buffer))
+ (tip nil))
+ (insert prefix prebuttontext str)
+ (setq end (point))
+ (put-text-property (- end (length str)) end 'face 'font-lock-comment-face)
+ (put-text-property start end 'ddebug buffer)
+ (put-text-property start end 'ddebug-indent(length prefix))
+ (put-text-property start end 'ddebug-prefix prefix)
+ (put-text-property start end 'help-echo tip)
+ (put-text-property start end 'ddebug-function
+ 'data-debug-insert-buffer-from-point)
+ (insert "\n")
+ )
+ )
+
+;;; buffer list
+;;
+(defun data-debug-insert-buffer-list (bufferlist prefix)
+ "Insert all the parts of BUFFERLIST.
+PREFIX specifies what to insert at the start of each line."
+ (while bufferlist
+ (data-debug-insert-buffer-button (car bufferlist)
+ prefix
+ "")
+ (setq bufferlist (cdr bufferlist))))
+
+(defun data-debug-insert-buffer-list-from-point (point)
+ "Insert the buffer found at the buffer list button at POINT."
+ (let ((bufferlist (get-text-property point 'ddebug))
+ (indent (get-text-property point 'ddebug-indent))
+ start
+ )
+ (end-of-line)
+ (setq start (point))
+ (forward-char 1)
+ (data-debug-insert-buffer-list bufferlist
+ (concat (make-string indent ? )
+ "* "))
+ (goto-char start)
+ ))
+
+(defun data-debug-insert-buffer-list-button (bufferlist
+ prefix
+ prebuttontext)
+ "Insert a button representing BUFFERLIST.
+PREFIX is the text that preceeds the button.
+PREBUTTONTEXT is some text between prefix and the buffer list button."
+ (let ((start (point))
+ (end nil)
+ (str (format "#<buffer list: %d entries>" (length bufferlist)))
+ (tip nil))
+ (insert prefix prebuttontext str)
+ (setq end (point))
+ (put-text-property (- end (length str)) end 'face 'font-lock-comment-face)
+ (put-text-property start end 'ddebug bufferlist)
+ (put-text-property start end 'ddebug-indent(length prefix))
+ (put-text-property start end 'ddebug-prefix prefix)
+ (put-text-property start end 'help-echo tip)
+ (put-text-property start end 'ddebug-function
+ 'data-debug-insert-buffer-list-from-point)
+ (insert "\n")
+ )
+ )
+
+;;; processes
+;;
+(defun data-debug-insert-process-props (process prefix)
+ "Insert all the parts of PROCESS.
+PREFIX specifies what to insert at the start of each line."
+ (let ((attrprefix (concat (make-string (length prefix) ? ) "# "))
+ (id (process-id process))
+ (tty (process-tty-name process))
+ (pcontact (process-contact process t))
+ (proplist (process-plist process)))
+ (data-debug-insert-property-list
+ (append
+ (if id (list 'id id))
+ (if tty (list 'tty tty))
+ (if pcontact pcontact)
+ proplist)
+ attrprefix)
+ )
+ )
+
+(defun data-debug-insert-process-from-point (point)
+ "Insert the process found at the process button at POINT."
+ (let ((process (get-text-property point 'ddebug))
+ (indent (get-text-property point 'ddebug-indent))
+ start
+ )
+ (end-of-line)
+ (setq start (point))
+ (forward-char 1)
+ (data-debug-insert-process-props process
+ (concat (make-string indent ? )
+ "| "))
+ (goto-char start)
+ ))
+
+(defun data-debug-insert-process-button (process prefix prebuttontext)
+ "Insert a button representing PROCESS.
+PREFIX is the text that preceeds the button.
+PREBUTTONTEXT is some text between prefix and the process button."
+ (let ((start (point))
+ (end nil)
+ (str (format "%S : %s" process (process-status process)))
+ (tip nil))
+ (insert prefix prebuttontext str)
+ (setq end (point))
+ (put-text-property (- end (length str)) end 'face 'font-lock-comment-face)
+ (put-text-property start end 'ddebug process)
+ (put-text-property start end 'ddebug-indent(length prefix))
+ (put-text-property start end 'ddebug-prefix prefix)
+ (put-text-property start end 'help-echo tip)
+ (put-text-property start end 'ddebug-function
+ 'data-debug-insert-process-from-point)
+ (insert "\n")
+ )
+ )
+
+;;; Rings
+;;
+;; A ring (like kill-ring, or whatever.)
+(defun data-debug-insert-ring-contents (ring prefix)
+ "Insert all the parts of RING.
+PREFIX specifies what to insert at the start of each line."
+ (let ((len (ring-length ring))
+ (idx 0)
+ )
+ (while (< idx len)
+ (data-debug-insert-thing (ring-ref ring idx) prefix "")
+ (setq idx (1+ idx))
+ )))
+
+(defun data-debug-insert-ring-items-from-point (point)
+ "Insert the ring found at the ring button at POINT."
+ (let ((ring (get-text-property point 'ddebug))
+ (indent (get-text-property point 'ddebug-indent))
+ start
+ )
+ (end-of-line)
+ (setq start (point))
+ (forward-char 1)
+ (data-debug-insert-ring-contents ring
+ (concat (make-string indent ? )
+ "} "))
+ (goto-char start)
+ ))
+
+(defun data-debug-insert-ring-button (ring
+ prefix
+ prebuttontext)
+ "Insert a button representing RING.
+PREFIX is the text that preceeds the button.
+PREBUTTONTEXT is some text between prefix and the stuff list button."
+ (let* ((start (point))
+ (end nil)
+ (str (format "#<RING: %d, %d max>"
+ (ring-length ring)
+ (ring-size ring)))
+ (ringthing
+ (if (= (ring-length ring) 0) nil (ring-ref ring 0)))
+ (tip (format "Ring max-size %d, length %d."
+ (ring-size ring)
+ (ring-length ring)))
+ )
+ (insert prefix prebuttontext str)
+ (setq end (point))
+ (put-text-property (- end (length str)) end 'face 'font-lock-type-face)
+ (put-text-property start end 'ddebug ring)
+ (put-text-property start end 'ddebug-indent(length prefix))
+ (put-text-property start end 'ddebug-prefix prefix)
+ (put-text-property start end 'help-echo tip)
+ (put-text-property start end 'ddebug-function
+ 'data-debug-insert-ring-items-from-point)
+ (insert "\n")
+ )
+ )
+
+\f
+;;; Hash-table
+;;
+
+(defun data-debug-insert-hash-table (hash-table prefix)
+ "Insert the contents of HASH-TABLE inserting PREFIX before each element."
+ (maphash
+ (lambda (key value)
+ (data-debug-insert-thing
+ key prefix
+ (dd-propertize "key " 'face font-lock-comment-face))
+ (data-debug-insert-thing
+ value prefix
+ (dd-propertize "val " 'face font-lock-comment-face)))
+ hash-table))
+
+(defun data-debug-insert-hash-table-from-point (point)
+ "Insert the contents of the hash-table button at POINT."
+ (let ((hash-table (get-text-property point 'ddebug))
+ (indent (get-text-property point 'ddebug-indent))
+ start)
+ (end-of-line)
+ (setq start (point))
+ (forward-char 1)
+ (data-debug-insert-hash-table
+ hash-table
+ (concat (make-string indent ? ) "> "))
+ (goto-char start))
+ )
+
+(defun data-debug-insert-hash-table-button (hash-table prefix prebuttontext)
+ "Insert HASH-TABLE as expandable button with recursive prefix PREFIX and PREBUTTONTEXT in front of the button text."
+ (let ((string (dd-propertize (format "%s" hash-table)
+ 'face 'font-lock-keyword-face)))
+ (insert (dd-propertize
+ (concat prefix prebuttontext string)
+ 'ddebug hash-table
+ 'ddebug-indent (length prefix)
+ 'ddebug-prefix prefix
+ 'help-echo
+ (format "Hash-table\nTest: %s\nWeakness: %s\nElements: %d (of %d)"
+ (hash-table-test hash-table)
+ (if (hash-table-weakness hash-table) "yes" "no")
+ (hash-table-count hash-table)
+ (hash-table-size hash-table))
+ 'ddebug-function
+ 'data-debug-insert-hash-table-from-point)
+ "\n"))
+ )
+
+;;; Widget
+;;
+;; Widgets have a long list of properties
+(defun data-debug-insert-widget-properties (widget prefix)
+ "Insert the contents of WIDGET inserting PREFIX before each element."
+ (let ((type (car widget))
+ (rest (cdr widget)))
+ (while rest
+ (data-debug-insert-thing (car (cdr rest))
+ prefix
+ (concat
+ (dd-propertize (format "%s" (car rest))
+ 'face font-lock-comment-face)
+ " : "))
+ (setq rest (cdr (cdr rest))))
+ ))
+
+(defun data-debug-insert-widget-from-point (point)
+ "Insert the contents of the widget button at POINT."
+ (let ((widget (get-text-property point 'ddebug))
+ (indent (get-text-property point 'ddebug-indent))
+ start)
+ (end-of-line)
+ (setq start (point))
+ (forward-char 1)
+ (data-debug-insert-widget-properties
+ widget (concat (make-string indent ? ) "# "))
+ (goto-char start))
+ )
+
+(defun data-debug-insert-widget (widget prefix prebuttontext)
+ "Insert one WIDGET.
+A Symbol is a simple thing, but this provides some face and prefix rules.
+PREFIX is the text that preceeds the button.
+PREBUTTONTEXT is some text between prefix and the thing."
+ (let ((string (dd-propertize (format "#<WIDGET %s>" (car widget))
+ 'face 'font-lock-keyword-face)))
+ (insert (dd-propertize
+ (concat prefix prebuttontext string)
+ 'ddebug widget
+ 'ddebug-indent (length prefix)
+ 'ddebug-prefix prefix
+ 'help-echo
+ (format "Widget\nType: %s\n# Properties: %d"
+ (car widget)
+ (/ (1- (length widget)) 2))
+ 'ddebug-function
+ 'data-debug-insert-widget-from-point)
+ "\n")))
+
+;;; list of stuff
+;;
+;; just a list. random stuff inside.
+(defun data-debug-insert-stuff-list (stufflist prefix)
+ "Insert all the parts of STUFFLIST.
+PREFIX specifies what to insert at the start of each line."
+ (while stufflist
+ (data-debug-insert-thing
+ ;; Some lists may put a value in the CDR
+ (if (listp stufflist) (car stufflist) stufflist)
+ prefix
+ "")
+ (setq stufflist
+ (if (listp stufflist)
+ (cdr-safe stufflist)
+ nil))))
+
+(defun data-debug-insert-stuff-list-from-point (point)
+ "Insert the stuff found at the stuff list button at POINT."
+ (let ((stufflist (get-text-property point 'ddebug))
+ (indent (get-text-property point 'ddebug-indent))
+ start
+ )
+ (end-of-line)
+ (setq start (point))
+ (forward-char 1)
+ (data-debug-insert-stuff-list stufflist
+ (concat (make-string indent ? )
+ "> "))
+ (goto-char start)
+ ))
+
+(defun data-debug-insert-stuff-list-button (stufflist
+ prefix
+ prebuttontext)
+ "Insert a button representing STUFFLIST.
+PREFIX is the text that preceeds the button.
+PREBUTTONTEXT is some text between prefix and the stuff list button."
+ (let ((start (point))
+ (end nil)
+ (str
+ (condition-case nil
+ (format "#<list o' stuff: %d entries>" (safe-length stufflist))
+ (error "#<list o' stuff>")))
+ (tip (if (or (listp (car stufflist))
+ (vectorp (car stufflist)))
+ ""
+ (format "%s" stufflist))))
+ (insert prefix prebuttontext str)
+ (setq end (point))
+ (put-text-property (- end (length str)) end 'face 'font-lock-variable-name-face)
+ (put-text-property start end 'ddebug stufflist)
+ (put-text-property start end 'ddebug-indent (length prefix))
+ (put-text-property start end 'ddebug-prefix prefix)
+ (put-text-property start end 'help-echo tip)
+ (put-text-property start end 'ddebug-function
+ 'data-debug-insert-stuff-list-from-point)
+ (insert "\n")
+ )
+ )
+
+;;; vector of stuff
+;;
+;; just a vector. random stuff inside.
+(defun data-debug-insert-stuff-vector (stuffvector prefix)
+ "Insert all the parts of STUFFVECTOR.
+PREFIX specifies what to insert at the start of each line."
+ (let ((idx 0))
+ (while (< idx (length stuffvector))
+ (data-debug-insert-thing
+ ;; Some vectors may put a value in the CDR
+ (aref stuffvector idx)
+ prefix
+ "")
+ (setq idx (1+ idx)))))
+
+(defun data-debug-insert-stuff-vector-from-point (point)
+ "Insert the stuff found at the stuff vector button at POINT."
+ (let ((stuffvector (get-text-property point 'ddebug))
+ (indent (get-text-property point 'ddebug-indent))
+ start
+ )
+ (end-of-line)
+ (setq start (point))
+ (forward-char 1)
+ (data-debug-insert-stuff-vector stuffvector
+ (concat (make-string indent ? )
+ "[ "))
+ (goto-char start)
+ ))
+
+(defun data-debug-insert-stuff-vector-button (stuffvector
+ prefix
+ prebuttontext)
+ "Insert a button representing STUFFVECTOR.
+PREFIX is the text that preceeds the button.
+PREBUTTONTEXT is some text between prefix and the stuff vector button."
+ (let* ((start (point))
+ (end nil)
+ (str (format "#<vector o' stuff: %d entries>" (length stuffvector)))
+ (tip str))
+ (insert prefix prebuttontext str)
+ (setq end (point))
+ (put-text-property (- end (length str)) end 'face 'font-lock-variable-name-face)
+ (put-text-property start end 'ddebug stuffvector)
+ (put-text-property start end 'ddebug-indent (length prefix))
+ (put-text-property start end 'ddebug-prefix prefix)
+ (put-text-property start end 'help-echo tip)
+ (put-text-property start end 'ddebug-function
+ 'data-debug-insert-stuff-vector-from-point)
+ (insert "\n")
+ )
+ )
+
+;;; Symbol
+;;
+
+(defun data-debug-insert-symbol-from-point (point)
+ "Insert attached properties and possibly the value of symbol at POINT."
+ (let ((symbol (get-text-property point 'ddebug))
+ (indent (get-text-property point 'ddebug-indent))
+ start)
+ (end-of-line)
+ (setq start (point))
+ (forward-char 1)
+ (when (and (not (fboundp symbol)) (boundp symbol))
+ (data-debug-insert-thing
+ (symbol-value symbol)
+ (concat (make-string indent ? ) "> ")
+ (concat
+ (dd-propertize "value"
+ 'face 'font-lock-comment-face)
+ " ")))
+ (data-debug-insert-property-list
+ (symbol-plist symbol)
+ (concat (make-string indent ? ) "> "))
+ (goto-char start))
+ )
+
+(defun data-debug-insert-symbol-button (symbol prefix prebuttontext)
+ "Insert a button representing SYMBOL.
+ PREFIX is the text that preceeds the button.
+ PREBUTTONTEXT is some text between prefix and the symbol button."
+ (let ((string
+ (cond ((fboundp symbol)
+ (dd-propertize (concat "#'" (symbol-name symbol))
+ 'face 'font-lock-function-name-face))
+ ((boundp symbol)
+ (dd-propertize (concat "'" (symbol-name symbol))
+ 'face 'font-lock-variable-name-face))
+ (t (format "'%s" symbol)))))
+ (insert (dd-propertize
+ (concat prefix prebuttontext string)
+ 'ddebug symbol
+ 'ddebug-indent (length prefix)
+ 'ddebug-prefix prefix
+ 'help-echo ""
+ 'ddebug-function
+ 'data-debug-insert-symbol-from-point)
+ "\n"))
+ )
+
+;;; String
+(defun data-debug-insert-string (thing prefix prebuttontext)
+ "Insert one symbol THING.
+A Symbol is a simple thing, but this provides some face and prefix rules.
+PREFIX is the text that preceeds the button.
+PREBUTTONTEXT is some text between prefix and the thing."
+ (let ((newstr thing))
+ (while (string-match "\n" newstr)
+ (setq newstr (replace-match "\\n" t t newstr)))
+ (while (string-match "\t" newstr)
+ (setq newstr (replace-match "\\t" t t newstr)))
+ (insert prefix prebuttontext
+ (dd-propertize (format "\"%s\"" newstr)
+ 'face font-lock-string-face)
+ "\n" )))
+
+;;; Number
+(defun data-debug-insert-number (thing prefix prebuttontext)
+ "Insert one symbol THING.
+A Symbol is a simple thing, but this provides some face and prefix rules.
+PREFIX is the text that preceeds the button.
+PREBUTTONTEXT is some text between prefix and the thing."
+ (insert prefix prebuttontext
+ (dd-propertize (format "%S" thing)
+ 'face font-lock-string-face)
+ "\n"))
+
+;;; Lambda Expression
+(defun data-debug-insert-lambda-expression (thing prefix prebuttontext)
+ "Insert one lambda expression THING.
+A Symbol is a simple thing, but this provides some face and prefix rules.
+PREFIX is the text that preceeds the button.
+PREBUTTONTEXT is some text between prefix and the thing."
+ (let ((txt (prin1-to-string thing)))
+ (data-debug-insert-simple-thing
+ txt prefix prebuttontext 'font-lock-keyword-face))
+ )
+
+;;; nil thing
+(defun data-debug-insert-nil (thing prefix prebuttontext)
+ "Insert one simple THING with a face.
+PREFIX is the text that preceeds the button.
+PREBUTTONTEXT is some text between prefix and the thing.
+FACE is the face to use."
+ (insert prefix prebuttontext)
+ (insert ": ")
+ (let ((start (point))
+ (end nil))
+ (insert "nil")
+ (setq end (point))
+ (insert "\n" )
+ (put-text-property start end 'face 'font-lock-variable-name-face)
+ ))
+
+;;; simple thing
+(defun data-debug-insert-simple-thing (thing prefix prebuttontext face)
+ "Insert one simple THING with a face.
+PREFIX is the text that preceeds the button.
+PREBUTTONTEXT is some text between prefix and the thing.
+FACE is the face to use."
+ (insert prefix prebuttontext)
+ (let ((start (point))
+ (end nil))
+ (insert (format "%s" thing))
+ (setq end (point))
+ (insert "\n" )
+ (put-text-property start end 'face face)
+ ))
+
+;;; custom thing
+(defun data-debug-insert-custom (thingstring prefix prebuttontext face)
+ "Insert one simple THINGSTRING with a face.
+Use for simple items that need a custom insert.
+PREFIX is the text that preceeds the button.
+PREBUTTONTEXT is some text between prefix and the thing.
+FACE is the face to use."
+ (insert prefix prebuttontext)
+ (let ((start (point))
+ (end nil))
+ (insert thingstring)
+ (setq end (point))
+ (insert "\n" )
+ (put-text-property start end 'face face)
+ ))
+
+
+(defvar data-debug-thing-alist
+ '(
+ ;; nil
+ (null . data-debug-insert-nil)
+
+ ;; Overlay
+ (data-debug-overlay-p . data-debug-insert-overlay-button)
+
+ ;; Overlay list
+ ((lambda (thing) (and (consp thing) (data-debug-overlay-p (car thing)))) .
+ data-debug-insert-overlay-list-button)
+
+ ;; Buffer
+ (bufferp . data-debug-insert-buffer-button)
+
+ ;; Buffer list
+ ((lambda (thing) (and (consp thing) (bufferp (car thing)))) .
+ data-debug-insert-buffer-list-button)
+
+ ;; Process
+ (processp . data-debug-insert-process-button)
+
+ ;; String
+ (stringp . data-debug-insert-string)
+
+ ;; Number
+ (numberp . data-debug-insert-number)
+
+ ;; Symbol
+ (symbolp . data-debug-insert-symbol-button)
+
+ ;; Ring
+ (ring-p . data-debug-insert-ring-button)
+
+ ;; Lambda Expression
+ ((lambda (thing) (and (consp thing) (eq (car thing) 'lambda))) .
+ data-debug-insert-lambda-expression)
+
+ ;; Hash-table
+ (hash-table-p . data-debug-insert-hash-table-button)
+
+ ;; Widgets
+ (widgetp . data-debug-insert-widget)
+
+ ;; List of stuff
+ (listp . data-debug-insert-stuff-list-button)
+
+ ;; Vector of stuff
+ (vectorp . data-debug-insert-stuff-vector-button)
+ )
+ "Alist of methods used to insert things into an Ddebug buffer.")
+
+;; An augmentation function for the thing alist.
+(defun data-debug-add-specialized-thing (predicate fcn)
+ "Add a new specialized thing to display with data-debug.
+PREDICATE is a function that returns t if a thing is this new type.
+FCN is a function that will display stuff in the data debug buffer."
+ (let ((entry (cons predicate fcn))
+ ;; Specialized entries show up AFTER nil,
+ ;; but before listp, vectorp, symbolp, and
+ ;; other general things. Splice it into
+ ;; the beginning.
+ (first (nthcdr 0 data-debug-thing-alist))
+ (second (nthcdr 1 data-debug-thing-alist))
+ )
+ (when (not (member entry data-debug-thing-alist))
+ (setcdr first (cons entry second)))))
+
+;; uber insert method
+(defun data-debug-insert-thing (thing prefix prebuttontext &optional parent)
+ "Insert THING with PREFIX.
+PREBUTTONTEXT is some text to insert between prefix and the thing
+that is not included in the indentation calculation of any children.
+If PARENT is non-nil, it is somehow related as a parent to thing."
+ (when (catch 'done
+ (dolist (test data-debug-thing-alist)
+ (when (funcall (car test) thing)
+ (condition-case nil
+ (funcall (cdr test) thing prefix prebuttontext parent)
+ (error
+ (funcall (cdr test) thing prefix prebuttontext)))
+ (throw 'done nil))
+ )
+ nil)
+ (data-debug-insert-simple-thing (format "%S" thing)
+ prefix
+ prebuttontext
+ 'bold)))
+
+;;; MAJOR MODE
+;;
+;; The Ddebug major mode provides an interactive space to explore
+;; complicated data structures.
+;;
+(defgroup data-debug nil
+ "data-debug group."
+ :group 'langauges)
+
+(defvar data-debug-mode-syntax-table
+ (let ((table (make-syntax-table (standard-syntax-table))))
+ (modify-syntax-entry ?\; ". 12" table) ;; SEMI, Comment start ;;
+ (modify-syntax-entry ?\n ">" table) ;; Comment end
+ (modify-syntax-entry ?\" "\"" table) ;; String
+ (modify-syntax-entry ?\- "_" table) ;; Symbol
+ (modify-syntax-entry ?\\ "\\" table) ;; Quote
+ (modify-syntax-entry ?\` "'" table) ;; Prefix ` (backquote)
+ (modify-syntax-entry ?\' "'" table) ;; Prefix ' (quote)
+ (modify-syntax-entry ?\, "'" table) ;; Prefix , (comma)
+
+ table)
+ "Syntax table used in data-debug macro buffers.")
+
+(defvar data-debug-map
+ (let ((km (make-sparse-keymap)))
+ (define-key km [mouse-2] 'data-debug-expand-or-contract-mouse)
+ (define-key km " " 'data-debug-expand-or-contract)
+ (define-key km "\C-m" 'data-debug-expand-or-contract)
+ (define-key km "n" 'data-debug-next)
+ (define-key km "p" 'data-debug-prev)
+ (define-key km "N" 'data-debug-next-expando)
+ (define-key km "P" 'data-debug-prev-expando)
+ km)
+ "Keymap used in data-debug.")
+
+(defcustom data-debug-mode-hook nil
+ "*Hook run when data-debug starts."
+ :group 'data-debug
+ :type 'hook)
+
+(defun data-debug-mode ()
+ "Major-mode for the Analyzer debugger.
+
+\\{data-debug-map}"
+ (interactive)
+ (kill-all-local-variables)
+ (setq major-mode 'data-debug-mode
+ mode-name "DATA-DEBUG"
+ comment-start ";;"
+ comment-end "")
+ (set (make-local-variable 'comment-start-skip)
+ "\\(\\(^\\|[^\\\\\n]\\)\\(\\\\\\\\\\)*\\);+ *")
+ (set-syntax-table data-debug-mode-syntax-table)
+ (use-local-map data-debug-map)
+ (run-hooks 'data-debug-hook)
+ (buffer-disable-undo)
+ (set (make-local-variable 'font-lock-global-modes) nil)
+ (font-lock-mode -1)
+ )
+
+;;;###autoload
+(defun data-debug-new-buffer (name)
+ "Create a new data-debug buffer with NAME."
+ (let ((b (get-buffer-create name)))
+ (pop-to-buffer b)
+ (set-buffer b)
+ (erase-buffer)
+ (data-debug-mode)
+ b))
+
+;;; Ddebug mode commands
+;;
+(defun data-debug-next ()
+ "Go to the next line in the Ddebug buffer."
+ (interactive)
+ (forward-line 1)
+ (beginning-of-line)
+ (skip-chars-forward " *-><[]" (point-at-eol)))
+
+(defun data-debug-prev ()
+ "Go to the next line in the Ddebug buffer."
+ (interactive)
+ (forward-line -1)
+ (beginning-of-line)
+ (skip-chars-forward " *-><[]" (point-at-eol)))
+
+(defun data-debug-next-expando ()
+ "Go to the next line in the Ddebug buffer.
+Contract the current line (if open) and expand the line
+we move to."
+ (interactive)
+ (data-debug-contract-current-line)
+ (data-debug-next)
+ (data-debug-expand-current-line)
+ )
+
+(defun data-debug-prev-expando ()
+ "Go to the previous line in the Ddebug buffer.
+Contract the current line (if open) and expand the line
+we move to."
+ (interactive)
+ (data-debug-contract-current-line)
+ (data-debug-prev)
+ (data-debug-expand-current-line)
+ )
+
+(defun data-debug-current-line-expanded-p ()
+ "Return non-nil if the current line is expanded."
+ (let ((ti (current-indentation))
+ (ni (condition-case nil
+ (save-excursion
+ (end-of-line)
+ (forward-char 1)
+ (current-indentation))
+ (error 0))))
+ (> ni ti)))
+
+(defun data-debug-line-expandable-p ()
+ "Return non-nil if the current line is expandable.
+Lines that are not expandable are assumed to not be contractable."
+ (not (get-text-property (point) 'ddebug-noexpand)))
+
+(defun data-debug-expand-current-line ()
+ "Expand the current line (if possible).
+Do nothing if already expanded."
+ (when (or (not (data-debug-line-expandable-p))
+ (not (data-debug-current-line-expanded-p)))
+ ;; If the next line is the same or less indentation, expand.
+ (let ((fcn (get-text-property (point) 'ddebug-function)))
+ (when fcn
+ (funcall fcn (point))
+ (beginning-of-line)
+ ))))
+
+(defun data-debug-contract-current-line ()
+ "Contract the current line (if possible).
+Do nothing if already expanded."
+ (when (and (data-debug-current-line-expanded-p)
+ ;; Don't contract if the current line is not expandable.
+ (get-text-property (point) 'ddebug-function))
+ (let ((ti (current-indentation))
+ )
+ ;; If next indentation is larger, collapse.
+ (end-of-line)
+ (forward-char 1)
+ (let ((start (point))
+ (end nil))
+ (condition-case nil
+ (progn
+ ;; Keep checking indentation
+ (while (or (> (current-indentation) ti)
+ (looking-at "^\\s-*$"))
+ (end-of-line)
+ (forward-char 1))
+ (setq end (point))
+ )
+ (error (setq end (point-max))))
+ (delete-region start end)
+ (forward-char -1)
+ (beginning-of-line)))))
+
+(defun data-debug-expand-or-contract ()
+ "Expand or contract anything at the current point."
+ (interactive)
+ (if (and (data-debug-line-expandable-p)
+ (data-debug-current-line-expanded-p))
+ (data-debug-contract-current-line)
+ (data-debug-expand-current-line))
+ (skip-chars-forward " *-><[]" (point-at-eol)))
+
+(defun data-debug-expand-or-contract-mouse (event)
+ "Expand or contract anything at event EVENT."
+ (interactive "e")
+ (let* ((win (car (car (cdr event))))
+ )
+ (select-window win t)
+ (save-excursion
+ ;(goto-char (window-start win))
+ (mouse-set-point event)
+ (data-debug-expand-or-contract))
+ ))
+
+;;; GENERIC STRUCTURE DUMP
+;;
+(defun data-debug-show-stuff (stuff name)
+ "Data debug STUFF in a buffer named *NAME DDebug*."
+ (data-debug-new-buffer (concat "*" name " DDebug*"))
+ (data-debug-insert-thing stuff "?" "")
+ (goto-char (point-min))
+ (when (data-debug-line-expandable-p)
+ (data-debug-expand-current-line)))
+
+;;; DEBUG COMMANDS
+;;
+;; Various commands for displaying complex data structures.
+
+(defun data-debug-edebug-expr (expr)
+ "Dump out the contets of some expression EXPR in edebug with ddebug."
+ (interactive
+ (list (let ((minibuffer-completing-symbol t))
+ (read-from-minibuffer "Eval: "
+ nil read-expression-map t
+ 'read-expression-history))
+ ))
+ (let ((v (eval expr)))
+ (if (not v)
+ (message "Expression %s is nil." expr)
+ (data-debug-show-stuff v "expression"))))
+
+(defun data-debug-eval-expression (expr)
+ "Evaluate EXPR and display the value.
+If the result is something simple, show it in the echo area.
+If the result is a list or vector, then use the data debugger to display it."
+ (interactive
+ (list (let ((minibuffer-completing-symbol t))
+ (read-from-minibuffer "Eval: "
+ nil read-expression-map t
+ 'read-expression-history))
+ ))
+
+ (if (null eval-expression-debug-on-error)
+ (setq values (cons (eval expr) values))
+ (let ((old-value (make-symbol "t")) new-value)
+ ;; Bind debug-on-error to something unique so that we can
+ ;; detect when evaled code changes it.
+ (let ((debug-on-error old-value))
+ (setq values (cons (eval expr) values))
+ (setq new-value debug-on-error))
+ ;; If evaled code has changed the value of debug-on-error,
+ ;; propagate that change to the global binding.
+ (unless (eq old-value new-value)
+ (setq debug-on-error new-value))))
+
+ (if (or (consp (car values)) (vectorp (car values)))
+ (let ((v (car values)))
+ (data-debug-show-stuff v "Expression"))
+ ;; Old style
+ (prog1
+ (prin1 (car values) t)
+ (let ((str (eval-expression-print-format (car values))))
+ (if str (princ str t))))))
+
+(provide 'data-debug)
+
+(if (featurep 'eieio)
+ (require 'eieio-datadebug))
+
+;;; data-debug.el ends here
--- /dev/null
+;;; inversion.el --- When you need something in version XX.XX
+
+;;; Copyright (C) 2002, 2003, 2005, 2006, 2007, 2008, 2009
+;;; Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <zappo@gnu.org>
+;; Version: 0.2
+;; Keywords: OO, lisp
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Keeping track of rapidly developing software is a tough thing to
+;; do, especially if you want to have co-dependent packages which all
+;; move at different rates.
+;;
+;; This library provides a framework for specifying version numbers
+;; and (as side effect) have a flexible way of getting a desired feature set.
+;;
+;; If you would like to use this package to satisfy dependency replace this:
+;;
+;; (require 'spiffy)
+;;
+;; with this:
+;;
+;; (require 'inversion)
+;; (inversion-require 'spiffy "1.0")
+;;
+;; If you feel the need to not throw errors, you can do this instead:
+;;
+;; (let ((err (inversion-test 'spiffy "1.0")))
+;; (if err (your-stuff-here)))
+;;
+;; If you new package (2.0) needs to make sure a load file from your
+;; package is compatible, use this test:
+;;
+;; (if (not (inversion-reverse-test 'spiffy version-from-file))
+;; ;; Everything ok
+;; (do stuff)
+;; ;; Out of date
+;; (import-old-code))
+;;
+;; If you would like to make inversion optional, do this:
+;;
+;; (or (require 'inversion nil t)
+;; (defun inversion-test (p v)
+;; (string= v (symbol-value
+;; (intern-soft (concat (symbol-string p) "-version"))))))
+;;
+;; Or modify to specify `inversion-require' instead.
+;;
+;; TODO:
+;; Offer to download newer versions of a package.
+
+;;; History:
+;;
+;; Sept 3, 2002: First general publication.
+
+;;; Code:
+
+(defvar inversion-version "1.3"
+ "Current version of InVersion.")
+
+(defvar inversion-incompatible-version "0.1alpha1"
+ "An earlier release which is incompatible with this release.")
+
+(defconst inversion-decoders
+ '(
+ (alpha "^\\([0-9]+\\)\\.\\([0-9]+\\)\\s-*alpha\\([0-9]+\\)?$" 3)
+ (beta "^\\([0-9]+\\)\\.\\([0-9]+\\)\\s-*beta\\([0-9]+\\)?$" 3)
+ (beta "^\\([0-9]+\\)\\.\\([0-9]+\\)\\s-*(beta\\([0-9]+\\)?)" 3)
+ (prerelease "^\\([0-9]+\\)\\.\\([0-9]+\\)\\s-*pre\\([0-9]+\\)?$" 3)
+ (full "^\\([0-9]+\\)\\.\\([0-9]+\\)$" 2)
+ (fullsingle "^\\([0-9]+\\)$" 1)
+ (patch "^\\([0-9]+\\)\\.\\([0-9]+\\) (patch \\([0-9]+\\))" 3)
+ (point "^\\([0-9]+\\)\\.\\([0-9]+\\)\\.\\([0-9]+\\)$" 3)
+ (build "^\\([0-9]+\\)\\.\\([0-9]+\\)\\.\\([0-9]+\\).\\([0-9]+\\)$" 4)
+ )
+ "List of decoders for version strings.
+Each decoder is of the form:
+
+ ( RELEASE-TYPE REGEXP MAX )
+
+RELEASE-TYPE is a symbol specifying something like `beta' or `alpha'.
+REGEXP is the regular expression to match a version string.
+MAX is the maximum number of match-numbers in the release number.
+Decoders must be ordered to decode least stable versions before the
+more stable ones.")
+
+;;; Version Checking
+;;
+(defun inversion-decode-version (version-string)
+ "Decode VERSION-STRING into an encoded list.
+Return value is of the form:
+ (RELEASE MAJOR MINOR ...)
+where RELEASE is a symbol such as `full', or `beta'."
+ (let ((decoders inversion-decoders)
+ (result nil))
+ (while (and decoders (not result))
+ (if (string-match (nth 1 (car decoders)) version-string)
+ (let ((ver nil)
+ (num-left (nth 2 (car decoders)))
+ (count 1))
+ (while (<= count num-left)
+ (setq ver (cons
+ (if (match-beginning count)
+ (string-to-number
+ (substring version-string
+ (match-beginning count)
+ (match-end count)))
+ 1)
+ ver)
+ count (1+ count)))
+ (setq result (cons (caar decoders) (nreverse ver))))
+ (setq decoders (cdr decoders))))
+ result))
+
+(defun inversion-package-version (package)
+ "Return the decoded version for PACKAGE."
+ (let ((ver (symbol-value
+ (intern-soft
+ (concat (symbol-name package)
+ "-version"))))
+ (code nil))
+ (unless ver
+ (error "Package %S does not define %S-version" package package))
+ ;; Decode the code
+ (setq code (inversion-decode-version ver))
+ (unless code
+ (error "%S-version value cannot be decoded" package))
+ code))
+
+(defun inversion-package-incompatibility-version (package)
+ "Return the decoded incompatibility version for PACKAGE.
+The incompatibility version is specified by the programmer of
+a package when a package is not backward compatible. It is
+not an indication of new features or bug fixes."
+ (let ((ver (symbol-value
+ (intern-soft
+ (concat (symbol-name package)
+ "-incompatible-version")))))
+ (if (not ver)
+ nil
+ ;; Decode the code
+ (inversion-decode-version ver))))
+
+(defun inversion-recode (code)
+ "Convert CODE into a string."
+ (let ((r (nth 0 code)) ; release-type
+ (n (nth 1 code)) ; main number
+ (i (nth 2 code)) ; first increment
+ (p (nth 3 code))) ; second increment
+ (cond
+ ((eq r 'full)
+ (setq r "" p ""))
+ ((eq r 'point)
+ (setq r ".")))
+ (format "%s.%s%s%s" n i r p)))
+
+(defun inversion-release-to-number (release-symbol)
+ "Convert RELEASE-SYMBOL into a number."
+ (let* ((ra (assoc release-symbol inversion-decoders))
+ (rn (- (length inversion-decoders)
+ (length (member ra inversion-decoders)))))
+ rn))
+
+(defun inversion-= (ver1 ver2)
+ "Return non-nil if VER1 is equal to VER2."
+ (equal ver1 ver2))
+
+(defun inversion-< (ver1 ver2)
+ "Return non-nil if VER1 is less than VER2."
+ (let ((v1-0 (inversion-release-to-number (nth 0 ver1)))
+ (v1-1 (nth 1 ver1))
+ (v1-2 (nth 2 ver1))
+ (v1-3 (nth 3 ver1))
+ (v1-4 (nth 4 ver1))
+ ;; v2
+ (v2-0 (inversion-release-to-number (nth 0 ver2)))
+ (v2-1 (nth 1 ver2))
+ (v2-2 (nth 2 ver2))
+ (v2-3 (nth 3 ver2))
+ (v2-4 (nth 4 ver2))
+ )
+ (or (and (= v1-0 v2-0)
+ (= v1-1 v2-1)
+ (= v1-2 v2-2)
+ (= v1-3 v2-3)
+ v1-4 v2-4 ; all or nothin if elt - is =
+ (< v1-4 v2-4))
+ (and (= v1-0 v2-0)
+ (= v1-1 v2-1)
+ (= v1-2 v2-2)
+ v1-3 v2-3 ; all or nothin if elt - is =
+ (< v1-3 v2-3))
+ (and (= v1-1 v2-1)
+ (< v1-2 v2-2))
+ (and (< v1-1 v2-1))
+ (and (< v1-0 v2-0)
+ (= v1-1 v2-1)
+ (= v1-2 v2-2)
+ )
+ )))
+
+(defun inversion-check-version (version incompatible-version
+ minimum &rest reserved)
+ "Check that a given version meets the minimum requirement.
+VERSION, INCOMPATIBLE-VERSION and MINIMUM are of similar format to
+return entries of `inversion-decode-version', or a classic version
+string. INCOMPATIBLE-VERSION can be nil.
+RESERVED arguments are kept for a later use.
+Return:
+- nil if everything is ok
+- 'outdated if VERSION is less than MINIMUM.
+- 'incompatible if VERSION is not backward compatible with MINIMUM.
+- t if the check failed."
+ (let ((code (if (stringp version)
+ (inversion-decode-version version)
+ version))
+ (req (if (stringp minimum)
+ (inversion-decode-version minimum)
+ minimum))
+ )
+ ;; Perform a test.
+ (cond
+ ((inversion-= code req)
+ ;; Same version.. Yay!
+ nil)
+ ((inversion-< code req)
+ ;; Version is too old!
+ 'outdated)
+ ((inversion-< req code)
+ ;; Newer is installed. What to do?
+ (let ((incompatible
+ (if (stringp incompatible-version)
+ (inversion-decode-version incompatible-version)
+ incompatible-version)))
+ (cond
+ ((not incompatible) nil)
+ ((or (inversion-= req incompatible)
+ (inversion-< req incompatible))
+ ;; The requested version is = or < than what the package
+ ;; maintainer says is incompatible.
+ 'incompatible)
+ ;; Things are ok.
+ (t nil))))
+ ;; Check failed
+ (t t))))
+
+(defun inversion-test (package minimum &rest reserved)
+ "Test that PACKAGE meets the MINIMUM version requirement.
+PACKAGE is a symbol, similar to what is passed to `require'.
+MINIMUM is of similar format to return entries of
+`inversion-decode-version', or a classic version string.
+RESERVED arguments are kept for a later user.
+This depends on the symbols `PACKAGE-version' and optionally
+`PACKAGE-incompatible-version' being defined in PACKAGE.
+Return nil if everything is ok. Return an error string otherwise."
+ (let ((check (inversion-check-version
+ (inversion-package-version package)
+ (inversion-package-incompatibility-version package)
+ minimum reserved)))
+ (cond
+ ((null check)
+ ;; Same version.. Yay!
+ nil)
+ ((eq check 'outdated)
+ ;; Version is too old!
+ (format "You need to upgrade package %s to %s" package minimum))
+ ((eq check 'incompatible)
+ ;; Newer is installed but the requested version is = or < than
+ ;; what the package maintainer says is incompatible, then throw
+ ;; that error.
+ (format "Package %s version is not backward compatible with %s"
+ package minimum))
+ ;; Check failed
+ (t "Inversion version check failed."))))
+
+(defun inversion-reverse-test (package oldversion &rest reserved)
+ "Test that PACKAGE at OLDVERSION is still compatible.
+If something like a save file is loaded at OLDVERSION, this
+test will identify if OLDVERSION is compatible with the current version
+of PACKAGE.
+PACKAGE is a symbol, similar to what is passed to `require'.
+OLDVERSION is of similar format to return entries of
+`inversion-decode-version', or a classic version string.
+RESERVED arguments are kept for a later user.
+This depends on the symbols `PACKAGE-version' and optionally
+`PACKAGE-incompatible-version' being defined in PACKAGE.
+Return nil if everything is ok. Return an error string otherwise."
+ (let ((check (inversion-check-version
+ (inversion-package-version package)
+ (inversion-package-incompatibility-version package)
+ oldversion reserved)))
+ (cond
+ ((null check)
+ ;; Same version.. Yay!
+ nil)
+ ((eq check 'outdated)
+ ;; Version is too old!
+ (format "Package %s version %s is not compatible with current version"
+ package oldversion))
+ ((eq check 'incompatible)
+ ;; Newer is installed but the requested version is = or < than
+ ;; what the package maintainer says is incompatible, then throw
+ ;; that error.
+ (format "Package %s version is not backward compatible with %s"
+ package oldversion))
+ ;; Check failed
+ (t "Inversion version check failed."))))
+
+(defun inversion-require (package version &optional file directory
+ &rest reserved)
+ "Declare that you need PACKAGE with at least VERSION.
+PACKAGE might be found in FILE. (See `require'.)
+Throws an error if VERSION is incompatible with what is installed.
+Optional argument DIRECTORY is a location where new versions of
+this tool can be located. If there is a versioning problem and
+DIRECTORY is provided, inversion will offer to download the file.
+Optional argument RESERVED is saved for later use."
+ (require package file)
+ (let ((err (inversion-test package version)))
+ (when err
+ (if directory
+ (inversion-download-package-ask err package directory version)
+ (error err)))
+ ;; Return the package symbol that was required.
+ package))
+
+(defun inversion-require-emacs (emacs-ver xemacs-ver)
+ "Declare that you need either EMACS-VER, or XEMACS-VER.
+Only checks one based on which kind of Emacs is being run."
+ (let ((err (inversion-test 'emacs
+ (if (featurep 'xemacs)
+ xemacs-ver
+ emacs-ver))))
+ (if err (error err)
+ ;; Something nice...
+ t)))
+
+(defconst inversion-find-data
+ '("(def\\(var\\|const\\)\\s-+%s-%s\\s-+\"\\([^\"]+\\)" 2)
+ "Regexp template and match data index of a version string.")
+
+(defun inversion-find-version (package)
+ "Search for the version and incompatible version of PACKAGE.
+Does not load PACKAGE nor requires that it has been previously loaded.
+Search in the directories in `load-path' for a PACKAGE.el library.
+Visit the file found and search for the declarations of variables or
+constants `PACKAGE-version' and `PACKAGE-incompatible-version'. The
+value of these variables must be a version string.
+
+Return a pair (VERSION-STRING . INCOMPATIBLE-VERSION-STRING) where
+INCOMPATIBLE-VERSION-STRING can be nil.
+Return nil when VERSION-STRING was not found."
+ (let* ((file (locate-library (format "%s.el" package) t))
+ (tag (car inversion-find-data))
+ (idx (nth 1 inversion-find-data))
+ version)
+ (when file
+ (with-temp-buffer
+ ;; The 3000 is a bit arbitrary, but should cut down on
+ ;; fileio as version info usually is at the very top
+ ;; of a file. AFter a long commentary could be bad.
+ (insert-file-contents-literally file nil 0 3000)
+ (goto-char (point-min))
+ (when (re-search-forward (format tag package 'version) nil t)
+ (setq version (list (match-string idx)))
+ (goto-char (point-min))
+ (when (re-search-forward
+ (format tag package 'incompatible-version) nil t)
+ (setcdr version (match-string idx))))))
+ version))
+
+(defun inversion-add-to-load-path (package minimum
+ &optional installdir
+ &rest subdirs)
+ "Add the PACKAGE path to `load-path' if necessary.
+MINIMUM is the minimum version requirement of PACKAGE.
+Optional argument INSTALLDIR is the base directory where PACKAGE is
+installed. It defaults to `default-directory'/PACKAGE.
+SUBDIRS are sub-directories to add to `load-path', following the main
+INSTALLDIR path."
+ (let ((ver (inversion-find-version package)))
+ ;; If PACKAGE not found or a bad version already in `load-path',
+ ;; prepend the new PACKAGE path, so it will be loaded first.
+ (when (or (not ver)
+ (and
+ (inversion-check-version (car ver) (cdr ver) minimum)
+ (message "Outdated %s %s shadowed to meet minimum version %s"
+ package (car ver) minimum)
+ t))
+ (let* ((default-directory
+ (or installdir
+ (expand-file-name (format "./%s" package))))
+ subdir)
+ (when (file-directory-p default-directory)
+ ;; Add SUBDIRS
+ (while subdirs
+ (setq subdir (expand-file-name (car subdirs))
+ subdirs (cdr subdirs))
+ (when (file-directory-p subdir)
+ ;;(message "%S added to `load-path'" subdir)
+ (add-to-list 'load-path subdir)))
+ ;; Add the main path
+ ;;(message "%S added to `load-path'" default-directory)
+ (add-to-list 'load-path default-directory))
+ ;; We get to this point iff we do not accept or there is no
+ ;; system file. Lets check the version of what we just
+ ;; installed... just to be safe.
+ (let ((newver (inversion-find-version package)))
+ (if (not newver)
+ (error "Failed to find version for newly installed %s"
+ package))
+ (if (inversion-check-version (car newver) (cdr newver) minimum)
+ (error "Outdated %s %s just installed" package (car newver)))
+ )))))
+
+;;; URL and downloading code
+;;
+(defun inversion-locate-package-files (package directory &optional version)
+ "Get a list of distributions of PACKAGE from DIRECTORY.
+DIRECTORY can be an ange-ftp compatible filename, such as:
+ \"/ftp@ftp1.sourceforge.net/pub/sourceforge/PACKAGE\"
+If it is a URL, wget will be used for download.
+Optional argument VERSION will restrict the list of available versions
+to the file matching VERSION exactly, or nil."
+;;DIRECTORY should also allow a URL:
+;; \"http://ftp1.sourceforge.net/PACKAGE\"
+;; but then I can get file listings easily.
+ (if (symbolp package) (setq package (symbol-name package)))
+ (directory-files directory t
+ (if version
+ (concat "^" package "-" version "\\>")
+ package)))
+
+(defvar inversion-package-common-tails '( ".tar.gz"
+ ".tar"
+ ".zip"
+ ".gz"
+ )
+ "Common distribution mechanisms for Emacs Lisp packages.")
+
+(defun inversion-locate-package-files-and-split (package directory &optional version)
+ "Use `inversion-locate-package-files' to get a list of PACKAGE files.
+DIRECTORY is the location where distributions of PACKAGE are.
+VERSION is an optional argument specifying a version to restrict to.
+The return list is an alist with the version string in the CAR,
+and the full path name in the CDR."
+ (if (symbolp package) (setq package (symbol-name package)))
+ (let ((f (inversion-locate-package-files package directory version))
+ (out nil))
+ (while f
+ (let* ((file (car f))
+ (dist (file-name-nondirectory file))
+ (tails inversion-package-common-tails)
+ (verstring nil))
+ (while (and tails (not verstring))
+ (when (string-match (concat (car tails) "$") dist)
+ (setq verstring
+ (substring dist (1+ (length package)) (match-beginning 0))))
+ (setq tails (cdr tails)))
+ (if (not verstring)
+ (error "Cannot decode version for %s" dist))
+ (setq out
+ (cons
+ (cons verstring file)
+ out))
+ (setq f (cdr f))))
+ out))
+
+(defun inversion-download-package-ask (err package directory version)
+ "Due to ERR, offer to download PACKAGE from DIRECTORY.
+The package should have VERSION available for download."
+ (if (symbolp package) (setq package (symbol-name package)))
+ (let ((files (inversion-locate-package-files-and-split
+ package directory version)))
+ (if (not files)
+ (error err)
+ (if (not (y-or-n-p (concat err ": Download update? ")))
+ (error err)
+ (let ((dest (read-directory-name (format "Download %s to: "
+ package)
+ t)))
+ (if (> (length files) 1)
+ (setq files
+ (list
+ "foo" ;; ignored
+ (read-file-name "Version to download: "
+ directory
+ files
+ t
+ (concat
+ (file-name-as-directory directory)
+ package)
+ nil))))
+
+ (copy-file (cdr (car files)) dest))))))
+
+;;; How we upgrade packages in Emacs has yet to be ironed out.
+
+;; (defun inversion-upgrade-package (package &optional directory)
+;; "Try to upgrade PACKAGE in DIRECTORY is available."
+;; (interactive "sPackage to upgrade: ")
+;; (if (stringp package) (setq package (intern package)))
+;; (if (not directory)
+;; ;; Hope that the package maintainer specified.
+;; (setq directory (symbol-value (or (intern-soft
+;; (concat (symbol-name package)
+;; "-url"))
+;; (intern-soft
+;; (concat (symbol-name package)
+;; "-directory"))))))
+;; (let ((files (inversion-locate-package-files-and-split
+;; package directory))
+;; (cver (inversion-package-version package))
+;; (newer nil))
+;; (mapc (lambda (f)
+;; (if (inversion-< cver (inversion-decode-version (car f)))
+;; (setq newer (cons f newer))))
+;; files)
+;; newer
+;; ))
+
+(provide 'inversion)
+
+;;; inversion.el ends here
--- /dev/null
+;;; pulse.el --- Pulsing Overlays
+
+;;; Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <eric@siege-engine.com>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Manage temporary pulsing of faces and overlays.
+;;
+;; This is a temporal decoration technique where something is to be
+;; highlighted briefly. This adds a gentle pulsing style to the text
+;; decorated this way.
+;;
+;; Useful user functions:
+;;
+;; `pulse-enable-integration-advice' - Turn on advice to make various
+;; Emacs commands pulse, such as `goto-line', or `find-tag'.
+;;
+;; The following are useful entry points:
+;;
+;; `pulse' - Cause `pulse-highlight-face' to shift toward background color.
+;; Assumes you are using a version of Emacs that supports pulsing.
+;;
+;;
+;; `pulse-momentary-highlight-one-line' - Pulse a single line at POINT.
+;; `pulse-momentary-highlight-region' - Pulse a region.
+;; `pulse-momentary-highlight-overlay' - Pulse an overlay
+;; These three functions will just blink the specified area if
+;; the version of Emacs you are using doesn't support pulsing.
+;;
+;; `pulse-line-hook-function' - A simple function that can be used in a
+;; hook that will pulse whatever line the cursor is on.
+;;
+;;; History:
+;;
+;; The original pulse code was written for semantic tag highlighting.
+;; It has been extracted, and adapted for general purpose pulsing.
+;;
+;; Pulse is a part of CEDET. http://cedet.sf.net
+
+(defun pulse-available-p ()
+ "Return non-nil if pulsing is available on the current frame."
+ (condition-case nil
+ (let ((v (color-values (face-background 'default))))
+ (numberp (car-safe v)))
+ (error nil)))
+
+(defcustom pulse-flag (pulse-available-p)
+ "*Non-nil means to pulse the overlay face for momentary highlighting.
+Pulsing involves a bright highlight that slowly shifts to the background
+color. Non-nil just means to highlight with an unchanging color for a short
+time.
+
+If `pulse-flag' is non-nil, but `pulse-available-p' is nil, then
+this flag is ignored."
+ :group 'pulse
+ :type 'boolean)
+
+(defface pulse-highlight-start-face
+ '((((class color) (background dark))
+ (:background "#AAAA33"))
+ (((class color) (background light))
+ (:background "#FFFFAA")))
+ "*Face used at beginning of a highight."
+ :group 'pulse)
+
+(defface pulse-highlight-face
+ '((((class color) (background dark))
+ (:background "#AAAA33"))
+ (((class color) (background light))
+ (:background "#FFFFAA")))
+ "*Face used during a pulse for display. *DO NOT CUSTOMIZE*
+Face used for temporary highlighting of tags for effect."
+ :group 'pulse)
+
+;;; Code:
+;;
+(defun pulse-int-to-hex (int &optional nb-digits)
+ "Convert integer argument INT to a #XXXXXXXXXXXX format hex string.
+Each X in the output string is a hexadecimal digit.
+NB-DIGITS is the number of hex digits. If INT is too large to be
+represented with NB-DIGITS, then the result is truncated from the
+left. So, for example, INT=256 and NB-DIGITS=2 returns \"00\", since
+the hex equivalent of 256 decimal is 100, which is more than 2 digits.
+
+This function was blindly copied from hexrgb.el by Drew Adams.
+http://www.emacswiki.org/cgi-bin/wiki/hexrgb.el"
+ (setq nb-digits (or nb-digits 4))
+ (substring (format (concat "%0" (int-to-string nb-digits) "X") int) (- nb-digits)))
+
+(defun pulse-color-values-to-hex (values)
+ "Convert list of rgb color VALUES to a hex string, #XXXXXXXXXXXX.
+Each X in the string is a hexadecimal digit.
+Input VALUES is as for the output of `x-color-values'.
+
+This function was blindly copied from hexrgb.el by Drew Adams.
+http://www.emacswiki.org/cgi-bin/wiki/hexrgb.el"
+ (concat "#"
+ (pulse-int-to-hex (nth 0 values) 4) ; red
+ (pulse-int-to-hex (nth 1 values) 4) ; green
+ (pulse-int-to-hex (nth 2 values) 4))) ; blue
+
+(defcustom pulse-iterations 10
+ "Number of iterations in a pulse operation."
+ :group 'pulse
+ :type 'number)
+(defcustom pulse-delay .03
+ "Delay between face lightening iterations, as used by `sit-for'."
+ :group 'pulse
+ :type 'number)
+
+(defun pulse-lighten-highlight ()
+ "Lighten the face by 1/`pulse-iterations' toward the background color.
+Return t if there is more drift to do, nil if completed."
+ (if (>= (get 'pulse-highlight-face :iteration) pulse-iterations)
+ nil
+ (let* ((frame (color-values (face-background 'default)))
+ (start (color-values (face-background
+ (get 'pulse-highlight-face
+ :startface))))
+ (frac (list (/ (- (nth 0 frame) (nth 0 start)) pulse-iterations)
+ (/ (- (nth 1 frame) (nth 1 start)) pulse-iterations)
+ (/ (- (nth 2 frame) (nth 2 start)) pulse-iterations)))
+ (it (get 'pulse-highlight-face :iteration))
+ )
+ (set-face-background 'pulse-highlight-face
+ (pulse-color-values-to-hex
+ (list
+ (+ (nth 0 start) (* (nth 0 frac) it))
+ (+ (nth 1 start) (* (nth 1 frac) it))
+ (+ (nth 2 start) (* (nth 2 frac) it)))))
+ (put 'pulse-highlight-face :iteration (1+ it))
+ (if (>= (1+ it) pulse-iterations)
+ nil
+ t))))
+
+(defun pulse-reset-face (&optional face)
+ "Reset the pulse highlighting FACE."
+ (set-face-background 'pulse-highlight-face
+ (if face
+ (face-background face)
+ (face-background 'pulse-highlight-start-face)
+ ))
+ (put 'pulse-highlight-face :startface (or face
+ 'pulse-highlight-start-face))
+ (put 'pulse-highlight-face :iteration 0))
+
+(defun pulse (&optional face)
+ "Pulse the colors on our highlight face.
+If optional FACE is provide, reset the face to FACE color,
+instead of `pulse-highlight-start-face'.
+Be sure to call `pulse-reset-face' after calling pulse."
+ (unwind-protect
+ (progn
+ (pulse-reset-face face)
+ (while (and (pulse-lighten-highlight)
+ (sit-for pulse-delay))
+ nil))))
+
+;;; Convenience Functions
+;;
+(defvar pulse-momentary-overlay nil
+ "The current pulsing overlay.")
+
+(defun pulse-momentary-highlight-overlay (o &optional face)
+ "Pulse the overlay O, unhighlighting before next command.
+Optional argument FACE specifies the fact to do the highlighting."
+ (overlay-put o 'original-face (overlay-get o 'face))
+ (add-to-list 'pulse-momentary-overlay o)
+ (if (or (not pulse-flag) (not (pulse-available-p)))
+ ;; Provide a face... clear on next command
+ (progn
+ (overlay-put o 'face (or face 'pulse-highlight-start-face))
+ (add-hook 'pre-command-hook
+ 'pulse-momentary-unhighlight)
+ )
+ ;; pulse it.
+ (unwind-protect
+ (progn
+ (overlay-put o 'face 'pulse-highlight-face)
+ ;; The pulse function puts FACE onto 'pulse-highlight-face.
+ ;; Thus above we put our face on the overlay, but pulse
+ ;; with a reference face needed for the color.
+ (pulse face))
+ (pulse-momentary-unhighlight))))
+
+(defun pulse-momentary-unhighlight ()
+ "Unhighlight a line recently highlighted."
+ ;; If someone passes in an overlay, then pulse-momentary-overlay
+ ;; will still be nil, and won't need modifying.
+ (when pulse-momentary-overlay
+ ;; clear the starting face
+ (mapc
+ (lambda (ol)
+ (overlay-put ol 'face (overlay-get ol 'original-face))
+ (overlay-put ol 'original-face nil)
+ ;; Clear the overlay if it needs deleting.
+ (when (overlay-get ol 'pulse-delete) (delete-overlay ol)))
+ pulse-momentary-overlay)
+
+ ;; Clear the variable.
+ (setq pulse-momentary-overlay nil))
+
+ ;; Reset the pulsing face.
+ (pulse-reset-face)
+
+ ;; Remove this hook.
+ (remove-hook 'pre-command-hook 'pulse-momentary-unhighlight))
+
+(defun pulse-momentary-highlight-one-line (point &optional face)
+ "Highlight the line around POINT, unhighlighting before next command.
+Optional argument FACE specifies the face to do the highlighting."
+ (let ((start (point-at-bol))
+ (end (save-excursion
+ (end-of-line)
+ (when (not (eobp))
+ (forward-char 1))
+ (point))))
+ (pulse-momentary-highlight-region start end face)))
+
+(defun pulse-momentary-highlight-region (start end &optional face)
+ "Highlight between START and END, unhighlighting before next command.
+Optional argument FACE specifies the fact to do the highlighting."
+ (let ((o (make-overlay start end)))
+ ;; Mark it for deletion
+ (overlay-put o 'pulse-delete t)
+ (pulse-momentary-highlight-overlay o face)))
+
+;;; Random integration with other tools
+
+(defvar pulse-command-advice-flag nil)
+
+(defun pulse-line-hook-function ()
+ "Function used in hooks to pulse the current line.
+Only pulses the line if `pulse-command-advice-flag' is non-nil."
+ (when pulse-command-advice-flag
+ (pulse-momentary-highlight-one-line (point))))
+
+(provide 'pulse)
+
+;;; pulse.el ends here
projects / emacs.git / commitdiff