Mercurial > emacs
changeset 105241:130db1220dfd
* 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.
| author | Chong Yidong <cyd@stupidchicken.com> |
|---|---|
| date | Mon, 28 Sep 2009 01:28:41 +0000 |
| parents | 6803b273c03a |
| children | bcef064b8a00 |
| files | lisp/ChangeLog lisp/cedet/cedet-cscope.el lisp/cedet/cedet-files.el lisp/cedet/cedet-global.el lisp/cedet/cedet-idutils.el lisp/cedet/data-debug.el lisp/cedet/inversion.el lisp/cedet/pulse.el |
| diffstat | 8 files changed, 2483 insertions(+), 0 deletions(-) [+] |
line wrap: on
line diff
--- a/lisp/ChangeLog Mon Sep 28 01:05:20 2009 +0000 +++ b/lisp/ChangeLog Mon Sep 28 01:28:41 2009 +0000 @@ -8,6 +8,14 @@ * 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 Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/cedet-cscope.el Mon Sep 28 01:28:41 2009 +0000 @@ -0,0 +1,157 @@ +;;; 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 Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/cedet-files.el Mon Sep 28 01:28:41 2009 +0000 @@ -0,0 +1,92 @@ +;;; 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 Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/cedet-global.el Mon Sep 28 01:28:41 2009 +0000 @@ -0,0 +1,162 @@ +;;; 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 Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/cedet-idutils.el Mon Sep 28 01:28:41 2009 +0000 @@ -0,0 +1,181 @@ +;;; 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 Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/data-debug.el Mon Sep 28 01:28:41 2009 +0000 @@ -0,0 +1,1085 @@ +;;; 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") + ) + ) + + +;;; 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 Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/inversion.el Mon Sep 28 01:28:41 2009 +0000 @@ -0,0 +1,541 @@ +;;; 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 Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/pulse.el Mon Sep 28 01:28:41 2009 +0000 @@ -0,0 +1,257 @@ +;;; 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