aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorChong Yidong2009-08-22 19:04:43 +0000
committerChong Yidong2009-08-22 19:04:43 +0000
commitb2b35d5627e7975e3ad6cd4e273cd902f37bdb91 (patch)
treedbcfde6f3d440da44b48f0a676c53bb66065a38a
parent9305093eabe13c50471a3d727e8953d676098250 (diff)
downloademacs-b2b35d5627e7975e3ad6cd4e273cd902f37bdb91.tar.gz
emacs-b2b35d5627e7975e3ad6cd4e273cd902f37bdb91.zip
cedet-cscope.el, cedet-edebug.el, cedet-global.el, cedet-idutils.el,
cedet.el, inversion.el, pulse.el: Initial version, from CEDET's common/ directory.
Diffstat
-rw-r--r--lisp/cedet/cedet-cscope.el157
-rw-r--r--lisp/cedet/cedet-edebug.el126
-rw-r--r--lisp/cedet/cedet-global.el165
-rw-r--r--lisp/cedet/cedet-idutils.el181
-rw-r--r--lisp/cedet/cedet.el130
-rw-r--r--lisp/cedet/inversion.el601
-rw-r--r--lisp/cedet/pulse.el397
7 files changed, 1757 insertions, 0 deletions
diff --git a/lisp/cedet/cedet-cscope.el b/lisp/cedet/cedet-cscope.el
new file mode 100644
index 00000000000..4355ea38570
--- /dev/null
+++ b/lisp/cedet/cedet-cscope.el
@@ -0,0 +1,157 @@
1;;; cedet-cscope.el --- CScope support for CEDET
2
3;;; Copyright (C) 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(defvar cedet-cscope-min-version "16.0"
29 "Minimum version of GNU global required.")
30
31(defcustom cedet-cscope-command "cscope"
32 "Command name for the CScope executable."
33 :type 'string
34 :group 'cedet)
35
36(defun cedet-cscope-search (searchtext texttype type scope)
37 "Perform a search with CScope, return the created buffer.
38SEARCHTEXT is text to find.
39TEXTTYPE is the type of text, such as 'regexp, 'string, 'tagname,
40'tagregexp, or 'tagcompletions.
41TYPE is the type of search, meaning that SEARCHTEXT is compared to
42filename, tagname (tags table), references (uses of a tag) , or
43symbol (uses of something not in the tag table.)
44SCOPE is the scope of the search, such as 'project or 'subdirs."
45 ;; CScope is an interactive program. It uses number flags
46 ;; in order to perform command line searches. Useful for this
47 ;; tool are:
48 ;;
49 ;; -0 = Find C symbol
50 ;; -1 = Find global definition
51 ;; -3 = Find references
52 ;; -6 = Find egrep pattern
53 ;; -7 = Find file
54 (let ((idx (cond ((eq type 'file)
55 "-7")
56 ;; Non files are symbols and such
57 ((eq texttype 'tagname)
58 "-1")
59 ((eq texttype 'tagregexp)
60 "-0")
61 ((eq texttype 'tagcompletions)
62 (setq searchtext (concat "^" searchtext ".*"))
63 "-1")
64 ((eq texttype 'regexp)
65 "-5")
66 (t
67 "-3")
68 )
69 )
70 )
71 (cedet-cscope-call (list "-d" "-L" idx searchtext))))
72
73(defun cedet-cscope-call (flags)
74 "Call CScope with the list of FLAGS."
75 (let ((b (get-buffer-create "*CEDET CScope*"))
76 (cd default-directory)
77 )
78 (save-excursion
79 (set-buffer b)
80 (setq default-directory cd)
81 (erase-buffer))
82 (apply 'call-process cedet-cscope-command
83 nil b nil
84 flags)
85 b))
86
87(defun cedet-cscope-expand-filename (filename)
88 "Expand the FILENAME with CScope.
89Return a fully qualified filename."
90 (interactive "sFile: ")
91 (let* ((ans1 (save-excursion
92 (set-buffer (cedet-cscope-call (list "-d" "-L" "-7" filename)))
93 (goto-char (point-min))
94 (if (looking-at "[^ \n]*cscope: ")
95 (error "CScope not available")
96 (split-string (buffer-string) "\n" t))))
97 (ans2 (mapcar (lambda (hit)
98 (expand-file-name (car (split-string hit " "))))
99 ans1)))
100 (when (interactive-p)
101 (if ans2
102 (if (= (length ans2) 1)
103 (message "%s" (car ans2))
104 (message "%s + %d others" (car ans2)
105 (length (cdr ans2))))
106 (error "No file found")))
107 ans2))
108
109(defun cedet-cscope-support-for-directory (&optional dir)
110 "Return non-nil if CScope has a support file for DIR.
111If DIR is not supplied, use the current default directory.
112This works by running cscope on a bogus symbol, and looking for
113the error code."
114 (save-excursion
115 (let ((default-directory (or dir default-directory)))
116 (set-buffer (cedet-cscope-call (list "-d" "-L" "-7" "moose")))
117 (goto-char (point-min))
118 (if (looking-at "[^ \n]*cscope: ")
119 nil
120 t))))
121
122(declare-function inversion-check-version "inversion")
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 Global 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-edebug.el b/lisp/cedet/cedet-edebug.el
new file mode 100644
index 00000000000..9548e27f5a7
--- /dev/null
+++ b/lisp/cedet/cedet-edebug.el
@@ -0,0 +1,126 @@
1;;; cedet-edebug.el --- Special EDEBUG augmentation code
2
3;;; Copyright (C) 2003, 2004, 2007, 2008 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;; Some aspects of EDEBUG are not extensible. It is possible to extend
27;; edebug through other means, such as alias or advice, but those don't stack
28;; very well when there are multiple tools trying to do the same sort of thing.
29;;
30;; This package provides a way to extend some aspects of edebug, such as value
31;; printing.
32
33;;; Code:
34(defvar cedet-edebug-prin1-extensions nil
35 "An alist of of code that can extend PRIN1 for edebug.
36Each entry has the value: (CONDITION . PRIN1COMMAND).")
37
38(defun cedet-edebug-prin1-recurse (object)
39 "Recurse into OBJECT for prin1 on `cedet-edebug-prin1-to-string'."
40 (concat "(" (mapconcat 'cedet-edebug-prin1-to-string object " ") ")"))
41
42(defun cedet-edebug-rebuild-prin1 ()
43 "Rebuild the function `cedet-edebug-prin1-to-string'.
44Use the values of `cedet-edebug-prin1-extensions' as the means of
45constructing the function."
46 (interactive)
47 (let ((c cedet-edebug-prin1-extensions)
48 (code nil))
49 (while c
50 (setq code (append (list (list (car (car c))
51 (cdr (car c))))
52 code))
53 (setq c (cdr c)))
54 (fset 'cedet-edebug-prin1-to-string-inner
55 `(lambda (object &optional noescape)
56 "Display eieio OBJECT in fancy format. Overrides the edebug default.
57Optional argument NOESCAPE is passed to `prin1-to-string' when appropriate."
58 (cond
59 ,@(nreverse code)
60 (t (prin1-to-string object noescape)))))
61 ))
62
63(defun cedet-edebug-prin1-to-string (object &optional noescape)
64 "CEDET version of `edebug-prin1-to-string' that adds specialty
65print methods for very large complex objects."
66 (if (not (fboundp 'cedet-edebug-prin1-to-string-inner))
67 ;; Recreate the official fcn now.
68 (cedet-edebug-rebuild-prin1))
69
70 ;; Call the auto-generated version.
71 ;; This is not going to be available at compile time.
72 (with-no-warnings
73 (cedet-edebug-prin1-to-string-inner object noescape)))
74
75
76(defun cedet-edebug-add-print-override (testfcn printfcn)
77 "Add a new EDEBUG print override.
78TESTFCN is a routine that returns nil if the first argument
79passed to it is not to use PRINTFCN.
80PRINTFCN accepts an object identified by TESTFCN and
81returns a string.
82New tests are always added to the END of the list of tests.
83See `cedet-edebug-prin1-extensions' for the official list."
84 (condition-case nil
85 (add-to-list 'cedet-edebug-prin1-extensions
86 (cons testfcn printfcn)
87 t)
88 (error ;; That failed, it must be an older version of Emacs
89 ;; withouth the append argument for `add-to-list'
90 ;; Doesn't handle the don't add twice case, but that's a
91 ;; development thing and developers probably use new emacsen.
92 (setq cedet-edebug-prin1-extensions
93 (append cedet-edebug-prin1-extensions
94 (list (cons testfcn printfcn))))))
95 ;; whack the old implementation to force a rebuild.
96 (fmakunbound 'cedet-edebug-prin1-to-string-inner))
97
98;; ;;; NOTE TO SELF. Make this system used as an extension
99;; ;;; and then autoload the below.
100;; ;;;###autoload
101;; (add-hook 'edebug-setup-hook
102;; (lambda ()
103;; (require 'cedet-edebug)
104;; ;; I suspect this isn't the best way to do this, but when
105;; ;; cust-print was used on my system all my objects
106;; ;; appeared as "#1 =" which was not useful. This allows
107;; ;; edebug to print my objects in the nice way they were
108;; ;; meant to with `object-print' and `class-name'
109;; (defalias 'edebug-prin1-to-string 'cedet-edebug-prin1-to-string)
110;; ;; Add a fancy binding into EDEBUG's keymap for ADEBUG.
111;; (define-key edebug-mode-map "A" 'data-debug-edebug-expr)
112;; ))
113
114;; ;;; DEBUG MODE TOO
115;; ;; This seems like as good a place as any to stick this hack.
116;; ;;;###autoload
117;; (add-hook 'debugger-mode-hook
118;; (lambda ()
119;; (require 'cedet-edebug)
120;; ;; Add a fancy binding into the debug mode map for ADEBUG.
121;; (define-key debugger-mode-map "A" 'data-debug-edebug-expr)
122;; ))
123
124(provide 'cedet-edebug)
125
126;;; cedet-edebug.el ends here
diff --git a/lisp/cedet/cedet-global.el b/lisp/cedet/cedet-global.el
new file mode 100644
index 00000000000..2cc74f6635e
--- /dev/null
+++ b/lisp/cedet/cedet-global.el
@@ -0,0 +1,165 @@
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(defvar cedet-global-min-version "5.0"
27 "Minimum version of GNU global required.")
28
29(defcustom cedet-global-command "global"
30 "Command name for the GNU Global executable."
31 :type 'string
32 :group 'cedet)
33
34;;; Code:
35(defun cedet-gnu-global-search (searchtext texttype type scope)
36 "Perform a search with GNU Global, return the created buffer.
37SEARCHTEXT is text to find.
38TEXTTYPE is the type of text, such as 'regexp, 'string, 'tagname,
39'tagregexp, or 'tagcompletions.
40TYPE is the type of search, meaning that SEARCHTEXT is compared to
41filename, tagname (tags table), references (uses of a tag) , or
42symbol (uses of something not in the tag table.)
43SCOPE is the scope of the search, such as 'project or 'subdirs."
44 (let ((flgs (cond ((eq type 'file)
45 "-a")
46 (t "-xa")))
47 (scopeflgs (cond
48 ((eq scope 'project)
49 ""
50 )
51 ((eq scope 'target)
52 "l")))
53 (stflag (cond ((or (eq texttype 'tagname)
54 (eq texttype 'tagregexp))
55 "")
56 ((eq texttype 'tagcompletions)
57 "c")
58 ((eq texttype 'regexp)
59 "g")
60 (t "r")))
61 )
62 (cedet-gnu-global-call (list (concat flgs scopeflgs stflag)
63 searchtext))))
64
65(defun cedet-gnu-global-call (flags)
66 "Call GNU Global with the list of FLAGS."
67 (let ((b (get-buffer-create "*CEDET Global*"))
68 (cd default-directory)
69 )
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 )
109 (save-excursion
110 (set-buffer (cedet-gnu-global-call (list "-pq")))
111 (goto-char (point-min))
112 (when (not (eobp))
113 (file-name-as-directory
114 (buffer-substring (point) (point-at-eol)))))))
115
116(declare-function inversion-check-version "inversion")
117
118(defun cedet-gnu-global-version-check (&optional noerror)
119 "Check the version of the installed GNU Global command.
120If optional programatic argument NOERROR is non-nil, then
121instead of throwing an error if Global isn't available, then
122return nil."
123 (interactive)
124 (require 'inversion)
125 (let ((b (condition-case nil
126 (cedet-gnu-global-call (list "--version"))
127 (error nil)))
128 (rev nil))
129 (if (not b)
130 (progn
131 (when (interactive-p)
132 (message "GNU Global not found."))
133 nil)
134 (save-excursion
135 (set-buffer b)
136 (goto-char (point-min))
137 (re-search-forward "GNU GLOBAL \\([0-9.]+\\)" nil t)
138 (setq rev (match-string 1))
139 (if (inversion-check-version rev nil cedet-global-min-version)
140 (if noerror
141 nil
142 (error "Version of GNU Global is %s. Need at least %s"
143 rev cedet-global-min-version))
144 ;; Else, return TRUE, as in good enough.
145 (when (interactive-p)
146 (message "GNU Global %s - Good enough for CEDET." rev))
147 t)))))
148
149(defun cedet-gnu-global-scan-hits (buffer)
150 "Scan all the hits from the GNU Global output BUFFER."
151 (let ((hits nil)
152 (r1 "^\\([^ ]+\\) +\\([0-9]+\\) \\([^ ]+\\) "))
153 (save-excursion
154 (set-buffer buffer)
155 (goto-char (point-min))
156 (while (re-search-forward r1 nil t)
157 (setq hits (cons (cons (string-to-number (match-string 2))
158 (match-string 3))
159 hits)))
160 ;; Return the results
161 (nreverse hits))))
162
163(provide 'cedet-global)
164
165;;; 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..f550e2af506
--- /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(defvar cedet-idutils-min-version "4.0"
32 "Minimum version of ID Utils required.")
33
34(defcustom cedet-idutils-file-command "fnid"
35 "Command name for the ID Utils executable for searching file names."
36 :type 'string
37 :group 'cedet)
38
39(defcustom cedet-idutils-token-command "lid"
40 "Command name for the ID Utils executable for searching for tokens."
41 :type 'string
42 :group 'cedet)
43
44(defun cedet-idutils-search (searchtext texttype type scope)
45 "Perform a search with IDUtils, return the created buffer.
46SEARCHTEXT is text to find.
47TEXTTYPE is the type of text, such as 'regexp, 'string, 'tagname,
48'tagregexp, or 'tagcompletions.
49TYPE is the type of search, meaning that SEARCHTEXT is compared to
50filename, tagname (tags table), references (uses of a tag) , or
51symbol (uses of something not in the tag table.)
52SCOPE is the scope of the search, such as 'project or 'subdirs.
53Note: Scope is not yet supported."
54 (if (eq type 'file)
55 ;; Calls for file stuff is very simple.
56 (cedet-idutils-fnid-call (list searchtext))
57 ;; Calls for text searches is more complex.
58 (let* ((resultflg (if (eq texttype 'tagcompletions)
59 (list "--key=token")
60 (list "--result=grep")))
61 (scopeflgs nil) ; (cond ((eq scope 'project) "" ) ((eq scope 'target) "l")))
62 (stflag (cond ((or (eq texttype 'tagname)
63 (eq texttype 'tagregexp))
64 (list "-r" "-w"))
65 ((eq texttype 'tagcompletions)
66 ;; Add regex to search text for beginning of char.
67 (setq searchtext (concat "^" searchtext))
68 (list "-r" "-s" ))
69 ((eq texttype 'regexp)
70 (list "-r"))
71 ;; t means 'symbol
72 (t (list "-l" "-w"))))
73 )
74 (cedet-idutils-lid-call (append resultflg scopeflgs stflag (list searchtext))))
75 ))
76
77(defun cedet-idutils-fnid-call (flags)
78 "Call ID Utils fnid with the list of FLAGS.
79Return the created buffer with with program output."
80 (let ((b (get-buffer-create "*CEDET fnid*"))
81 (cd default-directory)
82 )
83 (save-excursion
84 (set-buffer b)
85 (setq default-directory cd)
86 (erase-buffer))
87 (apply 'call-process cedet-idutils-file-command
88 nil b nil
89 flags)
90 b))
91
92(defun cedet-idutils-lid-call (flags)
93 "Call ID Utils lid with the list of FLAGS.
94Return the created buffer with with program output."
95 (let ((b (get-buffer-create "*CEDET lid*"))
96 (cd default-directory)
97 )
98 (save-excursion
99 (set-buffer b)
100 (setq default-directory cd)
101 (erase-buffer))
102 (apply 'call-process cedet-idutils-token-command
103 nil b nil
104 flags)
105 b))
106
107;;; UTIL CALLS
108;;
109(defun cedet-idutils-expand-filename (filename)
110 "Expand the FILENAME with IDUtils.
111Return a filename relative to the default directory."
112 (interactive "sFile: ")
113 (let ((ans (save-excursion
114 (set-buffer (cedet-idutils-fnid-call (list filename)))
115 (goto-char (point-min))
116 (if (looking-at "[^ \n]*fnid: ")
117 (error "ID Utils not available")
118 (split-string (buffer-string) "\n" t)))))
119 (setq ans (mapcar 'expand-file-name ans))
120 (when (interactive-p)
121 (if ans
122 (if (= (length ans) 1)
123 (message "%s" (car ans))
124 (message "%s + %d others" (car ans)
125 (length (cdr ans))))
126 (error "No file found")))
127 ans))
128
129(defun cedet-idutils-support-for-directory (&optional dir)
130 "Return non-nil if IDUtils has a support file for DIR.
131If DIR is not supplied, use the current default directory.
132This works by running lid on a bogus symbol, and looking for
133the error code."
134 (save-excursion
135 (let ((default-directory (or dir default-directory)))
136 (condition-case nil
137 (progn
138 (set-buffer (cedet-idutils-fnid-call '("moose")))
139 (goto-char (point-min))
140 (if (looking-at "[^ \n]*fnid: ")
141 nil
142 t))
143 (error nil)))))
144
145(declare-function inversion-check-version "inversion")
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/cedet.el b/lisp/cedet/cedet.el
new file mode 100644
index 00000000000..4e760838120
--- /dev/null
+++ b/lisp/cedet/cedet.el
@@ -0,0 +1,130 @@
1;;; cedet.el --- Setup CEDET environment
2
3;;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
4;;; Free Software Foundation, Inc.
5
6;; Author: David Ponce <david@dponce.com>
7;; Maintainer: Eric M. Ludlam <zappo@gnu.org>
8;; Version: 0.2
9;; Keywords: OO, lisp
10
11;; This file is part of GNU Emacs.
12
13;; GNU Emacs is free software: you can redistribute it and/or modify
14;; it under the terms of the GNU General Public License as published by
15;; the Free Software Foundation, either version 3 of the License, or
16;; (at your option) any later version.
17
18;; GNU Emacs is distributed in the hope that it will be useful,
19;; but WITHOUT ANY WARRANTY; without even the implied warranty of
20;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
21;; GNU General Public License for more details.
22
23;; You should have received a copy of the GNU General Public License
24;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
25
26;;; Commentary:
27;;
28;; This library automatically setups your [X]Emacs to use CEDET tools.
29;;
30;; (require 'cedet)
31;;
32;; If you want to turn on useful or all Semantic features by default,
33;; respectively add:
34;;
35;; (setq semantic-load-turn-useful-things-on t)
36;; or
37;; (setq semantic-load-turn-everything-on t)
38;;
39;; before loading this file, like this:
40;;
41;; (setq semantic-load-turn-useful-things-on t)
42;; (require 'cedet)
43;;
44;; That's it!
45
46;;; Code:
47
48(eval-when-compile
49 (require 'cl))
50
51(defconst cedet-version "1.0pre7"
52 "Current version of CEDET.")
53
54(require 'eieio)
55;; (require 'semantic)
56;; (require 'srecode)
57;; (require 'ede)
58(require 'speedbar)
59
60(defconst cedet-packages
61 `(
62 ;;PACKAGE MIN-VERSION
63 (cedet ,cedet-version)
64 (eieio "1.2")
65 (semantic "2.0pre7")
66 (srecode "0.2")
67 (ede "1.0pre7")
68 (speedbar "1.0.3"))
69 "Table of CEDET packages to install.")
70
71(declare-function inversion-find-version "inversion")
72
73(defun cedet-version ()
74 "Display all active versions of CEDET and Dependant packages.
75
76The PACKAGE column is the name of a given package from CEDET.
77
78REQUESTED VERSION is the version requested by the CEDET load script.
79See `cedet-packages' for details.
80
81FILE VERSION is the version number found in the source file
82for the specificed PACKAGE.
83
84LOADED VERSION is the version of PACKAGE current loaded in Emacs
85memory and (presumably) running in this Emacs instance. Value is X
86if the package has not been loaded."
87 (interactive)
88 (require 'inversion)
89 (with-output-to-temp-buffer "*CEDET*"
90 (princ "CEDET Version:\t") (princ cedet-version)
91 (princ "\n \t\t\tRequested\tFile\t\tLoaded")
92 (princ "\n Package\t\tVersion\t\tVersion\t\tVersion")
93 (princ "\n ----------------------------------------------------------")
94 (let ((p cedet-packages))
95 (while p
96 (let ((sym (symbol-name (car (car p)))))
97 (princ "\n ")
98 (princ sym)
99 (princ ":\t")
100 (if (< (length sym) 5)
101 (princ "\t"))
102 (if (< (length sym) 13)
103 (princ "\t"))
104 (let ((reqver (nth 1 (car p)))
105 (filever (car (inversion-find-version sym)))
106 (loadver (when (featurep (car (car p)))
107 (symbol-value (intern-soft (concat sym "-version"))))))
108 (princ reqver)
109 (if (< (length reqver) 8) (princ "\t"))
110 (princ "\t")
111 (if (string= filever reqver)
112 ;; I tried the words "check" and "match", but that
113 ;; just looked lame.
114 (princ "ok\t")
115 (princ filever)
116 (if (< (length filever) 8) (princ "\t")))
117 (princ "\t")
118 (if loadver
119 (if (string= loadver reqver)
120 (princ "ok")
121 (princ loadver))
122 (princ "Not Loaded"))
123 ))
124 (setq p (cdr p))))
125 (princ "\n\n\nC-h f cedet-version RET\n for details on output format.")
126 ))
127
128(provide 'cedet)
129
130;;; cedet.el ends here
diff --git a/lisp/cedet/inversion.el b/lisp/cedet/inversion.el
new file mode 100644
index 00000000000..95608c4df0d
--- /dev/null
+++ b/lisp/cedet/inversion.el
@@ -0,0 +1,601 @@
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(defvar inversion-incompatible-version "0.1alpha1"
78 "An earlier release which is incompatible with this release.")
79
80(defconst inversion-decoders
81 '(
82 (alpha "^\\([0-9]+\\)\\.\\([0-9]+\\)\\s-*alpha\\([0-9]+\\)?$" 3)
83 (beta "^\\([0-9]+\\)\\.\\([0-9]+\\)\\s-*beta\\([0-9]+\\)?$" 3)
84 (beta "^\\([0-9]+\\)\\.\\([0-9]+\\)\\s-*(beta\\([0-9]+\\)?)" 3)
85 (prerelease "^\\([0-9]+\\)\\.\\([0-9]+\\)\\s-*pre\\([0-9]+\\)?$" 3)
86 (full "^\\([0-9]+\\)\\.\\([0-9]+\\)$" 2)
87 (fullsingle "^\\([0-9]+\\)$" 1)
88 (patch "^\\([0-9]+\\)\\.\\([0-9]+\\) (patch \\([0-9]+\\))" 3)
89 (point "^\\([0-9]+\\)\\.\\([0-9]+\\)\\.\\([0-9]+\\)$" 3)
90 (build "^\\([0-9]+\\)\\.\\([0-9]+\\)\\.\\([0-9]+\\).\\([0-9]+\\)$" 4)
91 )
92 "List of decoders for version strings.
93Each decoder is of the form:
94
95 ( RELEASE-TYPE REGEXP MAX )
96
97RELEASE-TYPE is a symbol specifying something like `beta' or `alpha'.
98REGEXP is the regular expression to match a version string.
99MAX is the maximum number of match-numbers in the release number.
100Decoders must be ordered to decode least stable versions before the
101more stable ones.")
102
103;;; Version Checking
104;;
105(defun inversion-decode-version (version-string)
106 "Decode VERSION-STRING into an encoded list.
107Return value is of the form:
108 (RELEASE MAJOR MINOR ...)
109where RELEASE is a symbol such as `full', or `beta'."
110 (let ((decoders inversion-decoders)
111 (result nil))
112 (while (and decoders (not result))
113 (if (string-match (nth 1 (car decoders)) version-string)
114 (let ((ver nil)
115 (num-left (nth 2 (car decoders)))
116 (count 1))
117 (while (<= count num-left)
118 (setq ver (cons
119 (if (match-beginning count)
120 (string-to-number
121 (substring version-string
122 (match-beginning count)
123 (match-end count)))
124 1)
125 ver)
126 count (1+ count)))
127 (setq result (cons (caar decoders) (nreverse ver))))
128 (setq decoders (cdr decoders))))
129 result))
130
131(defun inversion-package-version (package)
132 "Return the decoded version for PACKAGE."
133 (let ((ver (symbol-value
134 (intern-soft
135 (concat (symbol-name package)
136 "-version"))))
137 (code nil))
138 (unless ver
139 (error "Package %S does not define %S-version" package package))
140 ;; Decode the code
141 (setq code (inversion-decode-version ver))
142 (unless code
143 (error "%S-version value cannot be decoded" package))
144 code))
145
146(defun inversion-package-incompatibility-version (package)
147 "Return the decoded incompatibility version for PACKAGE.
148The incompatibility version is specified by the programmer of
149a package when a package is not backward compatible. It is
150not an indication of new features or bug fixes."
151 (let ((ver (symbol-value
152 (intern-soft
153 (concat (symbol-name package)
154 "-incompatible-version")))))
155 (if (not ver)
156 nil
157 ;; Decode the code
158 (inversion-decode-version ver))))
159
160(defun inversion-recode (code)
161 "Convert CODE into a string."
162 (let ((r (nth 0 code)) ; release-type
163 (n (nth 1 code)) ; main number
164 (i (nth 2 code)) ; first increment
165 (p (nth 3 code))) ; second increment
166 (cond
167 ((eq r 'full)
168 (setq r "" p ""))
169 ((eq r 'point)
170 (setq r ".")))
171 (format "%s.%s%s%s" n i r p)))
172
173(defun inversion-release-to-number (release-symbol)
174 "Convert RELEASE-SYMBOL into a number."
175 (let* ((ra (assoc release-symbol inversion-decoders))
176 (rn (- (length inversion-decoders)
177 (length (member ra inversion-decoders)))))
178 rn))
179
180(defun inversion-= (ver1 ver2)
181 "Return non-nil if VER1 is equal to VER2."
182 (equal ver1 ver2))
183
184(defun inversion-< (ver1 ver2)
185 "Return non-nil if VER1 is less than VER2."
186 (let ((v1-0 (inversion-release-to-number (nth 0 ver1)))
187 (v1-1 (nth 1 ver1))
188 (v1-2 (nth 2 ver1))
189 (v1-3 (nth 3 ver1))
190 (v1-4 (nth 4 ver1))
191 ;; v2
192 (v2-0 (inversion-release-to-number (nth 0 ver2)))
193 (v2-1 (nth 1 ver2))
194 (v2-2 (nth 2 ver2))
195 (v2-3 (nth 3 ver2))
196 (v2-4 (nth 4 ver2))
197 )
198 (or (and (= v1-0 v2-0)
199 (= v1-1 v2-1)
200 (= v1-2 v2-2)
201 (= v1-3 v2-3)
202 v1-4 v2-4 ; all or nothin if elt - is =
203 (< v1-4 v2-4))
204 (and (= v1-0 v2-0)
205 (= v1-1 v2-1)
206 (= v1-2 v2-2)
207 v1-3 v2-3 ; all or nothin if elt - is =
208 (< v1-3 v2-3))
209 (and (= v1-1 v2-1)
210 (< v1-2 v2-2))
211 (and (< v1-1 v2-1))
212 (and (< v1-0 v2-0)
213 (= v1-1 v2-1)
214 (= v1-2 v2-2)
215 )
216 )))
217
218(defun inversion-check-version (version incompatible-version
219 minimum &rest reserved)
220 "Check that a given version meets the minimum requirement.
221VERSION, INCOMPATIBLE-VERSION and MINIMUM are of similar format to
222return entries of `inversion-decode-version', or a classic version
223string. INCOMPATIBLE-VERSION can be nil.
224RESERVED arguments are kept for a later use.
225Return:
226- nil if everything is ok
227- 'outdated if VERSION is less than MINIMUM.
228- 'incompatible if VERSION is not backward compatible with MINIMUM.
229- t if the check failed."
230 (let ((code (if (stringp version)
231 (inversion-decode-version version)
232 version))
233 (req (if (stringp minimum)
234 (inversion-decode-version minimum)
235 minimum))
236 )
237 ;; Perform a test.
238 (cond
239 ((inversion-= code req)
240 ;; Same version.. Yay!
241 nil)
242 ((inversion-< code req)
243 ;; Version is too old!
244 'outdated)
245 ((inversion-< req code)
246 ;; Newer is installed. What to do?
247 (let ((incompatible
248 (if (stringp incompatible-version)
249 (inversion-decode-version incompatible-version)
250 incompatible-version)))
251 (cond
252 ((not incompatible) nil)
253 ((or (inversion-= req incompatible)
254 (inversion-< req incompatible))
255 ;; The requested version is = or < than what the package
256 ;; maintainer says is incompatible.
257 'incompatible)
258 ;; Things are ok.
259 (t nil))))
260 ;; Check failed
261 (t t))))
262
263(defun inversion-test (package minimum &rest reserved)
264 "Test that PACKAGE meets the MINIMUM version requirement.
265PACKAGE is a symbol, similar to what is passed to `require'.
266MINIMUM is of similar format to return entries of
267`inversion-decode-version', or a classic version string.
268RESERVED arguments are kept for a later user.
269This depends on the symbols `PACKAGE-version' and optionally
270`PACKAGE-incompatible-version' being defined in PACKAGE.
271Return nil if everything is ok. Return an error string otherwise."
272 (let ((check (inversion-check-version
273 (inversion-package-version package)
274 (inversion-package-incompatibility-version package)
275 minimum reserved)))
276 (cond
277 ((null check)
278 ;; Same version.. Yay!
279 nil)
280 ((eq check 'outdated)
281 ;; Version is too old!
282 (format "You need to upgrade package %s to %s" package minimum))
283 ((eq check 'incompatible)
284 ;; Newer is installed but the requested version is = or < than
285 ;; what the package maintainer says is incompatible, then throw
286 ;; that error.
287 (format "Package %s version is not backward compatible with %s"
288 package minimum))
289 ;; Check failed
290 (t "Inversion version check failed."))))
291
292(defun inversion-reverse-test (package oldversion &rest reserved)
293 "Test that PACKAGE at OLDVERSION is still compatible.
294If something like a save file is loaded at OLDVERSION, this
295test will identify if OLDVERSION is compatible with the current version
296of PACKAGE.
297PACKAGE is a symbol, similar to what is passed to `require'.
298OLDVERSION is of similar format to return entries of
299`inversion-decode-version', or a classic version string.
300RESERVED arguments are kept for a later user.
301This depends on the symbols `PACKAGE-version' and optionally
302`PACKAGE-incompatible-version' being defined in PACKAGE.
303Return nil if everything is ok. Return an error string otherwise."
304 (let ((check (inversion-check-version
305 (inversion-package-version package)
306 (inversion-package-incompatibility-version package)
307 oldversion reserved)))
308 (cond
309 ((null check)
310 ;; Same version.. Yay!
311 nil)
312 ((eq check 'outdated)
313 ;; Version is too old!
314 (format "Package %s version %s is not compatible with current version"
315 package oldversion))
316 ((eq check 'incompatible)
317 ;; Newer is installed but the requested version is = or < than
318 ;; what the package maintainer says is incompatible, then throw
319 ;; that error.
320 (format "Package %s version is not backward compatible with %s"
321 package oldversion))
322 ;; Check failed
323 (t "Inversion version check failed."))))
324
325(defun inversion-require (package version &optional file directory
326 &rest reserved)
327 "Declare that you need PACKAGE with at least VERSION.
328PACKAGE might be found in FILE. (See `require'.)
329Throws an error if VERSION is incompatible with what is installed.
330Optional argument DIRECTORY is a location where new versions of
331this tool can be located. If there is a versioning problem and
332DIRECTORY is provided, inversion will offer to download the file.
333Optional argument RESERVED is saved for later use."
334 (require package file)
335 (let ((err (inversion-test package version)))
336 (when err
337 (if directory
338 (inversion-download-package-ask err package directory version)
339 (error err)))
340 ;; Return the package symbol that was required.
341 package))
342
343(defun inversion-require-emacs (emacs-ver xemacs-ver)
344 "Declare that you need either EMACS-VER, or XEMACS-VER.
345Only checks one based on which kind of Emacs is being run."
346 (let ((err (inversion-test 'emacs
347 (if (featurep 'xemacs)
348 xemacs-ver
349 emacs-ver))))
350 (if err (error err)
351 ;; Something nice...
352 t)))
353
354(defconst inversion-find-data
355 '("(def\\(var\\|const\\)\\s-+%s-%s\\s-+\"\\([^\"]+\\)" 2)
356 "Regexp template and match data index of a version string.")
357
358(defun inversion-find-version (package)
359 "Search for the version and incompatible version of PACKAGE.
360Does not load PACKAGE nor requires that it has been previously loaded.
361Search in the directories in `load-path' for a PACKAGE.el library.
362Visit the file found and search for the declarations of variables or
363constants `PACKAGE-version' and `PACKAGE-incompatible-version'. The
364value of these variables must be a version string.
365
366Return a pair (VERSION-STRING . INCOMPATIBLE-VERSION-STRING) where
367INCOMPATIBLE-VERSION-STRING can be nil.
368Return nil when VERSION-STRING was not found."
369 (let* ((file (locate-library (format "%s.el" package) t))
370 (tag (car inversion-find-data))
371 (idx (nth 1 inversion-find-data))
372 version)
373 (when file
374 (with-temp-buffer
375 ;; The 3000 is a bit arbitrary, but should cut down on
376 ;; fileio as version info usually is at the very top
377 ;; of a file. AFter a long commentary could be bad.
378 (insert-file-contents-literally file nil 0 3000)
379 (goto-char (point-min))
380 (when (re-search-forward (format tag package 'version) nil t)
381 (setq version (list (match-string idx)))
382 (goto-char (point-min))
383 (when (re-search-forward
384 (format tag package 'incompatible-version) nil t)
385 (setcdr version (match-string idx))))))
386 version))
387
388(defun inversion-add-to-load-path (package minimum
389 &optional installdir
390 &rest subdirs)
391 "Add the PACKAGE path to `load-path' if necessary.
392MINIMUM is the minimum version requirement of PACKAGE.
393Optional argument INSTALLDIR is the base directory where PACKAGE is
394installed. It defaults to `default-directory'/PACKAGE.
395SUBDIRS are sub-directories to add to `load-path', following the main
396INSTALLDIR path."
397 (let ((ver (inversion-find-version package)))
398 ;; If PACKAGE not found or a bad version already in `load-path',
399 ;; prepend the new PACKAGE path, so it will be loaded first.
400 (when (or (not ver)
401 (and
402 (inversion-check-version (car ver) (cdr ver) minimum)
403 (message "Outdated %s %s shadowed to meet minimum version %s"
404 package (car ver) minimum)
405 t))
406 (let* ((default-directory
407 (or installdir
408 (expand-file-name (format "./%s" package))))
409 subdir)
410 (when (file-directory-p default-directory)
411 ;; Add SUBDIRS
412 (while subdirs
413 (setq subdir (expand-file-name (car subdirs))
414 subdirs (cdr subdirs))
415 (when (file-directory-p subdir)
416 ;;(message "%S added to `load-path'" subdir)
417 (add-to-list 'load-path subdir)))
418 ;; Add the main path
419 ;;(message "%S added to `load-path'" default-directory)
420 (add-to-list 'load-path default-directory))
421 ;; We get to this point iff we do not accept or there is no
422 ;; system file. Lets check the version of what we just
423 ;; installed... just to be safe.
424 (let ((newver (inversion-find-version package)))
425 (if (not newver)
426 (error "Failed to find version for newly installed %s"
427 package))
428 (if (inversion-check-version (car newver) (cdr newver) minimum)
429 (error "Outdated %s %s just installed" package (car newver)))
430 )))))
431
432;;; Inversion tests
433;;
434(defun inversion-unit-test ()
435 "Test inversion to make sure it can identify different version strings."
436 (interactive)
437 (let ((c1 (inversion-package-version 'inversion))
438 (c1i (inversion-package-incompatibility-version 'inversion))
439 (c2 (inversion-decode-version "1.3alpha2"))
440 (c3 (inversion-decode-version "1.3beta4"))
441 (c4 (inversion-decode-version "1.3 beta5"))
442 (c5 (inversion-decode-version "1.3.4"))
443 (c6 (inversion-decode-version "2.3alpha"))
444 (c7 (inversion-decode-version "1.3"))
445 (c8 (inversion-decode-version "1.3pre1"))
446 (c9 (inversion-decode-version "2.4 (patch 2)"))
447 (c10 (inversion-decode-version "2.4 (patch 3)"))
448 (c11 (inversion-decode-version "2.4.2.1"))
449 (c12 (inversion-decode-version "2.4.2.2"))
450 )
451 (if (not (and
452 (inversion-= c1 c1)
453 (inversion-< c1i c1)
454 (inversion-< c2 c3)
455 (inversion-< c3 c4)
456 (inversion-< c4 c5)
457 (inversion-< c5 c6)
458 (inversion-< c2 c4)
459 (inversion-< c2 c5)
460 (inversion-< c2 c6)
461 (inversion-< c3 c5)
462 (inversion-< c3 c6)
463 (inversion-< c7 c6)
464 (inversion-< c4 c7)
465 (inversion-< c2 c7)
466 (inversion-< c8 c6)
467 (inversion-< c8 c7)
468 (inversion-< c4 c8)
469 (inversion-< c2 c8)
470 (inversion-< c9 c10)
471 (inversion-< c10 c11)
472 (inversion-< c11 c12)
473 ;; Negatives
474 (not (inversion-< c3 c2))
475 (not (inversion-< c4 c3))
476 (not (inversion-< c5 c4))
477 (not (inversion-< c6 c5))
478 (not (inversion-< c7 c2))
479 (not (inversion-< c7 c8))
480 (not (inversion-< c12 c11))
481 ;; Test the tester on inversion
482 (not (inversion-test 'inversion inversion-version))
483 ;; Test that we throw an error
484 (inversion-test 'inversion "0.0.0")
485 (inversion-test 'inversion "1000.0")
486 ))
487 (error "Inversion tests failed")
488 (message "Inversion tests passed."))))
489
490;;; URL and downloading code
491;;
492(defun inversion-locate-package-files (package directory &optional version)
493 "Get a list of distributions of PACKAGE from DIRECTORY.
494DIRECTORY can be an ange-ftp compatible filename, such as:
495 \"/ftp@ftp1.sourceforge.net/pub/sourceforge/PACKAGE\"
496If it is a URL, wget will be used for download.
497Optional argument VERSION will restrict the list of available versions
498to the file matching VERSION exactly, or nil."
499;;DIRECTORY should also allow a URL:
500;; \"http://ftp1.sourceforge.net/PACKAGE\"
501;; but then I can get file listings easily.
502 (if (symbolp package) (setq package (symbol-name package)))
503 (directory-files directory t
504 (if version
505 (concat "^" package "-" version "\\>")
506 package)))
507
508(defvar inversion-package-common-tails '( ".tar.gz"
509 ".tar"
510 ".zip"
511 ".gz"
512 )
513 "Common distribution mechanisms for Emacs Lisp packages.")
514
515(defun inversion-locate-package-files-and-split (package directory &optional version)
516 "Use `inversion-locate-package-files' to get a list of PACKAGE files.
517DIRECTORY is the location where distributions of PACKAGE are.
518VERSION is an optional argument specifying a version to restrict to.
519The return list is an alist with the version string in the CAR,
520and the full path name in the CDR."
521 (if (symbolp package) (setq package (symbol-name package)))
522 (let ((f (inversion-locate-package-files package directory version))
523 (out nil))
524 (while f
525 (let* ((file (car f))
526 (dist (file-name-nondirectory file))
527 (tails inversion-package-common-tails)
528 (verstring nil))
529 (while (and tails (not verstring))
530 (when (string-match (concat (car tails) "$") dist)
531 (setq verstring
532 (substring dist (1+ (length package)) (match-beginning 0))))
533 (setq tails (cdr tails)))
534 (if (not verstring)
535 (error "Cannot decode version for %s" dist))
536 (setq out
537 (cons
538 (cons verstring file)
539 out))
540 (setq f (cdr f))))
541 out))
542
543(defun inversion-download-package-ask (err package directory version)
544 "Due to ERR, offer to download PACKAGE from DIRECTORY.
545The package should have VERSION available for download."
546 (if (symbolp package) (setq package (symbol-name package)))
547 (let ((files (inversion-locate-package-files-and-split
548 package directory version)))
549 (if (not files)
550 (error err)
551 (if (not (y-or-n-p (concat err ": Download update? ")))
552 (error err)
553 (let ((dest (read-directory-name (format "Download %s to: "
554 package)
555 t)))
556 (if (> (length files) 1)
557 (setq files
558 (list
559 "foo" ;; ignored
560 (read-file-name "Version to download: "
561 directory
562 files
563 t
564 (concat
565 (file-name-as-directory directory)
566 package)
567 nil))))
568
569 (copy-file (cdr (car files)) dest))))))
570
571(defun inversion-upgrade-package (package &optional directory)
572 "Try to upgrade PACKAGE in DIRECTORY is available."
573 (interactive "sPackage to upgrade: ")
574 (if (stringp package) (setq package (intern package)))
575 (if (not directory)
576 ;; Hope that the package maintainer specified.
577 (setq directory (symbol-value (or (intern-soft
578 (concat (symbol-name package)
579 "-url"))
580 (intern-soft
581 (concat (symbol-name package)
582 "-directory"))))))
583 (let ((files (inversion-locate-package-files-and-split
584 package directory))
585 (cver (inversion-package-version package))
586 (newer nil))
587 (mapc (lambda (f)
588 (if (inversion-< cver (inversion-decode-version (car f)))
589 (setq newer (cons f newer))))
590 files)
591 newer
592 ))
593
594;; (inversion-upgrade-package
595;; 'semantic
596;; "/ftp@ftp1.sourceforge.net:/pub/sourceforge/cedet")
597
598;; "/ftp@ftp1.sourceforge.net:/pub/sourceforge/cedet"
599(provide 'inversion)
600
601;;; inversion.el ends here
diff --git a/lisp/cedet/pulse.el b/lisp/cedet/pulse.el
new file mode 100644
index 00000000000..e8a9b11dd2f
--- /dev/null
+++ b/lisp/cedet/pulse.el
@@ -0,0 +1,397 @@
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
58(defun pulse-available-p ()
59 "Return non-nil if pulsing is available on the current frame."
60 (condition-case nil
61 (let ((v (color-values (face-background 'default))))
62 (numberp (car-safe v)))
63 (error nil)))
64
65(defcustom pulse-flag (pulse-available-p)
66 "*Non-nil means to pulse the overlay face for momentary highlighting.
67Pulsing involves a bright highlight that slowly shifts to the background
68color. Non-nil just means to highlight with an unchanging color for a short
69time.
70
71If `pulse-flag' is non-nil, but `pulse-available-p' is nil, then
72this flag is ignored."
73 :group 'pulse
74 :type 'boolean)
75
76(defface pulse-highlight-start-face
77 '((((class color) (background dark))
78 (:background "#AAAA33"))
79 (((class color) (background light))
80 (:background "#FFFFAA")))
81 "*Face used at beginning of a highight."
82 :group 'pulse)
83
84(defface pulse-highlight-face
85 '((((class color) (background dark))
86 (:background "#AAAA33"))
87 (((class color) (background light))
88 (:background "#FFFFAA")))
89 "*Face used during a pulse for display. *DO NOT CUSTOMIZE*
90Face used for temporary highlighting of tags for effect."
91 :group 'pulse)
92
93;;; Compatibility
94(defalias 'pulse-overlay-live-p 'overlay-buffer)
95(defalias 'pulse-overlay-put 'overlay-put)
96(defalias 'pulse-overlay-get 'overlay-get)
97(defalias 'pulse-overlay-delete 'delete-overlay)
98(defalias 'pulse-make-overlay 'make-overlay)
99
100(when (featurep 'xemacs)
101 (defalias 'pulse-overlay-live-p
102 (lambda (o)
103 (and (extent-live-p o)
104 (not (extent-detached-p o))
105 (bufferp (extent-buffer o)))))
106 (defalias 'pulse-overlay-put 'set-extent-property)
107 (defalias 'pulse-overlay-get 'extent-property)
108 (defalias 'pulse-overlay-delete 'delete-extent)
109 (defalias 'pulse-make-overlay 'make-extent))
110
111;;; Code:
112;;
113(defun pulse-int-to-hex (int &optional nb-digits)
114 "Convert integer argument INT to a #XXXXXXXXXXXX format hex string.
115Each X in the output string is a hexadecimal digit.
116NB-DIGITS is the number of hex digits. If INT is too large to be
117represented with NB-DIGITS, then the result is truncated from the
118left. So, for example, INT=256 and NB-DIGITS=2 returns \"00\", since
119the hex equivalent of 256 decimal is 100, which is more than 2 digits.
120
121This function was blindly copied from hexrgb.el by Drew Adams.
122http://www.emacswiki.org/cgi-bin/wiki/hexrgb.el"
123 (setq nb-digits (or nb-digits 4))
124 (substring (format (concat "%0" (int-to-string nb-digits) "X") int) (- nb-digits)))
125
126(defun pulse-color-values-to-hex (values)
127 "Convert list of rgb color VALUES to a hex string, #XXXXXXXXXXXX.
128Each X in the string is a hexadecimal digit.
129Input VALUES is as for the output of `x-color-values'.
130
131This function was blindly copied from hexrgb.el by Drew Adams.
132http://www.emacswiki.org/cgi-bin/wiki/hexrgb.el"
133 (concat "#"
134 (pulse-int-to-hex (nth 0 values) 4) ; red
135 (pulse-int-to-hex (nth 1 values) 4) ; green
136 (pulse-int-to-hex (nth 2 values) 4))) ; blue
137
138(defcustom pulse-iterations 10
139 "Number of iterations in a pulse operation."
140 :group 'pulse
141 :type 'number)
142(defcustom pulse-delay .03
143 "Delay between face lightening iterations, as used by `sit-for'."
144 :group 'pulse
145 :type 'number)
146
147(defun pulse-lighten-highlight ()
148 "Lighten the face by 1/`pulse-iterations' toward the background color.
149Return t if there is more drift to do, nil if completed."
150 (if (>= (get 'pulse-highlight-face :iteration) pulse-iterations)
151 nil
152 (let* ((frame (color-values (face-background 'default)))
153 (start (color-values (face-background
154 (get 'pulse-highlight-face
155 :startface))))
156 (frac (list (/ (- (nth 0 frame) (nth 0 start)) pulse-iterations)
157 (/ (- (nth 1 frame) (nth 1 start)) pulse-iterations)
158 (/ (- (nth 2 frame) (nth 2 start)) pulse-iterations)))
159 (it (get 'pulse-highlight-face :iteration))
160 )
161 (set-face-background 'pulse-highlight-face
162 (pulse-color-values-to-hex
163 (list
164 (+ (nth 0 start) (* (nth 0 frac) it))
165 (+ (nth 1 start) (* (nth 1 frac) it))
166 (+ (nth 2 start) (* (nth 2 frac) it)))))
167 (put 'pulse-highlight-face :iteration (1+ it))
168 (if (>= (1+ it) pulse-iterations)
169 nil
170 t))))
171
172(defun pulse-reset-face (&optional face)
173 "Reset the pulse highlighting FACE."
174 (set-face-background 'pulse-highlight-face
175 (if face
176 (face-background face)
177 (face-background 'pulse-highlight-start-face)
178 ))
179 (put 'pulse-highlight-face :startface (or face
180 'pulse-highlight-start-face))
181 (put 'pulse-highlight-face :iteration 0))
182
183(defun pulse (&optional face)
184 "Pulse the colors on our highlight face.
185If optional FACE is provide, reset the face to FACE color,
186instead of `pulse-highlight-start-face'.
187Be sure to call `pulse-reset-face' after calling pulse."
188 (unwind-protect
189 (progn
190 (pulse-reset-face face)
191 (while (and (pulse-lighten-highlight)
192 (sit-for pulse-delay))
193 nil))
194 ))
195
196(defun pulse-test (&optional no-error)
197 "Test the lightening function for pulsing a line.
198When optional NO-ERROR Don't throw an error if we can't run tests."
199 (interactive)
200 (if (or (not pulse-flag) (not (pulse-available-p)))
201 (if no-error
202 nil
203 (error (concat "Pulse test only works on versions of Emacs"
204 " that support pulsing")))
205 ;; Run the tests
206 (when (interactive-p)
207 (message "<Press a key> Pulse one line.")
208 (read-char))
209 (pulse-momentary-highlight-one-line (point))
210 (when (interactive-p)
211 (message "<Press a key> Pulse a region.")
212 (read-char))
213 (pulse-momentary-highlight-region (point)
214 (save-excursion
215 (condition-case nil
216 (forward-char 30)
217 (error nil))
218 (point)))
219 (when (interactive-p)
220 (message "<Press a key> Pulse line a specific color.")
221 (read-char))
222 (pulse-momentary-highlight-one-line (point) 'modeline)
223 (when (interactive-p)
224 (message "<Press a key> Pulse a pre-existing overlay.")
225 (read-char))
226 (let* ((start (point-at-bol))
227 (end (save-excursion
228 (end-of-line)
229 (when (not (eobp))
230 (forward-char 1))
231 (point)))
232 (o (pulse-make-overlay start end))
233 )
234 (pulse-momentary-highlight-overlay o)
235 (if (pulse-overlay-live-p o)
236 (pulse-overlay-delete o)
237 (error "Non-temporary overlay was deleted!"))
238 )
239 (when (interactive-p)
240 (message "Done!"))))
241
242
243;;; Convenience Functions
244;;
245(defvar pulse-momentary-overlay nil
246 "The current pulsing overlay.")
247
248(defun pulse-momentary-highlight-overlay (o &optional face)
249 "Pulse the overlay O, unhighlighting before next command.
250Optional argument FACE specifies the fact to do the highlighting."
251 (pulse-overlay-put o 'original-face (pulse-overlay-get o 'face))
252 (add-to-list 'pulse-momentary-overlay o)
253 (if (or (not pulse-flag) (not (pulse-available-p)))
254 ;; Provide a face... clear on next command
255 (progn
256 (pulse-overlay-put o 'face (or face 'pulse-highlight-start-face))
257 (add-hook 'pre-command-hook
258 'pulse-momentary-unhighlight)
259 )
260 ;; pulse it.
261 (unwind-protect
262 (progn
263 (pulse-overlay-put o 'face 'pulse-highlight-face)
264 ;; The pulse function puts FACE onto 'pulse-highlight-face.
265 ;; Thus above we put our face on the overlay, but pulse
266 ;; with a reference face needed for the color.
267 (pulse face))
268 (pulse-momentary-unhighlight))
269 )
270 )
271
272(defun pulse-momentary-unhighlight ()
273 "Unhighlight a line recently highlighted."
274 ;; If someone passes in an overlay, then pulse-momentary-overlay
275 ;; will still be nil, and won't need modifying.
276 (when pulse-momentary-overlay
277 ;; clear the starting face
278 (mapc
279 (lambda (ol)
280 (pulse-overlay-put ol 'face (pulse-overlay-get ol 'original-face))
281 (pulse-overlay-put ol 'original-face nil)
282 ;; Clear the overlay if it needs deleting.
283 (when (pulse-overlay-get ol 'pulse-delete) (pulse-overlay-delete ol)))
284 pulse-momentary-overlay)
285
286 ;; Clear the variable.
287 (setq pulse-momentary-overlay nil))
288
289 ;; Reset the pulsing face.
290 (pulse-reset-face)
291
292 ;; Remove this hook.
293 (remove-hook 'pre-command-hook 'pulse-momentary-unhighlight)
294 )
295
296(defun pulse-momentary-highlight-one-line (point &optional face)
297 "Highlight the line around POINT, unhighlighting before next command.
298Optional argument FACE specifies the face to do the highlighting."
299 (let ((start (point-at-bol))
300 (end (save-excursion
301 (end-of-line)
302 (when (not (eobp))
303 (forward-char 1))
304 (point))))
305 (pulse-momentary-highlight-region start end face)
306 ))
307
308(defun pulse-momentary-highlight-region (start end &optional face)
309 "Highlight between START and END, unhighlighting before next command.
310Optional argument FACE specifies the fact to do the highlighting."
311 (let ((o (pulse-make-overlay start end)))
312 ;; Mark it for deletion
313 (pulse-overlay-put o 'pulse-delete t)
314 (pulse-momentary-highlight-overlay o face)))
315
316;;; Random integration with other tools
317;;
318(defvar pulse-command-advice-flag nil
319 "Non-nil means pulse advice is active.
320To active pulse advice, use `pulse-enable-integration-advice'.")
321
322(defun pulse-toggle-integration-advice (arg)
323 "Toggle activation of advised functions that will now pulse.
324Wint no ARG, toggle the pulse advice.
325With a negative ARG, disable pulse advice.
326With a positive ARG, enable pulse advice.
327Currently advised functions include:
328 `goto-line'
329 `exchange-point-and-mark'
330 `find-tag'
331 `tags-search'
332 `tags-loop-continue'
333 `pop-tag-mark'
334 `imenu-default-goto-function'
335Pulsing via `pulse-line-hook-function' has also been added to
336the following hook:
337 `next-error-hook'"
338 (interactive "P")
339 (if (null arg)
340 (setq pulse-command-advice-flag (not pulse-command-advice-flag))
341 (if (< (prefix-numeric-value arg) 0)
342 (setq pulse-command-advice-flag nil)
343 (setq pulse-command-advice-flag t)
344 )
345 )
346 (if pulse-command-advice-flag
347 (message "Pulse advice enabled")
348 (message "Pulse advice disabled"))
349 )
350
351(defadvice goto-line (after pulse-advice activate)
352 "Cause the line that is `goto'd to pulse when the cursor gets there."
353 (when (and pulse-command-advice-flag (interactive-p))
354 (pulse-momentary-highlight-one-line (point))))
355
356(defadvice exchange-point-and-mark (after pulse-advice activate)
357 "Cause the line that is `goto'd to pulse when the cursor gets there."
358 (when (and pulse-command-advice-flag (interactive-p)
359 (> (abs (- (point) (mark))) 400))
360 (pulse-momentary-highlight-one-line (point))))
361
362(defadvice find-tag (after pulse-advice activate)
363 "After going to a tag, pulse the line the cursor lands on."
364 (when (and pulse-command-advice-flag (interactive-p))
365 (pulse-momentary-highlight-one-line (point))))
366
367(defadvice tags-search (after pulse-advice activate)
368 "After going to a hit, pulse the line the cursor lands on."
369 (when (and pulse-command-advice-flag (interactive-p))
370 (pulse-momentary-highlight-one-line (point))))
371
372(defadvice tags-loop-continue (after pulse-advice activate)
373 "After going to a hit, pulse the line the cursor lands on."
374 (when (and pulse-command-advice-flag (interactive-p))
375 (pulse-momentary-highlight-one-line (point))))
376
377(defadvice pop-tag-mark (after pulse-advice activate)
378 "After going to a hit, pulse the line the cursor lands on."
379 (when (and pulse-command-advice-flag (interactive-p))
380 (pulse-momentary-highlight-one-line (point))))
381
382(defadvice imenu-default-goto-function (after pulse-advice activate)
383 "After going to a tag, pulse the line the cursor lands on."
384 (when pulse-command-advice-flag
385 (pulse-momentary-highlight-one-line (point))))
386
387(defun pulse-line-hook-function ()
388 "Function used in hooks to pulse the current line.
389Only pulses the line if `pulse-command-advice-flag' is non-nil."
390 (when pulse-command-advice-flag
391 (pulse-momentary-highlight-one-line (point))))
392
393(add-hook 'next-error-hook 'pulse-line-hook-function)
394
395(provide 'pulse)
396
397;;; pulse.el ends here
generated by cgit v1.2.1 (git 2.18.0) at 2026-02-20 06:09:17 +0000