aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--lisp/ChangeLog8
-rw-r--r--lisp/cedet/cedet-cscope.el157
-rw-r--r--lisp/cedet/cedet-files.el92
-rw-r--r--lisp/cedet/cedet-global.el162
-rw-r--r--lisp/cedet/cedet-idutils.el181
-rw-r--r--lisp/cedet/data-debug.el1085
-rw-r--r--lisp/cedet/inversion.el541
-rw-r--r--lisp/cedet/pulse.el257
8 files changed, 2483 insertions, 0 deletions
diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index fee8f99c6fc..b62a34cf81e 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -8,6 +8,14 @@
8 * emacs-lisp/eieio-speedbar.el: 8 * emacs-lisp/eieio-speedbar.el:
9 * emacs-lisp/eieio.el: New files. 9 * emacs-lisp/eieio.el: New files.
10 10
11 * cedet/cedet-cscope.el:
12 * cedet/cedet-files.el:
13 * cedet/cedet-global.el:
14 * cedet/cedet-idutils.el:
15 * cedet/data-debug.el:
16 * cedet/inversion.el:
17 * cedet/pulse.el: New files.
18
112009-09-27 Chong Yidong <cyd@stupidchicken.com> 192009-09-27 Chong Yidong <cyd@stupidchicken.com>
12 20
13 * menu-bar.el: Remove menu-bar-ediff-misc-menu from the Tools 21 * menu-bar.el: Remove menu-bar-ediff-misc-menu from the Tools
diff --git a/lisp/cedet/cedet-cscope.el b/lisp/cedet/cedet-cscope.el
new file mode 100644
index 00000000000..930aa3098d5
--- /dev/null
+++ b/lisp/cedet/cedet-cscope.el
@@ -0,0 +1,157 @@
1;;; cedet-cscope.el --- CScope support for CEDET
2
3;;; Copyright (C) 2009 Free Software Foundation, Inc.
4
5;; Author: Eric M. Ludlam <zappo@gnu.org>
6
7;; This file is part of GNU Emacs.
8
9;; GNU Emacs is free software: you can redistribute it and/or modify
10;; it under the terms of the GNU General Public License as published by
11;; the Free Software Foundation, either version 3 of the License, or
12;; (at your option) any later version.
13
14;; GNU Emacs is distributed in the hope that it will be useful,
15;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17;; GNU General Public License for more details.
18
19;; You should have received a copy of the GNU General Public License
20;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
21
22;;; Commentary:
23;;
24;; Support using CScope for symbol lookups.
25
26;;; Code:
27
28(declare-function inversion-check-version "inversion")
29
30(defvar cedet-cscope-min-version "16.0"
31 "Minimum version of CScope required.")
32
33(defcustom cedet-cscope-command "cscope"
34 "Command name for the CScope executable."
35 :type 'string
36 :group 'cedet)
37
38(defun cedet-cscope-search (searchtext texttype type scope)
39 "Perform a search with CScope, return the created buffer.
40SEARCHTEXT is text to find.
41TEXTTYPE is the type of text, such as 'regexp, 'string, 'tagname,
42'tagregexp, or 'tagcompletions.
43TYPE is the type of search, meaning that SEARCHTEXT is compared to
44filename, tagname (tags table), references (uses of a tag) , or
45symbol (uses of something not in the tag table.)
46SCOPE is the scope of the search, such as 'project or 'subdirs."
47 ;; CScope is an interactive program. It uses number flags
48 ;; in order to perform command line searches. Useful for this
49 ;; tool are:
50 ;;
51 ;; -0 = Find C symbol
52 ;; -1 = Find global definition
53 ;; -3 = Find references
54 ;; -6 = Find egrep pattern
55 ;; -7 = Find file
56 (let ((idx (cond ((eq type 'file)
57 "-7")
58 ;; Non files are symbols and such
59 ((eq texttype 'tagname)
60 "-1")
61 ((eq texttype 'tagregexp)
62 "-0")
63 ((eq texttype 'tagcompletions)
64 (setq searchtext (concat "^" searchtext ".*"))
65 "-1")
66 ((eq texttype 'regexp)
67 "-5")
68 (t
69 "-3")
70 )
71 )
72 )
73 (cedet-cscope-call (list "-d" "-L" idx searchtext))))
74
75(defun cedet-cscope-call (flags)
76 "Call CScope with the list of FLAGS."
77 (let ((b (get-buffer-create "*CEDET CScope*"))
78 (cd default-directory)
79 )
80 (save-excursion
81 (set-buffer b)
82 (setq default-directory cd)
83 (erase-buffer))
84 (apply 'call-process cedet-cscope-command
85 nil b nil
86 flags)
87 b))
88
89(defun cedet-cscope-expand-filename (filename)
90 "Expand the FILENAME with CScope.
91Return a fully qualified filename."
92 (interactive "sFile: ")
93 (let* ((ans1 (save-excursion
94 (set-buffer (cedet-cscope-call (list "-d" "-L" "-7" filename)))
95 (goto-char (point-min))
96 (if (looking-at "[^ \n]*cscope: ")
97 (error "CScope not available")
98 (split-string (buffer-string) "\n" t))))
99 (ans2 (mapcar (lambda (hit)
100 (expand-file-name (car (split-string hit " "))))
101 ans1)))
102 (when (interactive-p)
103 (if ans2
104 (if (= (length ans2) 1)
105 (message "%s" (car ans2))
106 (message "%s + %d others" (car ans2)
107 (length (cdr ans2))))
108 (error "No file found")))
109 ans2))
110
111(defun cedet-cscope-support-for-directory (&optional dir)
112 "Return non-nil if CScope has a support file for DIR.
113If DIR is not supplied, use the current default directory.
114This works by running cscope on a bogus symbol, and looking for
115the error code."
116 (save-excursion
117 (let ((default-directory (or dir default-directory)))
118 (set-buffer (cedet-cscope-call (list "-d" "-L" "-7" "moose")))
119 (goto-char (point-min))
120 (if (looking-at "[^ \n]*cscope: ")
121 nil
122 t))))
123
124(defun cedet-cscope-version-check (&optional noerror)
125 "Check the version of the installed CScope command.
126If optional programatic argument NOERROR is non-nil, then
127instead of throwing an error if CScope isn't available, then
128return nil."
129 (interactive)
130 (require 'inversion)
131 (let ((b (condition-case nil
132 (cedet-cscope-call (list "-V"))
133 (error nil)))
134 (rev nil))
135 (if (not b)
136 (progn
137 (when (interactive-p)
138 (message "CScope not found."))
139 nil)
140 (save-excursion
141 (set-buffer b)
142 (goto-char (point-min))
143 (re-search-forward "cscope: version \\([0-9.]+\\)" nil t)
144 (setq rev (match-string 1))
145 (if (inversion-check-version rev nil cedet-cscope-min-version)
146 (if noerror
147 nil
148 (error "Version of CScope is %s. Need at least %s"
149 rev cedet-cscope-min-version))
150 ;; Else, return TRUE, as in good enough.
151 (when (interactive-p)
152 (message "CScope %s - Good enough for CEDET." rev))
153 t)))))
154
155(provide 'cedet-cscope)
156
157;;; cedet-cscope.el ends here
diff --git a/lisp/cedet/cedet-files.el b/lisp/cedet/cedet-files.el
new file mode 100644
index 00000000000..b7d9b5dbdbd
--- /dev/null
+++ b/lisp/cedet/cedet-files.el
@@ -0,0 +1,92 @@
1;;; cedet-files.el --- Common routines dealing with file names.
2
3;;; Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc.
4
5;; Author: Eric M. Ludlam <eric@siege-engine.com>
6
7;; This file is part of GNU Emacs.
8
9;; GNU Emacs is free software: you can redistribute it and/or modify
10;; it under the terms of the GNU General Public License as published by
11;; the Free Software Foundation, either version 3 of the License, or
12;; (at your option) any later version.
13
14;; GNU Emacs is distributed in the hope that it will be useful,
15;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17;; GNU General Public License for more details.
18
19;; You should have received a copy of the GNU General Public License
20;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
21
22;;; Commentary:
23;;
24;; Various useful routines for dealing with file names in the tools
25;; which are a part of CEDET.
26
27;;; Code:
28
29(defun cedet-directory-name-to-file-name (referencedir &optional testmode)
30 "Convert the REFERENCEDIR (a full path name) into a filename.
31Convert directory seperation characters into ! characters.
32Optional argument TESTMODE is used by tests to avoid conversion
33to the file's truename, and dodging platform tricks."
34 (let ((file referencedir))
35 ;; Expand to full file name
36 (when (not testmode)
37 (setq file (file-truename file)))
38 ;; If FILE is a directory, then force it to end in /.
39 (when (file-directory-p file)
40 (setq file (file-name-as-directory file)))
41 ;; Handle Windows Special cases
42 (when (or (memq system-type '(windows-nt ms-dos)) testmode)
43 ;; Replace any invalid file-name characters (for the
44 ;; case of backing up remote files).
45 (when (not testmode)
46 (setq file (expand-file-name (convert-standard-filename file))))
47 ;; Normalize DOSish file names.
48 (if (eq (aref file 1) ?:)
49 (setq file (concat "/"
50 "drive_"
51 (char-to-string (downcase (aref file 0)))
52 (if (eq (aref file 2) ?/)
53 ""
54 "/")
55 (substring file 2)))))
56 ;; Make the name unique by substituting directory
57 ;; separators. It may not really be worth bothering about
58 ;; doubling `!'s in the original name...
59 (setq file (subst-char-in-string
60 ?/ ?!
61 (replace-regexp-in-string "!" "!!" file)))
62 file))
63
64(defun cedet-file-name-to-directory-name (referencefile &optional testmode)
65 "Reverse the process of `cedet-directory-name-to-file-name'.
66Convert REFERENCEFILE to a directory name replacing ! with /.
67Optional TESTMODE is used in tests to avoid doing some platform
68specific conversions during tests."
69 (let ((file referencefile))
70 ;; Replace the ! with /
71 (setq file (subst-char-in-string ?! ?/ file))
72 ;; Occurances of // meant there was once a single !.
73 (setq file (replace-regexp-in-string "//" "!" file))
74
75 ;; Handle Windows special cases
76 (when (or (memq system-type '(windows-nt ms-dos)) testmode)
77
78 ;; Handle drive letters from DOSish file names.
79 (when (string-match "^/drive_\\([a-z]\\)/" file)
80 (let ((driveletter (match-string 1 file))
81 )
82 (setq file (concat driveletter ":"
83 (substring file (match-end 1))))))
84
85 ;; Handle the \\file\name nomenclature on some windows boxes.
86 (when (string-match "^!" file)
87 (setq file (concat "//" (substring file 1)))))
88 file))
89
90(provide 'cedet-files)
91
92;;; cedet-files.el ends here
diff --git a/lisp/cedet/cedet-global.el b/lisp/cedet/cedet-global.el
new file mode 100644
index 00000000000..35a963af577
--- /dev/null
+++ b/lisp/cedet/cedet-global.el
@@ -0,0 +1,162 @@
1;;; cedet-global.el --- GNU Global support for CEDET.
2
3;; Copyright (C) 2008, 2009 Free Software Foundation, Inc.
4
5;; Author: Eric M. Ludlam <eric@siege-engine.com>
6
7;; This file is part of GNU Emacs.
8
9;; GNU Emacs is free software: you can redistribute it and/or modify
10;; it under the terms of the GNU General Public License as published by
11;; the Free Software Foundation, either version 3 of the License, or
12;; (at your option) any later version.
13
14;; GNU Emacs is distributed in the hope that it will be useful,
15;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17;; GNU General Public License for more details.
18
19;; You should have received a copy of the GNU General Public License
20;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
21
22;;; Commentary:
23;;
24;; Basic support for calling GNU Global, and testing version numbers.
25
26(declare-function inversion-check-version "inversion")
27
28(defvar cedet-global-min-version "5.0"
29 "Minimum version of GNU global required.")
30
31(defcustom cedet-global-command "global"
32 "Command name for the GNU Global executable."
33 :type 'string
34 :group 'cedet)
35
36;;; Code:
37(defun cedet-gnu-global-search (searchtext texttype type scope)
38 "Perform a search with GNU Global, return the created buffer.
39SEARCHTEXT is text to find.
40TEXTTYPE is the type of text, such as 'regexp, 'string, 'tagname,
41'tagregexp, or 'tagcompletions.
42TYPE is the type of search, meaning that SEARCHTEXT is compared to
43filename, tagname (tags table), references (uses of a tag) , or
44symbol (uses of something not in the tag table.)
45SCOPE is the scope of the search, such as 'project or 'subdirs."
46 (let ((flgs (cond ((eq type 'file)
47 "-a")
48 (t "-xa")))
49 (scopeflgs (cond
50 ((eq scope 'project)
51 ""
52 )
53 ((eq scope 'target)
54 "l")))
55 (stflag (cond ((or (eq texttype 'tagname)
56 (eq texttype 'tagregexp))
57 "")
58 ((eq texttype 'tagcompletions)
59 "c")
60 ((eq texttype 'regexp)
61 "g")
62 (t "r"))))
63 (cedet-gnu-global-call (list (concat flgs scopeflgs stflag)
64 searchtext))))
65
66(defun cedet-gnu-global-call (flags)
67 "Call GNU Global with the list of FLAGS."
68 (let ((b (get-buffer-create "*CEDET Global*"))
69 (cd default-directory))
70 (save-excursion
71 (set-buffer b)
72 (setq default-directory cd)
73 (erase-buffer))
74 (apply 'call-process cedet-global-command
75 nil b nil
76 flags)
77 b))
78
79(defun cedet-gnu-global-expand-filename (filename)
80 "Expand the FILENAME with GNU Global.
81Return a fully qualified filename."
82 (interactive "sFile: ")
83 (let ((ans (save-excursion
84 (set-buffer (cedet-gnu-global-call (list "-Pa" filename)))
85 (goto-char (point-min))
86 (if (looking-at "global: ")
87 (error "GNU Global not available")
88 (split-string (buffer-string) "\n" t)))))
89 (when (interactive-p)
90 (if ans
91 (if (= (length ans) 1)
92 (message "%s" (car ans))
93 (message "%s + %d others" (car ans)
94 (length (cdr ans))))
95 (error "No file found")))
96 ans))
97
98(defun cedet-gnu-global-show-root ()
99 "Show the root of a GNU Global area under the current buffer."
100 (interactive)
101 (message "%s" (cedet-gnu-global-root)))
102
103(defun cedet-gnu-global-root (&optional dir)
104 "Return the root of any GNU Global scanned project.
105If a default starting DIR is not specified, the current buffer's
106`default-directory' is used."
107 (let ((default-directory (or dir default-directory)))
108 (save-excursion
109 (set-buffer (cedet-gnu-global-call (list "-pq")))
110 (goto-char (point-min))
111 (when (not (eobp))
112 (file-name-as-directory
113 (buffer-substring (point) (point-at-eol)))))))
114
115(defun cedet-gnu-global-version-check (&optional noerror)
116 "Check the version of the installed GNU Global command.
117If optional programatic argument NOERROR is non-nil, then
118instead of throwing an error if Global isn't available, then
119return nil."
120 (interactive)
121 (require 'inversion)
122 (let ((b (condition-case nil
123 (cedet-gnu-global-call (list "--version"))
124 (error nil)))
125 (rev nil))
126 (if (not b)
127 (progn
128 (when (interactive-p)
129 (message "GNU Global not found."))
130 nil)
131 (save-excursion
132 (set-buffer b)
133 (goto-char (point-min))
134 (re-search-forward "GNU GLOBAL \\([0-9.]+\\)" nil t)
135 (setq rev (match-string 1))
136 (if (inversion-check-version rev nil cedet-global-min-version)
137 (if noerror
138 nil
139 (error "Version of GNU Global is %s. Need at least %s"
140 rev cedet-global-min-version))
141 ;; Else, return TRUE, as in good enough.
142 (when (interactive-p)
143 (message "GNU Global %s - Good enough for CEDET." rev))
144 t)))))
145
146(defun cedet-gnu-global-scan-hits (buffer)
147 "Scan all the hits from the GNU Global output BUFFER."
148 (let ((hits nil)
149 (r1 "^\\([^ ]+\\) +\\([0-9]+\\) \\([^ ]+\\) "))
150 (save-excursion
151 (set-buffer buffer)
152 (goto-char (point-min))
153 (while (re-search-forward r1 nil t)
154 (setq hits (cons (cons (string-to-number (match-string 2))
155 (match-string 3))
156 hits)))
157 ;; Return the results
158 (nreverse hits))))
159
160(provide 'cedet-global)
161
162;;; cedet-global.el ends here
diff --git a/lisp/cedet/cedet-idutils.el b/lisp/cedet/cedet-idutils.el
new file mode 100644
index 00000000000..3635f7fc8ae
--- /dev/null
+++ b/lisp/cedet/cedet-idutils.el
@@ -0,0 +1,181 @@
1;;; cedet-idutils.el --- ID Utils support for CEDET.
2
3;;; Copyright (C) 2009 Free Software Foundation, Inc.
4
5;; Author: Eric M. Ludlam <eric@siege-engine.com>
6;; Version: 0.2
7;; Keywords: OO, lisp
8
9;; This file is part of GNU Emacs.
10
11;; GNU Emacs is free software: you can redistribute it and/or modify
12;; it under the terms of the GNU General Public License as published by
13;; the Free Software Foundation, either version 3 of the License, or
14;; (at your option) any later version.
15
16;; GNU Emacs is distributed in the hope that it will be useful,
17;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19;; GNU General Public License for more details.
20
21;; You should have received a copy of the GNU General Public License
22;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
23
24;;; Commentary:
25;;
26;; Basic support calling ID Utils functions, and checking version
27;; numbers.
28
29;;; Code:
30
31(declare-function inversion-check-version "inversion")
32
33(defvar cedet-idutils-min-version "4.0"
34 "Minimum version of ID Utils required.")
35
36(defcustom cedet-idutils-file-command "fnid"
37 "Command name for the ID Utils executable for searching file names."
38 :type 'string
39 :group 'cedet)
40
41(defcustom cedet-idutils-token-command "lid"
42 "Command name for the ID Utils executable for searching for tokens."
43 :type 'string
44 :group 'cedet)
45
46(defun cedet-idutils-search (searchtext texttype type scope)
47 "Perform a search with IDUtils, return the created buffer.
48SEARCHTEXT is text to find.
49TEXTTYPE is the type of text, such as 'regexp, 'string, 'tagname,
50'tagregexp, or 'tagcompletions.
51TYPE is the type of search, meaning that SEARCHTEXT is compared to
52filename, tagname (tags table), references (uses of a tag) , or
53symbol (uses of something not in the tag table.)
54SCOPE is the scope of the search, such as 'project or 'subdirs.
55Note: Scope is not yet supported."
56 (if (eq type 'file)
57 ;; Calls for file stuff is very simple.
58 (cedet-idutils-fnid-call (list searchtext))
59 ;; Calls for text searches is more complex.
60 (let* ((resultflg (if (eq texttype 'tagcompletions)
61 (list "--key=token")
62 (list "--result=grep")))
63 (scopeflgs nil) ; (cond ((eq scope 'project) "" ) ((eq scope 'target) "l")))
64 (stflag (cond ((or (eq texttype 'tagname)
65 (eq texttype 'tagregexp))
66 (list "-r" "-w"))
67 ((eq texttype 'tagcompletions)
68 ;; Add regex to search text for beginning of char.
69 (setq searchtext (concat "^" searchtext))
70 (list "-r" "-s" ))
71 ((eq texttype 'regexp)
72 (list "-r"))
73 ;; t means 'symbol
74 (t (list "-l" "-w"))))
75 )
76 (cedet-idutils-lid-call (append resultflg scopeflgs stflag
77 (list searchtext))))))
78
79(defun cedet-idutils-fnid-call (flags)
80 "Call ID Utils fnid with the list of FLAGS.
81Return the created buffer with with program output."
82 (let ((b (get-buffer-create "*CEDET fnid*"))
83 (cd default-directory)
84 )
85 (save-excursion
86 (set-buffer b)
87 (setq default-directory cd)
88 (erase-buffer))
89 (apply 'call-process cedet-idutils-file-command
90 nil b nil
91 flags)
92 b))
93
94(defun cedet-idutils-lid-call (flags)
95 "Call ID Utils lid with the list of FLAGS.
96Return the created buffer with with program output."
97 (let ((b (get-buffer-create "*CEDET lid*"))
98 (cd default-directory)
99 )
100 (save-excursion
101 (set-buffer b)
102 (setq default-directory cd)
103 (erase-buffer))
104 (apply 'call-process cedet-idutils-token-command
105 nil b nil
106 flags)
107 b))
108
109;;; UTIL CALLS
110;;
111(defun cedet-idutils-expand-filename (filename)
112 "Expand the FILENAME with IDUtils.
113Return a filename relative to the default directory."
114 (interactive "sFile: ")
115 (let ((ans (save-excursion
116 (set-buffer (cedet-idutils-fnid-call (list filename)))
117 (goto-char (point-min))
118 (if (looking-at "[^ \n]*fnid: ")
119 (error "ID Utils not available")
120 (split-string (buffer-string) "\n" t)))))
121 (setq ans (mapcar 'expand-file-name ans))
122 (when (interactive-p)
123 (if ans
124 (if (= (length ans) 1)
125 (message "%s" (car ans))
126 (message "%s + %d others" (car ans)
127 (length (cdr ans))))
128 (error "No file found")))
129 ans))
130
131(defun cedet-idutils-support-for-directory (&optional dir)
132 "Return non-nil if IDUtils has a support file for DIR.
133If DIR is not supplied, use the current default directory.
134This works by running lid on a bogus symbol, and looking for
135the error code."
136 (save-excursion
137 (let ((default-directory (or dir default-directory)))
138 (condition-case nil
139 (progn
140 (set-buffer (cedet-idutils-fnid-call '("moose")))
141 (goto-char (point-min))
142 (if (looking-at "[^ \n]*fnid: ")
143 nil
144 t))
145 (error nil)))))
146
147(defun cedet-idutils-version-check (&optional noerror)
148 "Check the version of the installed ID Utils command.
149If optional programatic argument NOERROR is non-nil, then
150instead of throwing an error if Global isn't available, then
151return nil."
152 (interactive)
153 (require 'inversion)
154 (let ((b (condition-case nil
155 (cedet-idutils-fnid-call (list "--version"))
156 (error nil)))
157 (rev nil))
158 (if (not b)
159 (progn
160 (when (interactive-p)
161 (message "ID Utils not found."))
162 nil)
163 (save-excursion
164 (set-buffer b)
165 (goto-char (point-min))
166 (re-search-forward "fnid - \\([0-9.]+\\)" nil t)
167 (setq rev (match-string 1))
168 (if (inversion-check-version rev nil cedet-idutils-min-version)
169 (if noerror
170 nil
171 (error "Version of ID Utis is %s. Need at least %s"
172 rev cedet-idutils-min-version))
173 ;; Else, return TRUE, as in good enough.
174 (when (interactive-p)
175 (message "ID Utils %s - Good enough for CEDET." rev))
176 t)))))
177
178
179(provide 'cedet-idutils)
180
181;;; cedet-idutils.el ends here
diff --git a/lisp/cedet/data-debug.el b/lisp/cedet/data-debug.el
new file mode 100644
index 00000000000..d132e47fc9a
--- /dev/null
+++ b/lisp/cedet/data-debug.el
@@ -0,0 +1,1085 @@
1;;; data-debug.el --- Datastructure Debugger
2
3;; Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc.
4
5;; Author: Eric M. Ludlam <zappo@gnu.org>
6;; Version: 0.2
7;; Keywords: OO, lisp
8
9;; This file is part of GNU Emacs.
10
11;; GNU Emacs is free software: you can redistribute it and/or modify
12;; it under the terms of the GNU General Public License as published by
13;; the Free Software Foundation, either version 3 of the License, or
14;; (at your option) any later version.
15
16;; GNU Emacs is distributed in the hope that it will be useful,
17;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19;; GNU General Public License for more details.
20
21;; You should have received a copy of the GNU General Public License
22;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
23
24;;; Commentary:
25;;
26;; Provide a simple way to investigate particularly large and complex
27;; data structures.
28;;
29;; The best way to get started is to bind M-: to 'data-debug-eval-expression.
30;;
31;; (global-set-key "\M-:" 'data-debug-eval-expression)
32;;
33;; If you write functions with complex output that need debugging, you
34;; can make them interactive with data-debug-show-stuff. For example:
35;;
36;; (defun my-complex-output-fcn ()
37;; "Calculate something complicated at point, and return it."
38;; (interactive) ;; function not normally interactive
39;; (let ((stuff (do-stuff)))
40;; (when (interactive-p)
41;; (data-debug-show-stuff stuff "myStuff"))
42;; stuff))
43
44(require 'font-lock)
45(require 'ring)
46
47;;; Code:
48
49;;; Compatibility
50;;
51(if (featurep 'xemacs)
52 (eval-and-compile
53 (defalias 'data-debug-overlay-properties 'extent-properties)
54 (defalias 'data-debug-overlay-p 'extentp)
55 (if (not (fboundp 'propertize))
56 (defun dd-propertize (string &rest properties)
57 "Mimic 'propertize' in from Emacs 23."
58 (add-text-properties 0 (length string) properties string)
59 string
60 )
61 (defalias 'dd-propertize 'propertize))
62 )
63 ;; Regular Emacs
64 (eval-and-compile
65 (defalias 'data-debug-overlay-properties 'overlay-properties)
66 (defalias 'data-debug-overlay-p 'overlayp)
67 (defalias 'dd-propertize 'propertize)
68 )
69 )
70
71;;; GENERIC STUFF
72;;
73(defun data-debug-insert-property-list (proplist prefix &optional parent)
74 "Insert the property list PROPLIST.
75Each line starts with PREFIX.
76The attributes belong to the tag PARENT."
77 (while proplist
78 (let ((pretext (concat (symbol-name (car proplist)) " : ")))
79 (data-debug-insert-thing (car (cdr proplist))
80 prefix
81 pretext
82 parent))
83 (setq proplist (cdr (cdr proplist)))))
84
85;;; overlays
86;;
87(defun data-debug-insert-overlay-props (overlay prefix)
88 "Insert all the parts of OVERLAY.
89PREFIX specifies what to insert at the start of each line."
90 (let ((attrprefix (concat (make-string (length prefix) ? ) "# "))
91 (proplist (data-debug-overlay-properties overlay)))
92 (data-debug-insert-property-list
93 proplist attrprefix)
94 )
95 )
96
97(defun data-debug-insert-overlay-from-point (point)
98 "Insert the overlay found at the overlay button at POINT."
99 (let ((overlay (get-text-property point 'ddebug))
100 (indent (get-text-property point 'ddebug-indent))
101 start
102 )
103 (end-of-line)
104 (setq start (point))
105 (forward-char 1)
106 (data-debug-insert-overlay-props overlay
107 (concat (make-string indent ? )
108 "| "))
109 (goto-char start)
110 ))
111
112(defun data-debug-insert-overlay-button (overlay prefix prebuttontext)
113 "Insert a button representing OVERLAY.
114PREFIX is the text that preceeds the button.
115PREBUTTONTEXT is some text between prefix and the overlay button."
116 (let ((start (point))
117 (end nil)
118 (str (format "%s" overlay))
119 (tip nil))
120 (insert prefix prebuttontext str)
121 (setq end (point))
122 (put-text-property (- end (length str)) end 'face 'font-lock-comment-face)
123 (put-text-property start end 'ddebug overlay)
124 (put-text-property start end 'ddebug-indent(length prefix))
125 (put-text-property start end 'ddebug-prefix prefix)
126 (put-text-property start end 'help-echo tip)
127 (put-text-property start end 'ddebug-function
128 'data-debug-insert-overlay-from-point)
129 (insert "\n")
130 )
131 )
132
133;;; overlay list
134;;
135(defun data-debug-insert-overlay-list (overlaylist prefix)
136 "Insert all the parts of OVERLAYLIST.
137PREFIX specifies what to insert at the start of each line."
138 (while overlaylist
139 (data-debug-insert-overlay-button (car overlaylist)
140 prefix
141 "")
142 (setq overlaylist (cdr overlaylist))))
143
144(defun data-debug-insert-overlay-list-from-point (point)
145 "Insert the overlay found at the overlay list button at POINT."
146 (let ((overlaylist (get-text-property point 'ddebug))
147 (indent (get-text-property point 'ddebug-indent))
148 start
149 )
150 (end-of-line)
151 (setq start (point))
152 (forward-char 1)
153 (data-debug-insert-overlay-list overlaylist
154 (concat (make-string indent ? )
155 "* "))
156 (goto-char start)
157 ))
158
159(defun data-debug-insert-overlay-list-button (overlaylist
160 prefix
161 prebuttontext)
162 "Insert a button representing OVERLAYLIST.
163PREFIX is the text that preceeds the button.
164PREBUTTONTEXT is some text between prefix and the overlay list button."
165 (let ((start (point))
166 (end nil)
167 (str (format "#<overlay list: %d entries>" (length overlaylist)))
168 (tip nil))
169 (insert prefix prebuttontext str)
170 (setq end (point))
171 (put-text-property (- end (length str)) end 'face 'font-lock-comment-face)
172 (put-text-property start end 'ddebug overlaylist)
173 (put-text-property start end 'ddebug-indent(length prefix))
174 (put-text-property start end 'ddebug-prefix prefix)
175 (put-text-property start end 'help-echo tip)
176 (put-text-property start end 'ddebug-function
177 'data-debug-insert-overlay-list-from-point)
178 (insert "\n")
179 )
180 )
181
182;;; buffers
183;;
184(defun data-debug-insert-buffer-props (buffer prefix)
185 "Insert all the parts of BUFFER.
186PREFIX specifies what to insert at the start of each line."
187 (let ((attrprefix (concat (make-string (length prefix) ? ) "# "))
188 (proplist
189 (list :filename (buffer-file-name buffer)
190 :live (buffer-live-p buffer)
191 :modified (buffer-modified-p buffer)
192 :size (buffer-size buffer)
193 :process (get-buffer-process buffer)
194 :localvars (buffer-local-variables buffer)
195 )))
196 (data-debug-insert-property-list
197 proplist attrprefix)
198 )
199 )
200
201(defun data-debug-insert-buffer-from-point (point)
202 "Insert the buffer found at the buffer button at POINT."
203 (let ((buffer (get-text-property point 'ddebug))
204 (indent (get-text-property point 'ddebug-indent))
205 start
206 )
207 (end-of-line)
208 (setq start (point))
209 (forward-char 1)
210 (data-debug-insert-buffer-props buffer
211 (concat (make-string indent ? )
212 "| "))
213 (goto-char start)
214 ))
215
216(defun data-debug-insert-buffer-button (buffer prefix prebuttontext)
217 "Insert a button representing BUFFER.
218PREFIX is the text that preceeds the button.
219PREBUTTONTEXT is some text between prefix and the buffer button."
220 (let ((start (point))
221 (end nil)
222 (str (format "%S" buffer))
223 (tip nil))
224 (insert prefix prebuttontext str)
225 (setq end (point))
226 (put-text-property (- end (length str)) end 'face 'font-lock-comment-face)
227 (put-text-property start end 'ddebug buffer)
228 (put-text-property start end 'ddebug-indent(length prefix))
229 (put-text-property start end 'ddebug-prefix prefix)
230 (put-text-property start end 'help-echo tip)
231 (put-text-property start end 'ddebug-function
232 'data-debug-insert-buffer-from-point)
233 (insert "\n")
234 )
235 )
236
237;;; buffer list
238;;
239(defun data-debug-insert-buffer-list (bufferlist prefix)
240 "Insert all the parts of BUFFERLIST.
241PREFIX specifies what to insert at the start of each line."
242 (while bufferlist
243 (data-debug-insert-buffer-button (car bufferlist)
244 prefix
245 "")
246 (setq bufferlist (cdr bufferlist))))
247
248(defun data-debug-insert-buffer-list-from-point (point)
249 "Insert the buffer found at the buffer list button at POINT."
250 (let ((bufferlist (get-text-property point 'ddebug))
251 (indent (get-text-property point 'ddebug-indent))
252 start
253 )
254 (end-of-line)
255 (setq start (point))
256 (forward-char 1)
257 (data-debug-insert-buffer-list bufferlist
258 (concat (make-string indent ? )
259 "* "))
260 (goto-char start)
261 ))
262
263(defun data-debug-insert-buffer-list-button (bufferlist
264 prefix
265 prebuttontext)
266 "Insert a button representing BUFFERLIST.
267PREFIX is the text that preceeds the button.
268PREBUTTONTEXT is some text between prefix and the buffer list button."
269 (let ((start (point))
270 (end nil)
271 (str (format "#<buffer list: %d entries>" (length bufferlist)))
272 (tip nil))
273 (insert prefix prebuttontext str)
274 (setq end (point))
275 (put-text-property (- end (length str)) end 'face 'font-lock-comment-face)
276 (put-text-property start end 'ddebug bufferlist)
277 (put-text-property start end 'ddebug-indent(length prefix))
278 (put-text-property start end 'ddebug-prefix prefix)
279 (put-text-property start end 'help-echo tip)
280 (put-text-property start end 'ddebug-function
281 'data-debug-insert-buffer-list-from-point)
282 (insert "\n")
283 )
284 )
285
286;;; processes
287;;
288(defun data-debug-insert-process-props (process prefix)
289 "Insert all the parts of PROCESS.
290PREFIX specifies what to insert at the start of each line."
291 (let ((attrprefix (concat (make-string (length prefix) ? ) "# "))
292 (id (process-id process))
293 (tty (process-tty-name process))
294 (pcontact (process-contact process t))
295 (proplist (process-plist process)))
296 (data-debug-insert-property-list
297 (append
298 (if id (list 'id id))
299 (if tty (list 'tty tty))
300 (if pcontact pcontact)
301 proplist)
302 attrprefix)
303 )
304 )
305
306(defun data-debug-insert-process-from-point (point)
307 "Insert the process found at the process button at POINT."
308 (let ((process (get-text-property point 'ddebug))
309 (indent (get-text-property point 'ddebug-indent))
310 start
311 )
312 (end-of-line)
313 (setq start (point))
314 (forward-char 1)
315 (data-debug-insert-process-props process
316 (concat (make-string indent ? )
317 "| "))
318 (goto-char start)
319 ))
320
321(defun data-debug-insert-process-button (process prefix prebuttontext)
322 "Insert a button representing PROCESS.
323PREFIX is the text that preceeds the button.
324PREBUTTONTEXT is some text between prefix and the process button."
325 (let ((start (point))
326 (end nil)
327 (str (format "%S : %s" process (process-status process)))
328 (tip nil))
329 (insert prefix prebuttontext str)
330 (setq end (point))
331 (put-text-property (- end (length str)) end 'face 'font-lock-comment-face)
332 (put-text-property start end 'ddebug process)
333 (put-text-property start end 'ddebug-indent(length prefix))
334 (put-text-property start end 'ddebug-prefix prefix)
335 (put-text-property start end 'help-echo tip)
336 (put-text-property start end 'ddebug-function
337 'data-debug-insert-process-from-point)
338 (insert "\n")
339 )
340 )
341
342;;; Rings
343;;
344;; A ring (like kill-ring, or whatever.)
345(defun data-debug-insert-ring-contents (ring prefix)
346 "Insert all the parts of RING.
347PREFIX specifies what to insert at the start of each line."
348 (let ((len (ring-length ring))
349 (idx 0)
350 )
351 (while (< idx len)
352 (data-debug-insert-thing (ring-ref ring idx) prefix "")
353 (setq idx (1+ idx))
354 )))
355
356(defun data-debug-insert-ring-items-from-point (point)
357 "Insert the ring found at the ring button at POINT."
358 (let ((ring (get-text-property point 'ddebug))
359 (indent (get-text-property point 'ddebug-indent))
360 start
361 )
362 (end-of-line)
363 (setq start (point))
364 (forward-char 1)
365 (data-debug-insert-ring-contents ring
366 (concat (make-string indent ? )
367 "} "))
368 (goto-char start)
369 ))
370
371(defun data-debug-insert-ring-button (ring
372 prefix
373 prebuttontext)
374 "Insert a button representing RING.
375PREFIX is the text that preceeds the button.
376PREBUTTONTEXT is some text between prefix and the stuff list button."
377 (let* ((start (point))
378 (end nil)
379 (str (format "#<RING: %d, %d max>"
380 (ring-length ring)
381 (ring-size ring)))
382 (ringthing
383 (if (= (ring-length ring) 0) nil (ring-ref ring 0)))
384 (tip (format "Ring max-size %d, length %d."
385 (ring-size ring)
386 (ring-length ring)))
387 )
388 (insert prefix prebuttontext str)
389 (setq end (point))
390 (put-text-property (- end (length str)) end 'face 'font-lock-type-face)
391 (put-text-property start end 'ddebug ring)
392 (put-text-property start end 'ddebug-indent(length prefix))
393 (put-text-property start end 'ddebug-prefix prefix)
394 (put-text-property start end 'help-echo tip)
395 (put-text-property start end 'ddebug-function
396 'data-debug-insert-ring-items-from-point)
397 (insert "\n")
398 )
399 )
400
401
402;;; Hash-table
403;;
404
405(defun data-debug-insert-hash-table (hash-table prefix)
406 "Insert the contents of HASH-TABLE inserting PREFIX before each element."
407 (maphash
408 (lambda (key value)
409 (data-debug-insert-thing
410 key prefix
411 (dd-propertize "key " 'face font-lock-comment-face))
412 (data-debug-insert-thing
413 value prefix
414 (dd-propertize "val " 'face font-lock-comment-face)))
415 hash-table))
416
417(defun data-debug-insert-hash-table-from-point (point)
418 "Insert the contents of the hash-table button at POINT."
419 (let ((hash-table (get-text-property point 'ddebug))
420 (indent (get-text-property point 'ddebug-indent))
421 start)
422 (end-of-line)
423 (setq start (point))
424 (forward-char 1)
425 (data-debug-insert-hash-table
426 hash-table
427 (concat (make-string indent ? ) "> "))
428 (goto-char start))
429 )
430
431(defun data-debug-insert-hash-table-button (hash-table prefix prebuttontext)
432 "Insert HASH-TABLE as expandable button with recursive prefix PREFIX and PREBUTTONTEXT in front of the button text."
433 (let ((string (dd-propertize (format "%s" hash-table)
434 'face 'font-lock-keyword-face)))
435 (insert (dd-propertize
436 (concat prefix prebuttontext string)
437 'ddebug hash-table
438 'ddebug-indent (length prefix)
439 'ddebug-prefix prefix
440 'help-echo
441 (format "Hash-table\nTest: %s\nWeakness: %s\nElements: %d (of %d)"
442 (hash-table-test hash-table)
443 (if (hash-table-weakness hash-table) "yes" "no")
444 (hash-table-count hash-table)
445 (hash-table-size hash-table))
446 'ddebug-function
447 'data-debug-insert-hash-table-from-point)
448 "\n"))
449 )
450
451;;; Widget
452;;
453;; Widgets have a long list of properties
454(defun data-debug-insert-widget-properties (widget prefix)
455 "Insert the contents of WIDGET inserting PREFIX before each element."
456 (let ((type (car widget))
457 (rest (cdr widget)))
458 (while rest
459 (data-debug-insert-thing (car (cdr rest))
460 prefix
461 (concat
462 (dd-propertize (format "%s" (car rest))
463 'face font-lock-comment-face)
464 " : "))
465 (setq rest (cdr (cdr rest))))
466 ))
467
468(defun data-debug-insert-widget-from-point (point)
469 "Insert the contents of the widget button at POINT."
470 (let ((widget (get-text-property point 'ddebug))
471 (indent (get-text-property point 'ddebug-indent))
472 start)
473 (end-of-line)
474 (setq start (point))
475 (forward-char 1)
476 (data-debug-insert-widget-properties
477 widget (concat (make-string indent ? ) "# "))
478 (goto-char start))
479 )
480
481(defun data-debug-insert-widget (widget prefix prebuttontext)
482 "Insert one WIDGET.
483A Symbol is a simple thing, but this provides some face and prefix rules.
484PREFIX is the text that preceeds the button.
485PREBUTTONTEXT is some text between prefix and the thing."
486 (let ((string (dd-propertize (format "#<WIDGET %s>" (car widget))
487 'face 'font-lock-keyword-face)))
488 (insert (dd-propertize
489 (concat prefix prebuttontext string)
490 'ddebug widget
491 'ddebug-indent (length prefix)
492 'ddebug-prefix prefix
493 'help-echo
494 (format "Widget\nType: %s\n# Properties: %d"
495 (car widget)
496 (/ (1- (length widget)) 2))
497 'ddebug-function
498 'data-debug-insert-widget-from-point)
499 "\n")))
500
501;;; list of stuff
502;;
503;; just a list. random stuff inside.
504(defun data-debug-insert-stuff-list (stufflist prefix)
505 "Insert all the parts of STUFFLIST.
506PREFIX specifies what to insert at the start of each line."
507 (while stufflist
508 (data-debug-insert-thing
509 ;; Some lists may put a value in the CDR
510 (if (listp stufflist) (car stufflist) stufflist)
511 prefix
512 "")
513 (setq stufflist
514 (if (listp stufflist)
515 (cdr-safe stufflist)
516 nil))))
517
518(defun data-debug-insert-stuff-list-from-point (point)
519 "Insert the stuff found at the stuff list button at POINT."
520 (let ((stufflist (get-text-property point 'ddebug))
521 (indent (get-text-property point 'ddebug-indent))
522 start
523 )
524 (end-of-line)
525 (setq start (point))
526 (forward-char 1)
527 (data-debug-insert-stuff-list stufflist
528 (concat (make-string indent ? )
529 "> "))
530 (goto-char start)
531 ))
532
533(defun data-debug-insert-stuff-list-button (stufflist
534 prefix
535 prebuttontext)
536 "Insert a button representing STUFFLIST.
537PREFIX is the text that preceeds the button.
538PREBUTTONTEXT is some text between prefix and the stuff list button."
539 (let ((start (point))
540 (end nil)
541 (str
542 (condition-case nil
543 (format "#<list o' stuff: %d entries>" (safe-length stufflist))
544 (error "#<list o' stuff>")))
545 (tip (if (or (listp (car stufflist))
546 (vectorp (car stufflist)))
547 ""
548 (format "%s" stufflist))))
549 (insert prefix prebuttontext str)
550 (setq end (point))
551 (put-text-property (- end (length str)) end 'face 'font-lock-variable-name-face)
552 (put-text-property start end 'ddebug stufflist)
553 (put-text-property start end 'ddebug-indent (length prefix))
554 (put-text-property start end 'ddebug-prefix prefix)
555 (put-text-property start end 'help-echo tip)
556 (put-text-property start end 'ddebug-function
557 'data-debug-insert-stuff-list-from-point)
558 (insert "\n")
559 )
560 )
561
562;;; vector of stuff
563;;
564;; just a vector. random stuff inside.
565(defun data-debug-insert-stuff-vector (stuffvector prefix)
566 "Insert all the parts of STUFFVECTOR.
567PREFIX specifies what to insert at the start of each line."
568 (let ((idx 0))
569 (while (< idx (length stuffvector))
570 (data-debug-insert-thing
571 ;; Some vectors may put a value in the CDR
572 (aref stuffvector idx)
573 prefix
574 "")
575 (setq idx (1+ idx)))))
576
577(defun data-debug-insert-stuff-vector-from-point (point)
578 "Insert the stuff found at the stuff vector button at POINT."
579 (let ((stuffvector (get-text-property point 'ddebug))
580 (indent (get-text-property point 'ddebug-indent))
581 start
582 )
583 (end-of-line)
584 (setq start (point))
585 (forward-char 1)
586 (data-debug-insert-stuff-vector stuffvector
587 (concat (make-string indent ? )
588 "[ "))
589 (goto-char start)
590 ))
591
592(defun data-debug-insert-stuff-vector-button (stuffvector
593 prefix
594 prebuttontext)
595 "Insert a button representing STUFFVECTOR.
596PREFIX is the text that preceeds the button.
597PREBUTTONTEXT is some text between prefix and the stuff vector button."
598 (let* ((start (point))
599 (end nil)
600 (str (format "#<vector o' stuff: %d entries>" (length stuffvector)))
601 (tip str))
602 (insert prefix prebuttontext str)
603 (setq end (point))
604 (put-text-property (- end (length str)) end 'face 'font-lock-variable-name-face)
605 (put-text-property start end 'ddebug stuffvector)
606 (put-text-property start end 'ddebug-indent (length prefix))
607 (put-text-property start end 'ddebug-prefix prefix)
608 (put-text-property start end 'help-echo tip)
609 (put-text-property start end 'ddebug-function
610 'data-debug-insert-stuff-vector-from-point)
611 (insert "\n")
612 )
613 )
614
615;;; Symbol
616;;
617
618(defun data-debug-insert-symbol-from-point (point)
619 "Insert attached properties and possibly the value of symbol at POINT."
620 (let ((symbol (get-text-property point 'ddebug))
621 (indent (get-text-property point 'ddebug-indent))
622 start)
623 (end-of-line)
624 (setq start (point))
625 (forward-char 1)
626 (when (and (not (fboundp symbol)) (boundp symbol))
627 (data-debug-insert-thing
628 (symbol-value symbol)
629 (concat (make-string indent ? ) "> ")
630 (concat
631 (dd-propertize "value"
632 'face 'font-lock-comment-face)
633 " ")))
634 (data-debug-insert-property-list
635 (symbol-plist symbol)
636 (concat (make-string indent ? ) "> "))
637 (goto-char start))
638 )
639
640(defun data-debug-insert-symbol-button (symbol prefix prebuttontext)
641 "Insert a button representing SYMBOL.
642 PREFIX is the text that preceeds the button.
643 PREBUTTONTEXT is some text between prefix and the symbol button."
644 (let ((string
645 (cond ((fboundp symbol)
646 (dd-propertize (concat "#'" (symbol-name symbol))
647 'face 'font-lock-function-name-face))
648 ((boundp symbol)
649 (dd-propertize (concat "'" (symbol-name symbol))
650 'face 'font-lock-variable-name-face))
651 (t (format "'%s" symbol)))))
652 (insert (dd-propertize
653 (concat prefix prebuttontext string)
654 'ddebug symbol
655 'ddebug-indent (length prefix)
656 'ddebug-prefix prefix
657 'help-echo ""
658 'ddebug-function
659 'data-debug-insert-symbol-from-point)
660 "\n"))
661 )
662
663;;; String
664(defun data-debug-insert-string (thing prefix prebuttontext)
665 "Insert one symbol THING.
666A Symbol is a simple thing, but this provides some face and prefix rules.
667PREFIX is the text that preceeds the button.
668PREBUTTONTEXT is some text between prefix and the thing."
669 (let ((newstr thing))
670 (while (string-match "\n" newstr)
671 (setq newstr (replace-match "\\n" t t newstr)))
672 (while (string-match "\t" newstr)
673 (setq newstr (replace-match "\\t" t t newstr)))
674 (insert prefix prebuttontext
675 (dd-propertize (format "\"%s\"" newstr)
676 'face font-lock-string-face)
677 "\n" )))
678
679;;; Number
680(defun data-debug-insert-number (thing prefix prebuttontext)
681 "Insert one symbol THING.
682A Symbol is a simple thing, but this provides some face and prefix rules.
683PREFIX is the text that preceeds the button.
684PREBUTTONTEXT is some text between prefix and the thing."
685 (insert prefix prebuttontext
686 (dd-propertize (format "%S" thing)
687 'face font-lock-string-face)
688 "\n"))
689
690;;; Lambda Expression
691(defun data-debug-insert-lambda-expression (thing prefix prebuttontext)
692 "Insert one lambda expression THING.
693A Symbol is a simple thing, but this provides some face and prefix rules.
694PREFIX is the text that preceeds the button.
695PREBUTTONTEXT is some text between prefix and the thing."
696 (let ((txt (prin1-to-string thing)))
697 (data-debug-insert-simple-thing
698 txt prefix prebuttontext 'font-lock-keyword-face))
699 )
700
701;;; nil thing
702(defun data-debug-insert-nil (thing prefix prebuttontext)
703 "Insert one simple THING with a face.
704PREFIX is the text that preceeds the button.
705PREBUTTONTEXT is some text between prefix and the thing.
706FACE is the face to use."
707 (insert prefix prebuttontext)
708 (insert ": ")
709 (let ((start (point))
710 (end nil))
711 (insert "nil")
712 (setq end (point))
713 (insert "\n" )
714 (put-text-property start end 'face 'font-lock-variable-name-face)
715 ))
716
717;;; simple thing
718(defun data-debug-insert-simple-thing (thing prefix prebuttontext face)
719 "Insert one simple THING with a face.
720PREFIX is the text that preceeds the button.
721PREBUTTONTEXT is some text between prefix and the thing.
722FACE is the face to use."
723 (insert prefix prebuttontext)
724 (let ((start (point))
725 (end nil))
726 (insert (format "%s" thing))
727 (setq end (point))
728 (insert "\n" )
729 (put-text-property start end 'face face)
730 ))
731
732;;; custom thing
733(defun data-debug-insert-custom (thingstring prefix prebuttontext face)
734 "Insert one simple THINGSTRING with a face.
735Use for simple items that need a custom insert.
736PREFIX is the text that preceeds the button.
737PREBUTTONTEXT is some text between prefix and the thing.
738FACE is the face to use."
739 (insert prefix prebuttontext)
740 (let ((start (point))
741 (end nil))
742 (insert thingstring)
743 (setq end (point))
744 (insert "\n" )
745 (put-text-property start end 'face face)
746 ))
747
748
749(defvar data-debug-thing-alist
750 '(
751 ;; nil
752 (null . data-debug-insert-nil)
753
754 ;; Overlay
755 (data-debug-overlay-p . data-debug-insert-overlay-button)
756
757 ;; Overlay list
758 ((lambda (thing) (and (consp thing) (data-debug-overlay-p (car thing)))) .
759 data-debug-insert-overlay-list-button)
760
761 ;; Buffer
762 (bufferp . data-debug-insert-buffer-button)
763
764 ;; Buffer list
765 ((lambda (thing) (and (consp thing) (bufferp (car thing)))) .
766 data-debug-insert-buffer-list-button)
767
768 ;; Process
769 (processp . data-debug-insert-process-button)
770
771 ;; String
772 (stringp . data-debug-insert-string)
773
774 ;; Number
775 (numberp . data-debug-insert-number)
776
777 ;; Symbol
778 (symbolp . data-debug-insert-symbol-button)
779
780 ;; Ring
781 (ring-p . data-debug-insert-ring-button)
782
783 ;; Lambda Expression
784 ((lambda (thing) (and (consp thing) (eq (car thing) 'lambda))) .
785 data-debug-insert-lambda-expression)
786
787 ;; Hash-table
788 (hash-table-p . data-debug-insert-hash-table-button)
789
790 ;; Widgets
791 (widgetp . data-debug-insert-widget)
792
793 ;; List of stuff
794 (listp . data-debug-insert-stuff-list-button)
795
796 ;; Vector of stuff
797 (vectorp . data-debug-insert-stuff-vector-button)
798 )
799 "Alist of methods used to insert things into an Ddebug buffer.")
800
801;; An augmentation function for the thing alist.
802(defun data-debug-add-specialized-thing (predicate fcn)
803 "Add a new specialized thing to display with data-debug.
804PREDICATE is a function that returns t if a thing is this new type.
805FCN is a function that will display stuff in the data debug buffer."
806 (let ((entry (cons predicate fcn))
807 ;; Specialized entries show up AFTER nil,
808 ;; but before listp, vectorp, symbolp, and
809 ;; other general things. Splice it into
810 ;; the beginning.
811 (first (nthcdr 0 data-debug-thing-alist))
812 (second (nthcdr 1 data-debug-thing-alist))
813 )
814 (when (not (member entry data-debug-thing-alist))
815 (setcdr first (cons entry second)))))
816
817;; uber insert method
818(defun data-debug-insert-thing (thing prefix prebuttontext &optional parent)
819 "Insert THING with PREFIX.
820PREBUTTONTEXT is some text to insert between prefix and the thing
821that is not included in the indentation calculation of any children.
822If PARENT is non-nil, it is somehow related as a parent to thing."
823 (when (catch 'done
824 (dolist (test data-debug-thing-alist)
825 (when (funcall (car test) thing)
826 (condition-case nil
827 (funcall (cdr test) thing prefix prebuttontext parent)
828 (error
829 (funcall (cdr test) thing prefix prebuttontext)))
830 (throw 'done nil))
831 )
832 nil)
833 (data-debug-insert-simple-thing (format "%S" thing)
834 prefix
835 prebuttontext
836 'bold)))
837
838;;; MAJOR MODE
839;;
840;; The Ddebug major mode provides an interactive space to explore
841;; complicated data structures.
842;;
843(defgroup data-debug nil
844 "data-debug group."
845 :group 'langauges)
846
847(defvar data-debug-mode-syntax-table
848 (let ((table (make-syntax-table (standard-syntax-table))))
849 (modify-syntax-entry ?\; ". 12" table) ;; SEMI, Comment start ;;
850 (modify-syntax-entry ?\n ">" table) ;; Comment end
851 (modify-syntax-entry ?\" "\"" table) ;; String
852 (modify-syntax-entry ?\- "_" table) ;; Symbol
853 (modify-syntax-entry ?\\ "\\" table) ;; Quote
854 (modify-syntax-entry ?\` "'" table) ;; Prefix ` (backquote)
855 (modify-syntax-entry ?\' "'" table) ;; Prefix ' (quote)
856 (modify-syntax-entry ?\, "'" table) ;; Prefix , (comma)
857
858 table)
859 "Syntax table used in data-debug macro buffers.")
860
861(defvar data-debug-map
862 (let ((km (make-sparse-keymap)))
863 (define-key km [mouse-2] 'data-debug-expand-or-contract-mouse)
864 (define-key km " " 'data-debug-expand-or-contract)
865 (define-key km "\C-m" 'data-debug-expand-or-contract)
866 (define-key km "n" 'data-debug-next)
867 (define-key km "p" 'data-debug-prev)
868 (define-key km "N" 'data-debug-next-expando)
869 (define-key km "P" 'data-debug-prev-expando)
870 km)
871 "Keymap used in data-debug.")
872
873(defcustom data-debug-mode-hook nil
874 "*Hook run when data-debug starts."
875 :group 'data-debug
876 :type 'hook)
877
878(defun data-debug-mode ()
879 "Major-mode for the Analyzer debugger.
880
881\\{data-debug-map}"
882 (interactive)
883 (kill-all-local-variables)
884 (setq major-mode 'data-debug-mode
885 mode-name "DATA-DEBUG"
886 comment-start ";;"
887 comment-end "")
888 (set (make-local-variable 'comment-start-skip)
889 "\\(\\(^\\|[^\\\\\n]\\)\\(\\\\\\\\\\)*\\);+ *")
890 (set-syntax-table data-debug-mode-syntax-table)
891 (use-local-map data-debug-map)
892 (run-hooks 'data-debug-hook)
893 (buffer-disable-undo)
894 (set (make-local-variable 'font-lock-global-modes) nil)
895 (font-lock-mode -1)
896 )
897
898;;;###autoload
899(defun data-debug-new-buffer (name)
900 "Create a new data-debug buffer with NAME."
901 (let ((b (get-buffer-create name)))
902 (pop-to-buffer b)
903 (set-buffer b)
904 (erase-buffer)
905 (data-debug-mode)
906 b))
907
908;;; Ddebug mode commands
909;;
910(defun data-debug-next ()
911 "Go to the next line in the Ddebug buffer."
912 (interactive)
913 (forward-line 1)
914 (beginning-of-line)
915 (skip-chars-forward " *-><[]" (point-at-eol)))
916
917(defun data-debug-prev ()
918 "Go to the next line in the Ddebug buffer."
919 (interactive)
920 (forward-line -1)
921 (beginning-of-line)
922 (skip-chars-forward " *-><[]" (point-at-eol)))
923
924(defun data-debug-next-expando ()
925 "Go to the next line in the Ddebug buffer.
926Contract the current line (if open) and expand the line
927we move to."
928 (interactive)
929 (data-debug-contract-current-line)
930 (data-debug-next)
931 (data-debug-expand-current-line)
932 )
933
934(defun data-debug-prev-expando ()
935 "Go to the previous line in the Ddebug buffer.
936Contract the current line (if open) and expand the line
937we move to."
938 (interactive)
939 (data-debug-contract-current-line)
940 (data-debug-prev)
941 (data-debug-expand-current-line)
942 )
943
944(defun data-debug-current-line-expanded-p ()
945 "Return non-nil if the current line is expanded."
946 (let ((ti (current-indentation))
947 (ni (condition-case nil
948 (save-excursion
949 (end-of-line)
950 (forward-char 1)
951 (current-indentation))
952 (error 0))))
953 (> ni ti)))
954
955(defun data-debug-line-expandable-p ()
956 "Return non-nil if the current line is expandable.
957Lines that are not expandable are assumed to not be contractable."
958 (not (get-text-property (point) 'ddebug-noexpand)))
959
960(defun data-debug-expand-current-line ()
961 "Expand the current line (if possible).
962Do nothing if already expanded."
963 (when (or (not (data-debug-line-expandable-p))
964 (not (data-debug-current-line-expanded-p)))
965 ;; If the next line is the same or less indentation, expand.
966 (let ((fcn (get-text-property (point) 'ddebug-function)))
967 (when fcn
968 (funcall fcn (point))
969 (beginning-of-line)
970 ))))
971
972(defun data-debug-contract-current-line ()
973 "Contract the current line (if possible).
974Do nothing if already expanded."
975 (when (and (data-debug-current-line-expanded-p)
976 ;; Don't contract if the current line is not expandable.
977 (get-text-property (point) 'ddebug-function))
978 (let ((ti (current-indentation))
979 )
980 ;; If next indentation is larger, collapse.
981 (end-of-line)
982 (forward-char 1)
983 (let ((start (point))
984 (end nil))
985 (condition-case nil
986 (progn
987 ;; Keep checking indentation
988 (while (or (> (current-indentation) ti)
989 (looking-at "^\\s-*$"))
990 (end-of-line)
991 (forward-char 1))
992 (setq end (point))
993 )
994 (error (setq end (point-max))))
995 (delete-region start end)
996 (forward-char -1)
997 (beginning-of-line)))))
998
999(defun data-debug-expand-or-contract ()
1000 "Expand or contract anything at the current point."
1001 (interactive)
1002 (if (and (data-debug-line-expandable-p)
1003 (data-debug-current-line-expanded-p))
1004 (data-debug-contract-current-line)
1005 (data-debug-expand-current-line))
1006 (skip-chars-forward " *-><[]" (point-at-eol)))
1007
1008(defun data-debug-expand-or-contract-mouse (event)
1009 "Expand or contract anything at event EVENT."
1010 (interactive "e")
1011 (let* ((win (car (car (cdr event))))
1012 )
1013 (select-window win t)
1014 (save-excursion
1015 ;(goto-char (window-start win))
1016 (mouse-set-point event)
1017 (data-debug-expand-or-contract))
1018 ))
1019
1020;;; GENERIC STRUCTURE DUMP
1021;;
1022(defun data-debug-show-stuff (stuff name)
1023 "Data debug STUFF in a buffer named *NAME DDebug*."
1024 (data-debug-new-buffer (concat "*" name " DDebug*"))
1025 (data-debug-insert-thing stuff "?" "")
1026 (goto-char (point-min))
1027 (when (data-debug-line-expandable-p)
1028 (data-debug-expand-current-line)))
1029
1030;;; DEBUG COMMANDS
1031;;
1032;; Various commands for displaying complex data structures.
1033
1034(defun data-debug-edebug-expr (expr)
1035 "Dump out the contets of some expression EXPR in edebug with ddebug."
1036 (interactive
1037 (list (let ((minibuffer-completing-symbol t))
1038 (read-from-minibuffer "Eval: "
1039 nil read-expression-map t
1040 'read-expression-history))
1041 ))
1042 (let ((v (eval expr)))
1043 (if (not v)
1044 (message "Expression %s is nil." expr)
1045 (data-debug-show-stuff v "expression"))))
1046
1047(defun data-debug-eval-expression (expr)
1048 "Evaluate EXPR and display the value.
1049If the result is something simple, show it in the echo area.
1050If the result is a list or vector, then use the data debugger to display it."
1051 (interactive
1052 (list (let ((minibuffer-completing-symbol t))
1053 (read-from-minibuffer "Eval: "
1054 nil read-expression-map t
1055 'read-expression-history))
1056 ))
1057
1058 (if (null eval-expression-debug-on-error)
1059 (setq values (cons (eval expr) values))
1060 (let ((old-value (make-symbol "t")) new-value)
1061 ;; Bind debug-on-error to something unique so that we can
1062 ;; detect when evaled code changes it.
1063 (let ((debug-on-error old-value))
1064 (setq values (cons (eval expr) values))
1065 (setq new-value debug-on-error))
1066 ;; If evaled code has changed the value of debug-on-error,
1067 ;; propagate that change to the global binding.
1068 (unless (eq old-value new-value)
1069 (setq debug-on-error new-value))))
1070
1071 (if (or (consp (car values)) (vectorp (car values)))
1072 (let ((v (car values)))
1073 (data-debug-show-stuff v "Expression"))
1074 ;; Old style
1075 (prog1
1076 (prin1 (car values) t)
1077 (let ((str (eval-expression-print-format (car values))))
1078 (if str (princ str t))))))
1079
1080(provide 'data-debug)
1081
1082(if (featurep 'eieio)
1083 (require 'eieio-datadebug))
1084
1085;;; data-debug.el ends here
diff --git a/lisp/cedet/inversion.el b/lisp/cedet/inversion.el
new file mode 100644
index 00000000000..7bd0b9696a0
--- /dev/null
+++ b/lisp/cedet/inversion.el
@@ -0,0 +1,541 @@
1;;; inversion.el --- When you need something in version XX.XX
2
3;;; Copyright (C) 2002, 2003, 2005, 2006, 2007, 2008, 2009
4;;; Free Software Foundation, Inc.
5
6;; Author: Eric M. Ludlam <zappo@gnu.org>
7;; Version: 0.2
8;; Keywords: OO, lisp
9
10;; This file is part of GNU Emacs.
11
12;; GNU Emacs is free software: you can redistribute it and/or modify
13;; it under the terms of the GNU General Public License as published by
14;; the Free Software Foundation, either version 3 of the License, or
15;; (at your option) any later version.
16
17;; GNU Emacs is distributed in the hope that it will be useful,
18;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20;; GNU General Public License for more details.
21
22;; You should have received a copy of the GNU General Public License
23;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
24
25;;; Commentary:
26;;
27;; Keeping track of rapidly developing software is a tough thing to
28;; do, especially if you want to have co-dependent packages which all
29;; move at different rates.
30;;
31;; This library provides a framework for specifying version numbers
32;; and (as side effect) have a flexible way of getting a desired feature set.
33;;
34;; If you would like to use this package to satisfy dependency replace this:
35;;
36;; (require 'spiffy)
37;;
38;; with this:
39;;
40;; (require 'inversion)
41;; (inversion-require 'spiffy "1.0")
42;;
43;; If you feel the need to not throw errors, you can do this instead:
44;;
45;; (let ((err (inversion-test 'spiffy "1.0")))
46;; (if err (your-stuff-here)))
47;;
48;; If you new package (2.0) needs to make sure a load file from your
49;; package is compatible, use this test:
50;;
51;; (if (not (inversion-reverse-test 'spiffy version-from-file))
52;; ;; Everything ok
53;; (do stuff)
54;; ;; Out of date
55;; (import-old-code))
56;;
57;; If you would like to make inversion optional, do this:
58;;
59;; (or (require 'inversion nil t)
60;; (defun inversion-test (p v)
61;; (string= v (symbol-value
62;; (intern-soft (concat (symbol-string p) "-version"))))))
63;;
64;; Or modify to specify `inversion-require' instead.
65;;
66;; TODO:
67;; Offer to download newer versions of a package.
68
69;;; History:
70;;
71;; Sept 3, 2002: First general publication.
72
73;;; Code:
74
75(defvar inversion-version "1.3"
76 "Current version of InVersion.")
77
78(defvar inversion-incompatible-version "0.1alpha1"
79 "An earlier release which is incompatible with this release.")
80
81(defconst inversion-decoders
82 '(
83 (alpha "^\\([0-9]+\\)\\.\\([0-9]+\\)\\s-*alpha\\([0-9]+\\)?$" 3)
84 (beta "^\\([0-9]+\\)\\.\\([0-9]+\\)\\s-*beta\\([0-9]+\\)?$" 3)
85 (beta "^\\([0-9]+\\)\\.\\([0-9]+\\)\\s-*(beta\\([0-9]+\\)?)" 3)
86 (prerelease "^\\([0-9]+\\)\\.\\([0-9]+\\)\\s-*pre\\([0-9]+\\)?$" 3)
87 (full "^\\([0-9]+\\)\\.\\([0-9]+\\)$" 2)
88 (fullsingle "^\\([0-9]+\\)$" 1)
89 (patch "^\\([0-9]+\\)\\.\\([0-9]+\\) (patch \\([0-9]+\\))" 3)
90 (point "^\\([0-9]+\\)\\.\\([0-9]+\\)\\.\\([0-9]+\\)$" 3)
91 (build "^\\([0-9]+\\)\\.\\([0-9]+\\)\\.\\([0-9]+\\).\\([0-9]+\\)$" 4)
92 )
93 "List of decoders for version strings.
94Each decoder is of the form:
95
96 ( RELEASE-TYPE REGEXP MAX )
97
98RELEASE-TYPE is a symbol specifying something like `beta' or `alpha'.
99REGEXP is the regular expression to match a version string.
100MAX is the maximum number of match-numbers in the release number.
101Decoders must be ordered to decode least stable versions before the
102more stable ones.")
103
104;;; Version Checking
105;;
106(defun inversion-decode-version (version-string)
107 "Decode VERSION-STRING into an encoded list.
108Return value is of the form:
109 (RELEASE MAJOR MINOR ...)
110where RELEASE is a symbol such as `full', or `beta'."
111 (let ((decoders inversion-decoders)
112 (result nil))
113 (while (and decoders (not result))
114 (if (string-match (nth 1 (car decoders)) version-string)
115 (let ((ver nil)
116 (num-left (nth 2 (car decoders)))
117 (count 1))
118 (while (<= count num-left)
119 (setq ver (cons
120 (if (match-beginning count)
121 (string-to-number
122 (substring version-string
123 (match-beginning count)
124 (match-end count)))
125 1)
126 ver)
127 count (1+ count)))
128 (setq result (cons (caar decoders) (nreverse ver))))
129 (setq decoders (cdr decoders))))
130 result))
131
132(defun inversion-package-version (package)
133 "Return the decoded version for PACKAGE."
134 (let ((ver (symbol-value
135 (intern-soft
136 (concat (symbol-name package)
137 "-version"))))
138 (code nil))
139 (unless ver
140 (error "Package %S does not define %S-version" package package))
141 ;; Decode the code
142 (setq code (inversion-decode-version ver))
143 (unless code
144 (error "%S-version value cannot be decoded" package))
145 code))
146
147(defun inversion-package-incompatibility-version (package)
148 "Return the decoded incompatibility version for PACKAGE.
149The incompatibility version is specified by the programmer of
150a package when a package is not backward compatible. It is
151not an indication of new features or bug fixes."
152 (let ((ver (symbol-value
153 (intern-soft
154 (concat (symbol-name package)
155 "-incompatible-version")))))
156 (if (not ver)
157 nil
158 ;; Decode the code
159 (inversion-decode-version ver))))
160
161(defun inversion-recode (code)
162 "Convert CODE into a string."
163 (let ((r (nth 0 code)) ; release-type
164 (n (nth 1 code)) ; main number
165 (i (nth 2 code)) ; first increment
166 (p (nth 3 code))) ; second increment
167 (cond
168 ((eq r 'full)
169 (setq r "" p ""))
170 ((eq r 'point)
171 (setq r ".")))
172 (format "%s.%s%s%s" n i r p)))
173
174(defun inversion-release-to-number (release-symbol)
175 "Convert RELEASE-SYMBOL into a number."
176 (let* ((ra (assoc release-symbol inversion-decoders))
177 (rn (- (length inversion-decoders)
178 (length (member ra inversion-decoders)))))
179 rn))
180
181(defun inversion-= (ver1 ver2)
182 "Return non-nil if VER1 is equal to VER2."
183 (equal ver1 ver2))
184
185(defun inversion-< (ver1 ver2)
186 "Return non-nil if VER1 is less than VER2."
187 (let ((v1-0 (inversion-release-to-number (nth 0 ver1)))
188 (v1-1 (nth 1 ver1))
189 (v1-2 (nth 2 ver1))
190 (v1-3 (nth 3 ver1))
191 (v1-4 (nth 4 ver1))
192 ;; v2
193 (v2-0 (inversion-release-to-number (nth 0 ver2)))
194 (v2-1 (nth 1 ver2))
195 (v2-2 (nth 2 ver2))
196 (v2-3 (nth 3 ver2))
197 (v2-4 (nth 4 ver2))
198 )
199 (or (and (= v1-0 v2-0)
200 (= v1-1 v2-1)
201 (= v1-2 v2-2)
202 (= v1-3 v2-3)
203 v1-4 v2-4 ; all or nothin if elt - is =
204 (< v1-4 v2-4))
205 (and (= v1-0 v2-0)
206 (= v1-1 v2-1)
207 (= v1-2 v2-2)
208 v1-3 v2-3 ; all or nothin if elt - is =
209 (< v1-3 v2-3))
210 (and (= v1-1 v2-1)
211 (< v1-2 v2-2))
212 (and (< v1-1 v2-1))
213 (and (< v1-0 v2-0)
214 (= v1-1 v2-1)
215 (= v1-2 v2-2)
216 )
217 )))
218
219(defun inversion-check-version (version incompatible-version
220 minimum &rest reserved)
221 "Check that a given version meets the minimum requirement.
222VERSION, INCOMPATIBLE-VERSION and MINIMUM are of similar format to
223return entries of `inversion-decode-version', or a classic version
224string. INCOMPATIBLE-VERSION can be nil.
225RESERVED arguments are kept for a later use.
226Return:
227- nil if everything is ok
228- 'outdated if VERSION is less than MINIMUM.
229- 'incompatible if VERSION is not backward compatible with MINIMUM.
230- t if the check failed."
231 (let ((code (if (stringp version)
232 (inversion-decode-version version)
233 version))
234 (req (if (stringp minimum)
235 (inversion-decode-version minimum)
236 minimum))
237 )
238 ;; Perform a test.
239 (cond
240 ((inversion-= code req)
241 ;; Same version.. Yay!
242 nil)
243 ((inversion-< code req)
244 ;; Version is too old!
245 'outdated)
246 ((inversion-< req code)
247 ;; Newer is installed. What to do?
248 (let ((incompatible
249 (if (stringp incompatible-version)
250 (inversion-decode-version incompatible-version)
251 incompatible-version)))
252 (cond
253 ((not incompatible) nil)
254 ((or (inversion-= req incompatible)
255 (inversion-< req incompatible))
256 ;; The requested version is = or < than what the package
257 ;; maintainer says is incompatible.
258 'incompatible)
259 ;; Things are ok.
260 (t nil))))
261 ;; Check failed
262 (t t))))
263
264(defun inversion-test (package minimum &rest reserved)
265 "Test that PACKAGE meets the MINIMUM version requirement.
266PACKAGE is a symbol, similar to what is passed to `require'.
267MINIMUM is of similar format to return entries of
268`inversion-decode-version', or a classic version string.
269RESERVED arguments are kept for a later user.
270This depends on the symbols `PACKAGE-version' and optionally
271`PACKAGE-incompatible-version' being defined in PACKAGE.
272Return nil if everything is ok. Return an error string otherwise."
273 (let ((check (inversion-check-version
274 (inversion-package-version package)
275 (inversion-package-incompatibility-version package)
276 minimum reserved)))
277 (cond
278 ((null check)
279 ;; Same version.. Yay!
280 nil)
281 ((eq check 'outdated)
282 ;; Version is too old!
283 (format "You need to upgrade package %s to %s" package minimum))
284 ((eq check 'incompatible)
285 ;; Newer is installed but the requested version is = or < than
286 ;; what the package maintainer says is incompatible, then throw
287 ;; that error.
288 (format "Package %s version is not backward compatible with %s"
289 package minimum))
290 ;; Check failed
291 (t "Inversion version check failed."))))
292
293(defun inversion-reverse-test (package oldversion &rest reserved)
294 "Test that PACKAGE at OLDVERSION is still compatible.
295If something like a save file is loaded at OLDVERSION, this
296test will identify if OLDVERSION is compatible with the current version
297of PACKAGE.
298PACKAGE is a symbol, similar to what is passed to `require'.
299OLDVERSION is of similar format to return entries of
300`inversion-decode-version', or a classic version string.
301RESERVED arguments are kept for a later user.
302This depends on the symbols `PACKAGE-version' and optionally
303`PACKAGE-incompatible-version' being defined in PACKAGE.
304Return nil if everything is ok. Return an error string otherwise."
305 (let ((check (inversion-check-version
306 (inversion-package-version package)
307 (inversion-package-incompatibility-version package)
308 oldversion reserved)))
309 (cond
310 ((null check)
311 ;; Same version.. Yay!
312 nil)
313 ((eq check 'outdated)
314 ;; Version is too old!
315 (format "Package %s version %s is not compatible with current version"
316 package oldversion))
317 ((eq check 'incompatible)
318 ;; Newer is installed but the requested version is = or < than
319 ;; what the package maintainer says is incompatible, then throw
320 ;; that error.
321 (format "Package %s version is not backward compatible with %s"
322 package oldversion))
323 ;; Check failed
324 (t "Inversion version check failed."))))
325
326(defun inversion-require (package version &optional file directory
327 &rest reserved)
328 "Declare that you need PACKAGE with at least VERSION.
329PACKAGE might be found in FILE. (See `require'.)
330Throws an error if VERSION is incompatible with what is installed.
331Optional argument DIRECTORY is a location where new versions of
332this tool can be located. If there is a versioning problem and
333DIRECTORY is provided, inversion will offer to download the file.
334Optional argument RESERVED is saved for later use."
335 (require package file)
336 (let ((err (inversion-test package version)))
337 (when err
338 (if directory
339 (inversion-download-package-ask err package directory version)
340 (error err)))
341 ;; Return the package symbol that was required.
342 package))
343
344(defun inversion-require-emacs (emacs-ver xemacs-ver)
345 "Declare that you need either EMACS-VER, or XEMACS-VER.
346Only checks one based on which kind of Emacs is being run."
347 (let ((err (inversion-test 'emacs
348 (if (featurep 'xemacs)
349 xemacs-ver
350 emacs-ver))))
351 (if err (error err)
352 ;; Something nice...
353 t)))
354
355(defconst inversion-find-data
356 '("(def\\(var\\|const\\)\\s-+%s-%s\\s-+\"\\([^\"]+\\)" 2)
357 "Regexp template and match data index of a version string.")
358
359(defun inversion-find-version (package)
360 "Search for the version and incompatible version of PACKAGE.
361Does not load PACKAGE nor requires that it has been previously loaded.
362Search in the directories in `load-path' for a PACKAGE.el library.
363Visit the file found and search for the declarations of variables or
364constants `PACKAGE-version' and `PACKAGE-incompatible-version'. The
365value of these variables must be a version string.
366
367Return a pair (VERSION-STRING . INCOMPATIBLE-VERSION-STRING) where
368INCOMPATIBLE-VERSION-STRING can be nil.
369Return nil when VERSION-STRING was not found."
370 (let* ((file (locate-library (format "%s.el" package) t))
371 (tag (car inversion-find-data))
372 (idx (nth 1 inversion-find-data))
373 version)
374 (when file
375 (with-temp-buffer
376 ;; The 3000 is a bit arbitrary, but should cut down on
377 ;; fileio as version info usually is at the very top
378 ;; of a file. AFter a long commentary could be bad.
379 (insert-file-contents-literally file nil 0 3000)
380 (goto-char (point-min))
381 (when (re-search-forward (format tag package 'version) nil t)
382 (setq version (list (match-string idx)))
383 (goto-char (point-min))
384 (when (re-search-forward
385 (format tag package 'incompatible-version) nil t)
386 (setcdr version (match-string idx))))))
387 version))
388
389(defun inversion-add-to-load-path (package minimum
390 &optional installdir
391 &rest subdirs)
392 "Add the PACKAGE path to `load-path' if necessary.
393MINIMUM is the minimum version requirement of PACKAGE.
394Optional argument INSTALLDIR is the base directory where PACKAGE is
395installed. It defaults to `default-directory'/PACKAGE.
396SUBDIRS are sub-directories to add to `load-path', following the main
397INSTALLDIR path."
398 (let ((ver (inversion-find-version package)))
399 ;; If PACKAGE not found or a bad version already in `load-path',
400 ;; prepend the new PACKAGE path, so it will be loaded first.
401 (when (or (not ver)
402 (and
403 (inversion-check-version (car ver) (cdr ver) minimum)
404 (message "Outdated %s %s shadowed to meet minimum version %s"
405 package (car ver) minimum)
406 t))
407 (let* ((default-directory
408 (or installdir
409 (expand-file-name (format "./%s" package))))
410 subdir)
411 (when (file-directory-p default-directory)
412 ;; Add SUBDIRS
413 (while subdirs
414 (setq subdir (expand-file-name (car subdirs))
415 subdirs (cdr subdirs))
416 (when (file-directory-p subdir)
417 ;;(message "%S added to `load-path'" subdir)
418 (add-to-list 'load-path subdir)))
419 ;; Add the main path
420 ;;(message "%S added to `load-path'" default-directory)
421 (add-to-list 'load-path default-directory))
422 ;; We get to this point iff we do not accept or there is no
423 ;; system file. Lets check the version of what we just
424 ;; installed... just to be safe.
425 (let ((newver (inversion-find-version package)))
426 (if (not newver)
427 (error "Failed to find version for newly installed %s"
428 package))
429 (if (inversion-check-version (car newver) (cdr newver) minimum)
430 (error "Outdated %s %s just installed" package (car newver)))
431 )))))
432
433;;; URL and downloading code
434;;
435(defun inversion-locate-package-files (package directory &optional version)
436 "Get a list of distributions of PACKAGE from DIRECTORY.
437DIRECTORY can be an ange-ftp compatible filename, such as:
438 \"/ftp@ftp1.sourceforge.net/pub/sourceforge/PACKAGE\"
439If it is a URL, wget will be used for download.
440Optional argument VERSION will restrict the list of available versions
441to the file matching VERSION exactly, or nil."
442;;DIRECTORY should also allow a URL:
443;; \"http://ftp1.sourceforge.net/PACKAGE\"
444;; but then I can get file listings easily.
445 (if (symbolp package) (setq package (symbol-name package)))
446 (directory-files directory t
447 (if version
448 (concat "^" package "-" version "\\>")
449 package)))
450
451(defvar inversion-package-common-tails '( ".tar.gz"
452 ".tar"
453 ".zip"
454 ".gz"
455 )
456 "Common distribution mechanisms for Emacs Lisp packages.")
457
458(defun inversion-locate-package-files-and-split (package directory &optional version)
459 "Use `inversion-locate-package-files' to get a list of PACKAGE files.
460DIRECTORY is the location where distributions of PACKAGE are.
461VERSION is an optional argument specifying a version to restrict to.
462The return list is an alist with the version string in the CAR,
463and the full path name in the CDR."
464 (if (symbolp package) (setq package (symbol-name package)))
465 (let ((f (inversion-locate-package-files package directory version))
466 (out nil))
467 (while f
468 (let* ((file (car f))
469 (dist (file-name-nondirectory file))
470 (tails inversion-package-common-tails)
471 (verstring nil))
472 (while (and tails (not verstring))
473 (when (string-match (concat (car tails) "$") dist)
474 (setq verstring
475 (substring dist (1+ (length package)) (match-beginning 0))))
476 (setq tails (cdr tails)))
477 (if (not verstring)
478 (error "Cannot decode version for %s" dist))
479 (setq out
480 (cons
481 (cons verstring file)
482 out))
483 (setq f (cdr f))))
484 out))
485
486(defun inversion-download-package-ask (err package directory version)
487 "Due to ERR, offer to download PACKAGE from DIRECTORY.
488The package should have VERSION available for download."
489 (if (symbolp package) (setq package (symbol-name package)))
490 (let ((files (inversion-locate-package-files-and-split
491 package directory version)))
492 (if (not files)
493 (error err)
494 (if (not (y-or-n-p (concat err ": Download update? ")))
495 (error err)
496 (let ((dest (read-directory-name (format "Download %s to: "
497 package)
498 t)))
499 (if (> (length files) 1)
500 (setq files
501 (list
502 "foo" ;; ignored
503 (read-file-name "Version to download: "
504 directory
505 files
506 t
507 (concat
508 (file-name-as-directory directory)
509 package)
510 nil))))
511
512 (copy-file (cdr (car files)) dest))))))
513
514;;; How we upgrade packages in Emacs has yet to be ironed out.
515
516;; (defun inversion-upgrade-package (package &optional directory)
517;; "Try to upgrade PACKAGE in DIRECTORY is available."
518;; (interactive "sPackage to upgrade: ")
519;; (if (stringp package) (setq package (intern package)))
520;; (if (not directory)
521;; ;; Hope that the package maintainer specified.
522;; (setq directory (symbol-value (or (intern-soft
523;; (concat (symbol-name package)
524;; "-url"))
525;; (intern-soft
526;; (concat (symbol-name package)
527;; "-directory"))))))
528;; (let ((files (inversion-locate-package-files-and-split
529;; package directory))
530;; (cver (inversion-package-version package))
531;; (newer nil))
532;; (mapc (lambda (f)
533;; (if (inversion-< cver (inversion-decode-version (car f)))
534;; (setq newer (cons f newer))))
535;; files)
536;; newer
537;; ))
538
539(provide 'inversion)
540
541;;; inversion.el ends here
diff --git a/lisp/cedet/pulse.el b/lisp/cedet/pulse.el
new file mode 100644
index 00000000000..d28d5a1f651
--- /dev/null
+++ b/lisp/cedet/pulse.el
@@ -0,0 +1,257 @@
1;;; pulse.el --- Pulsing Overlays
2
3;;; Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc.
4
5;; Author: Eric M. Ludlam <eric@siege-engine.com>
6
7;; This file is part of GNU Emacs.
8
9;; GNU Emacs is free software: you can redistribute it and/or modify
10;; it under the terms of the GNU General Public License as published by
11;; the Free Software Foundation, either version 3 of the License, or
12;; (at your option) any later version.
13
14;; GNU Emacs is distributed in the hope that it will be useful,
15;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17;; GNU General Public License for more details.
18
19;; You should have received a copy of the GNU General Public License
20;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
21
22;;; Commentary:
23;;
24;; Manage temporary pulsing of faces and overlays.
25;;
26;; This is a temporal decoration technique where something is to be
27;; highlighted briefly. This adds a gentle pulsing style to the text
28;; decorated this way.
29;;
30;; Useful user functions:
31;;
32;; `pulse-enable-integration-advice' - Turn on advice to make various
33;; Emacs commands pulse, such as `goto-line', or `find-tag'.
34;;
35;; The following are useful entry points:
36;;
37;; `pulse' - Cause `pulse-highlight-face' to shift toward background color.
38;; Assumes you are using a version of Emacs that supports pulsing.
39;;
40;;
41;; `pulse-momentary-highlight-one-line' - Pulse a single line at POINT.
42;; `pulse-momentary-highlight-region' - Pulse a region.
43;; `pulse-momentary-highlight-overlay' - Pulse an overlay
44;; These three functions will just blink the specified area if
45;; the version of Emacs you are using doesn't support pulsing.
46;;
47;; `pulse-line-hook-function' - A simple function that can be used in a
48;; hook that will pulse whatever line the cursor is on.
49;;
50;;; History:
51;;
52;; The original pulse code was written for semantic tag highlighting.
53;; It has been extracted, and adapted for general purpose pulsing.
54;;
55;; Pulse is a part of CEDET. http://cedet.sf.net
56
57(defun pulse-available-p ()
58 "Return non-nil if pulsing is available on the current frame."
59 (condition-case nil
60 (let ((v (color-values (face-background 'default))))
61 (numberp (car-safe v)))
62 (error nil)))
63
64(defcustom pulse-flag (pulse-available-p)
65 "*Non-nil means to pulse the overlay face for momentary highlighting.
66Pulsing involves a bright highlight that slowly shifts to the background
67color. Non-nil just means to highlight with an unchanging color for a short
68time.
69
70If `pulse-flag' is non-nil, but `pulse-available-p' is nil, then
71this flag is ignored."
72 :group 'pulse
73 :type 'boolean)
74
75(defface pulse-highlight-start-face
76 '((((class color) (background dark))
77 (:background "#AAAA33"))
78 (((class color) (background light))
79 (:background "#FFFFAA")))
80 "*Face used at beginning of a highight."
81 :group 'pulse)
82
83(defface pulse-highlight-face
84 '((((class color) (background dark))
85 (:background "#AAAA33"))
86 (((class color) (background light))
87 (:background "#FFFFAA")))
88 "*Face used during a pulse for display. *DO NOT CUSTOMIZE*
89Face used for temporary highlighting of tags for effect."
90 :group 'pulse)
91
92;;; Code:
93;;
94(defun pulse-int-to-hex (int &optional nb-digits)
95 "Convert integer argument INT to a #XXXXXXXXXXXX format hex string.
96Each X in the output string is a hexadecimal digit.
97NB-DIGITS is the number of hex digits. If INT is too large to be
98represented with NB-DIGITS, then the result is truncated from the
99left. So, for example, INT=256 and NB-DIGITS=2 returns \"00\", since
100the hex equivalent of 256 decimal is 100, which is more than 2 digits.
101
102This function was blindly copied from hexrgb.el by Drew Adams.
103http://www.emacswiki.org/cgi-bin/wiki/hexrgb.el"
104 (setq nb-digits (or nb-digits 4))
105 (substring (format (concat "%0" (int-to-string nb-digits) "X") int) (- nb-digits)))
106
107(defun pulse-color-values-to-hex (values)
108 "Convert list of rgb color VALUES to a hex string, #XXXXXXXXXXXX.
109Each X in the string is a hexadecimal digit.
110Input VALUES is as for the output of `x-color-values'.
111
112This function was blindly copied from hexrgb.el by Drew Adams.
113http://www.emacswiki.org/cgi-bin/wiki/hexrgb.el"
114 (concat "#"
115 (pulse-int-to-hex (nth 0 values) 4) ; red
116 (pulse-int-to-hex (nth 1 values) 4) ; green
117 (pulse-int-to-hex (nth 2 values) 4))) ; blue
118
119(defcustom pulse-iterations 10
120 "Number of iterations in a pulse operation."
121 :group 'pulse
122 :type 'number)
123(defcustom pulse-delay .03
124 "Delay between face lightening iterations, as used by `sit-for'."
125 :group 'pulse
126 :type 'number)
127
128(defun pulse-lighten-highlight ()
129 "Lighten the face by 1/`pulse-iterations' toward the background color.
130Return t if there is more drift to do, nil if completed."
131 (if (>= (get 'pulse-highlight-face :iteration) pulse-iterations)
132 nil
133 (let* ((frame (color-values (face-background 'default)))
134 (start (color-values (face-background
135 (get 'pulse-highlight-face
136 :startface))))
137 (frac (list (/ (- (nth 0 frame) (nth 0 start)) pulse-iterations)
138 (/ (- (nth 1 frame) (nth 1 start)) pulse-iterations)
139 (/ (- (nth 2 frame) (nth 2 start)) pulse-iterations)))
140 (it (get 'pulse-highlight-face :iteration))
141 )
142 (set-face-background 'pulse-highlight-face
143 (pulse-color-values-to-hex
144 (list
145 (+ (nth 0 start) (* (nth 0 frac) it))
146 (+ (nth 1 start) (* (nth 1 frac) it))
147 (+ (nth 2 start) (* (nth 2 frac) it)))))
148 (put 'pulse-highlight-face :iteration (1+ it))
149 (if (>= (1+ it) pulse-iterations)
150 nil
151 t))))
152
153(defun pulse-reset-face (&optional face)
154 "Reset the pulse highlighting FACE."
155 (set-face-background 'pulse-highlight-face
156 (if face
157 (face-background face)
158 (face-background 'pulse-highlight-start-face)
159 ))
160 (put 'pulse-highlight-face :startface (or face
161 'pulse-highlight-start-face))
162 (put 'pulse-highlight-face :iteration 0))
163
164(defun pulse (&optional face)
165 "Pulse the colors on our highlight face.
166If optional FACE is provide, reset the face to FACE color,
167instead of `pulse-highlight-start-face'.
168Be sure to call `pulse-reset-face' after calling pulse."
169 (unwind-protect
170 (progn
171 (pulse-reset-face face)
172 (while (and (pulse-lighten-highlight)
173 (sit-for pulse-delay))
174 nil))))
175
176;;; Convenience Functions
177;;
178(defvar pulse-momentary-overlay nil
179 "The current pulsing overlay.")
180
181(defun pulse-momentary-highlight-overlay (o &optional face)
182 "Pulse the overlay O, unhighlighting before next command.
183Optional argument FACE specifies the fact to do the highlighting."
184 (overlay-put o 'original-face (overlay-get o 'face))
185 (add-to-list 'pulse-momentary-overlay o)
186 (if (or (not pulse-flag) (not (pulse-available-p)))
187 ;; Provide a face... clear on next command
188 (progn
189 (overlay-put o 'face (or face 'pulse-highlight-start-face))
190 (add-hook 'pre-command-hook
191 'pulse-momentary-unhighlight)
192 )
193 ;; pulse it.
194 (unwind-protect
195 (progn
196 (overlay-put o 'face 'pulse-highlight-face)
197 ;; The pulse function puts FACE onto 'pulse-highlight-face.
198 ;; Thus above we put our face on the overlay, but pulse
199 ;; with a reference face needed for the color.
200 (pulse face))
201 (pulse-momentary-unhighlight))))
202
203(defun pulse-momentary-unhighlight ()
204 "Unhighlight a line recently highlighted."
205 ;; If someone passes in an overlay, then pulse-momentary-overlay
206 ;; will still be nil, and won't need modifying.
207 (when pulse-momentary-overlay
208 ;; clear the starting face
209 (mapc
210 (lambda (ol)
211 (overlay-put ol 'face (overlay-get ol 'original-face))
212 (overlay-put ol 'original-face nil)
213 ;; Clear the overlay if it needs deleting.
214 (when (overlay-get ol 'pulse-delete) (delete-overlay ol)))
215 pulse-momentary-overlay)
216
217 ;; Clear the variable.
218 (setq pulse-momentary-overlay nil))
219
220 ;; Reset the pulsing face.
221 (pulse-reset-face)
222
223 ;; Remove this hook.
224 (remove-hook 'pre-command-hook 'pulse-momentary-unhighlight))
225
226(defun pulse-momentary-highlight-one-line (point &optional face)
227 "Highlight the line around POINT, unhighlighting before next command.
228Optional argument FACE specifies the face to do the highlighting."
229 (let ((start (point-at-bol))
230 (end (save-excursion
231 (end-of-line)
232 (when (not (eobp))
233 (forward-char 1))
234 (point))))
235 (pulse-momentary-highlight-region start end face)))
236
237(defun pulse-momentary-highlight-region (start end &optional face)
238 "Highlight between START and END, unhighlighting before next command.
239Optional argument FACE specifies the fact to do the highlighting."
240 (let ((o (make-overlay start end)))
241 ;; Mark it for deletion
242 (overlay-put o 'pulse-delete t)
243 (pulse-momentary-highlight-overlay o face)))
244
245;;; Random integration with other tools
246
247(defvar pulse-command-advice-flag nil)
248
249(defun pulse-line-hook-function ()
250 "Function used in hooks to pulse the current line.
251Only pulses the line if `pulse-command-advice-flag' is non-nil."
252 (when pulse-command-advice-flag
253 (pulse-momentary-highlight-one-line (point))))
254
255(provide 'pulse)
256
257;;; pulse.el ends here
generated by cgit v1.2.1 (git 2.18.0) at 2026-01-20 15:17:53 +0000