0
|
1 ;;!emacs
|
|
2 ;;
|
|
3 ;; FILE: br-ftr.el
|
|
4 ;; SUMMARY: OO-Browser feature browsing support.
|
|
5 ;; USAGE: GNU Emacs Lisp Library
|
|
6 ;; KEYWORDS: oop, tools
|
|
7 ;;
|
|
8 ;; AUTHOR: Bob Weiner
|
100
|
9 ;; ORG: InfoDock Associates
|
0
|
10 ;;
|
|
11 ;; ORIG-DATE: 20-Aug-91 at 18:16:36
|
120
|
12 ;; LAST-MOD: 18-Mar-97 at 22:19:28 by Bob Weiner
|
0
|
13 ;;
|
100
|
14 ;; Copyright (C) 1991-1996, Free Software Foundation, Inc.
|
0
|
15 ;; See the file BR-COPY for license information.
|
|
16 ;;
|
|
17 ;; This file is part of the OO-Browser.
|
|
18 ;;
|
|
19 ;; DESCRIPTION:
|
|
20 ;; DESCRIP-END.
|
|
21
|
|
22 ;;; ************************************************************************
|
|
23 ;;; Public variables
|
|
24 ;;; ************************************************************************
|
|
25
|
|
26 (defconst br-feature-type-regexp "[-+=@%>1/]"
|
100
|
27 "Regular expression which matches the first non-whitespace character in an OO-Browser feature listing.")
|
0
|
28
|
|
29 ;;; ************************************************************************
|
|
30 ;;; Public functions
|
|
31 ;;; ************************************************************************
|
|
32
|
100
|
33 (defun br-edit-feature (class feature-name &optional other-win view-only)
|
|
34 "Edit the definition of CLASS' FEATURE-NAME, optionally in some OTHER-WIN if non-nil.
|
|
35 With optional VIEW-ONLY non-nil, view the feature definition instead of editing it.
|
|
36 Return the pathname of the feature definition if found, else nil."
|
|
37 (interactive
|
|
38 (list nil (br-feature-complete 'must-match "Edit feature definition:")
|
|
39 nil nil))
|
|
40 (let ((tag-and-file (br-feature-tag-and-file
|
|
41 (if (null class)
|
|
42 ;; Assume feature-name includes prepended class in
|
|
43 ;; proper format, e.g. when called interactively.
|
|
44 (regexp-quote feature-name)
|
|
45 (br-feature-tag-regexp class feature-name)))))
|
|
46 (if tag-and-file (br-edit-feature-from-tag
|
|
47 (car tag-and-file) (cdr tag-and-file) other-win view-only))))
|
0
|
48
|
100
|
49 (defun br-edit-feature-from-tag (tag-entry feature-path &optional other-win view-only)
|
|
50 "Edit feature for OO-Browser TAG-ENTRY of file FEATURE-PATH, optionally in OTHER-WIN if non-nil.
|
0
|
51 With optional VIEW-ONLY, view feature definition instead of editing it.
|
|
52 Return FEATURE-PATH if feature definition is found, else nil."
|
|
53 (let ((err))
|
|
54 (cond ((and feature-path (file-readable-p feature-path))
|
|
55 (cond ((br-feature-found-p feature-path tag-entry nil other-win)
|
|
56 (br-major-mode)
|
|
57 (if view-only
|
|
58 (setq buffer-read-only t)
|
|
59 ;; Handle case of already existing buffer in
|
|
60 ;; read only mode.
|
|
61 (and buffer-read-only
|
|
62 (file-writable-p feature-path)
|
|
63 (setq buffer-read-only nil)))
|
|
64 ;; Force mode-line redisplay
|
|
65 (set-buffer-modified-p (buffer-modified-p)))
|
|
66 ((interactive-p)
|
|
67 (setq err
|
|
68 (format
|
100
|
69 "(OO-Browser): No `%s' feature defined in Environment."
|
0
|
70 tag-entry)
|
|
71 feature-path nil))))
|
|
72 ((interactive-p)
|
|
73 (setq err
|
|
74 (format
|
100
|
75 "(OO-Browser): `%s' - src file not found or not readable, %s"
|
0
|
76 tag-entry feature-path)
|
|
77 feature-path nil)))
|
|
78 (if err (error err))
|
|
79 feature-path))
|
|
80
|
100
|
81 (defun br-find-feature (&optional feature-entry view-only other-win)
|
|
82 "Display feature definition for FEATURE-ENTRY in VIEW-ONLY mode if non-nil.
|
|
83 Return feature path if FEATURE-ENTRY is successfully displayed, nil
|
|
84 otherwise. Can also signal an error when called interactively."
|
|
85 (interactive)
|
|
86 (and (interactive-p) (setq view-only current-prefix-arg))
|
|
87 (let ((feature-path))
|
|
88 (setq feature-entry
|
|
89 (br-feature-signature-and-file
|
|
90 (or feature-entry
|
|
91 (br-feature-complete 'must-match
|
|
92 (if view-only
|
|
93 "View feature definition:"
|
|
94 "Edit feature definition:"))))
|
|
95 feature-path (cdr feature-entry)
|
|
96 feature-entry (car feature-entry))
|
|
97 (br-edit-feature-from-tag feature-entry feature-path other-win view-only)))
|
|
98
|
0
|
99 (defun br-find-feature-entry ()
|
|
100 "Return feature entry that point is within or nil."
|
|
101 (if (= (point) (point-max)) (skip-chars-backward " \t\n"))
|
|
102 (save-excursion
|
|
103 (beginning-of-line)
|
|
104 (if (or
|
|
105 (progn (skip-chars-forward " \t")
|
|
106 (looking-at br-feature-entry))
|
|
107 ;; Get current feature signature, if any.
|
|
108 (br-feature-get-signature))
|
|
109 (let ((feature (buffer-substring
|
|
110 (point)
|
|
111 (progn (skip-chars-forward "^\t\n\r") (point)))))
|
|
112 (if (and (equal br-lang-prefix "objc-")
|
|
113 ;; Remove any trailing class from a category entry.
|
|
114 (string-match "@ ([^\)]+)" feature))
|
|
115 (substring feature 0 (match-end 0))
|
|
116 feature)))))
|
|
117
|
|
118 (defun br-feature-complete (&optional must-match prompt)
|
|
119 "Interactively completes feature entry if possible, and returns it.
|
|
120 Optional MUST-MATCH means must match a completion table entry.
|
|
121 Optional PROMPT is intial prompt string for user."
|
|
122 (interactive)
|
|
123 (let ((default (br-find-feature-entry))
|
|
124 (completion-ignore-case t)
|
|
125 completions
|
|
126 ftr-entry)
|
|
127 ;; Prompt with possible completions of ftr-entry.
|
|
128 (setq prompt (or prompt "Feature entry:")
|
|
129 completions (br-feature-completions)
|
|
130 ftr-entry
|
|
131 (if completions
|
|
132 (completing-read
|
|
133 (format "%s (default %s) " prompt default)
|
|
134 completions nil must-match)
|
|
135 (read-string
|
|
136 (format "%s (default %s) " prompt default))))
|
|
137 (if (equal ftr-entry "") default ftr-entry)))
|
|
138
|
|
139 (defun br-feature-completions ()
|
|
140 "Return completion alist of all current Environment elements."
|
|
141 (cond ((not (and br-feature-tags-file (file-exists-p br-feature-tags-file)
|
|
142 (file-readable-p br-feature-tags-file)))
|
|
143 nil)
|
|
144 ((and br-feature-tags-completions
|
|
145 (eq
|
|
146 (car (cdr br-feature-tags-completions)) ;; tags last mod time
|
|
147 (apply '+ (nth 5 (file-attributes br-feature-tags-file))))
|
|
148 (equal br-env-file (car br-feature-tags-completions)))
|
|
149 (car (cdr (cdr br-feature-tags-completions))))
|
|
150 (t
|
|
151 (let ((ftr-buf (get-buffer-create "*ftr-buf*"))
|
|
152 (ftr-alist))
|
|
153 (save-excursion
|
|
154 (br-feature-tags-init)
|
|
155 (copy-to-buffer ftr-buf 1 (point-max))
|
|
156 (set-buffer ftr-buf)
|
|
157 (goto-char 1)
|
|
158 (while (search-forward "\^L" nil t)
|
|
159 (forward-line 1)
|
|
160 ;; Skip past pathname where features are defined.
|
|
161 (while (and (= (forward-line 1) 0)
|
|
162 (not (looking-at "\^L\\|\\'")))
|
|
163 (setq ftr-alist (cons (cons (br-feature-signature-to-name
|
|
164 (br-feature-current)
|
100
|
165 t t)
|
0
|
166 nil)
|
|
167 ftr-alist)))))
|
|
168 (kill-buffer ftr-buf)
|
|
169 (setq br-feature-tags-completions
|
|
170 (list br-env-file
|
|
171 ;; tags last mod time
|
|
172 (apply '+ (nth 5 (file-attributes
|
|
173 br-feature-tags-file)))
|
|
174 ftr-alist))
|
|
175 ftr-alist))))
|
|
176
|
|
177 (defun br-feature-def-file (feature-regexp)
|
|
178 "Return file name in which feature matching FEATURE-REGEXP is, if any.
|
|
179 Assume feature tags file is current buffer and leave point at the start of
|
|
180 matching feature tag, if any."
|
|
181 (goto-char 1)
|
|
182 (and (re-search-forward feature-regexp nil t)
|
|
183 ;; This ensures that point is left on the same line as the feature tag
|
|
184 ;; which is found.
|
|
185 (goto-char (match-beginning 0))
|
|
186 (br-feature-file-of-tag)))
|
|
187
|
|
188 (defun br-feature-file (feature-sig)
|
|
189 "Return file name in which feature matching FEATURE-SIG is, if any."
|
|
190 (let ((obuf (current-buffer))
|
|
191 (file))
|
|
192 (set-buffer (funcall br-find-file-noselect-function br-feature-tags-file))
|
|
193 (goto-char 1)
|
120
|
194 ;; Add a newline to feature-sig to avoid matching to signatures that
|
|
195 ;; contain the desired signature's classname as a substring, e.g. when
|
|
196 ;; looking for a signature from Object, we don't want to match to
|
|
197 ;; ClassObject.
|
|
198 (if (search-forward (concat "\n" feature-sig) nil t)
|
0
|
199 (setq file (br-feature-file-of-tag)))
|
|
200 (set-buffer obuf)
|
|
201 file))
|
|
202
|
|
203 (defun br-feature-found-p (buf-file feature-tag
|
|
204 &optional deferred-class other-win regexp-flag)
|
|
205 "Search BUF-FILE for FEATURE-TAG.
|
|
206 Return nil if not found, otherwise display it and return non-nil."
|
|
207 (if buf-file
|
|
208 (let ((found-def)
|
|
209 (opoint (point))
|
|
210 (prev-buf)
|
|
211 (prev-point)
|
|
212 (config (current-window-configuration)))
|
|
213 (setq prev-buf (get-file-buffer buf-file))
|
|
214 (funcall br-edit-file-function buf-file other-win)
|
|
215 (setq prev-point (point))
|
|
216 (widen)
|
|
217 (goto-char (point-min))
|
|
218 (setq found-def
|
|
219 (cond (deferred-class
|
100
|
220 (br-feature-locate-p feature-tag deferred-class))
|
0
|
221 (regexp-flag
|
|
222 (br-feature-locate-p feature-tag regexp-flag))
|
|
223 (t (br-feature-locate-p feature-tag))))
|
|
224 (if found-def
|
|
225 ;; Set appropriate mode for file.
|
|
226 (br-major-mode)
|
|
227 (setq buf-file (get-file-buffer buf-file))
|
|
228 (if prev-buf
|
|
229 (goto-char prev-point)
|
|
230 (if buf-file
|
|
231 (kill-buffer buf-file)
|
|
232 (goto-char prev-point)))
|
|
233 (set-window-configuration config)
|
|
234 (goto-char opoint))
|
|
235 found-def)))
|
|
236
|
|
237 (defun br-feature-name (ftr-entry)
|
|
238 "Return name part of FTR-ENTRY."
|
|
239 (if (equal (string-match br-feature-entry ftr-entry) 0)
|
|
240 (substring ftr-entry (match-beginning 1))
|
|
241 ""))
|
|
242
|
|
243 (defun br-feature-signature-and-file (class-and-feature-name)
|
|
244 "Return (feature signature . feature-def-file-name) of CLASS-AND-FEATURE-NAME."
|
|
245 (let ((obuf (current-buffer))
|
|
246 ;; Find only exact matches
|
|
247 (name-regexp (br-feature-name-to-regexp class-and-feature-name))
|
|
248 (result))
|
|
249 (set-buffer (funcall br-find-file-noselect-function br-feature-tags-file))
|
|
250 (goto-char 1)
|
|
251 (if (re-search-forward name-regexp nil t)
|
|
252 (progn (goto-char (match-beginning 0))
|
|
253 (setq result (cons (br-feature-current)
|
|
254 (br-feature-file-of-tag)))))
|
|
255 (set-buffer obuf)
|
|
256 result))
|
|
257
|
|
258 (defun br-feature-signature (&optional arg)
|
|
259 "Show full feature signature in the view window.
|
|
260 With optional prefix ARG, display signatures of all features from the current
|
|
261 buffer."
|
|
262 (interactive "P")
|
|
263 (let* ((buf (buffer-name))
|
|
264 (owind (selected-window))
|
|
265 (features (delq nil (if arg (br-feature-get-tags)
|
|
266 (list (br-feature-get-signature))))))
|
|
267 (if (null features)
|
|
268 (progn (beep) (message "No elements."))
|
|
269 (br-to-view-window)
|
|
270 (switch-to-buffer (get-buffer-create (concat buf "-Elements")))
|
|
271 (setq buffer-read-only nil)
|
|
272 (erase-buffer)
|
|
273 (mapcar (function (lambda (feature) (insert feature "\n")))
|
|
274 features)
|
|
275 (br-major-mode)
|
|
276 (goto-char 1)
|
|
277 (select-window owind)
|
|
278 (message ""))))
|
|
279
|
|
280 ;;; ************************************************************************
|
|
281 ;;; Listing buffer entry tag property handling.
|
|
282 ;;; ************************************************************************
|
|
283
|
|
284 (if (string-match "^19\." emacs-version)
|
|
285 (progn
|
|
286 ;;
|
|
287 ;; Emacs 19 buffer entry tags functions
|
|
288 ;;
|
|
289
|
|
290 (defun br-feature-clear-signatures (&optional buf-nm)
|
|
291 "Erase any feature signatures saved with current buffer or optional BUF-NM."
|
|
292 (save-excursion
|
|
293 (if buf-nm (set-buffer (get-buffer buf-nm)))
|
|
294 (save-restriction
|
|
295 (widen)
|
|
296 (remove-text-properties (point-min) (point-max) '(tag)))))
|
|
297
|
|
298 (defun br-feature-get-signature (&optional line-num-minus-one)
|
|
299 (save-excursion
|
|
300 (if (numberp line-num-minus-one)
|
|
301 (goto-line (1+ line-num-minus-one)))
|
|
302 (end-of-line)
|
|
303 (car (cdr (memq 'tag (text-properties-at (1- (point))))))))
|
|
304
|
|
305 (defun br-feature-get-tags ()
|
|
306 (save-excursion
|
|
307 (goto-char (point-max))
|
|
308 (let ((found t)
|
|
309 (tags)
|
|
310 tag)
|
|
311 (while found
|
|
312 (setq tag (get-text-property (1- (point)) 'tag))
|
|
313 (if tag (setq tags (cons tag tags)))
|
|
314 (setq found (= (forward-line -1) 0))
|
|
315 (end-of-line))
|
|
316 tags)))
|
|
317
|
|
318 ;; Tag property is placed at end of line in case leading indent is
|
|
319 ;; removed by an OO-Browser operation. In that case, we don't want to
|
|
320 ;; lose the tag property.
|
|
321 (defun br-feature-put-signatures (ftr-sigs)
|
|
322 (while ftr-sigs
|
|
323 (end-of-line)
|
|
324 (put-text-property (- (point) 2) (point) 'tag (car ftr-sigs))
|
|
325 (setq ftr-sigs (cdr ftr-sigs))
|
|
326 (if (and ftr-sigs (/= (forward-line 1) 0))
|
|
327 (error "(br-feature-put-signatures): Too few lines in this buffer"))))
|
|
328
|
|
329 )
|
|
330
|
|
331 ;;
|
|
332 ;; Emacs 18 buffer entry tags functions
|
|
333 ;;
|
|
334
|
|
335 (defun br-feature-clear-signatures (&optional buf-nm)
|
|
336 "Erase any feature signatures saved with current buffer or optional BUF-NM."
|
|
337 (put (intern (or buf-nm (buffer-name))) 'features nil))
|
|
338
|
|
339 (defun br-feature-get-signature (&optional line-num)
|
|
340 (or (numberp line-num)
|
|
341 (save-excursion
|
|
342 (beginning-of-line)
|
|
343 (setq line-num (count-lines 1 (point)))))
|
|
344 (cdr (assq line-num (get (intern-soft (buffer-name)) 'features))))
|
|
345
|
|
346 (defun br-feature-get-tags ()
|
|
347 (get (intern-soft (buffer-name)) 'features))
|
|
348
|
|
349 (defun br-feature-put-signatures (ftr-sigs)
|
|
350 (beginning-of-line)
|
|
351 (let* ((line (count-lines 1 (point)))
|
|
352 (meth-alist (mapcar (function
|
|
353 (lambda (meth)
|
|
354 (prog1 (cons line meth)
|
|
355 (setq line (1+ line)))))
|
|
356 ftr-sigs))
|
|
357 (buf-sym (intern (buffer-name))))
|
|
358 (put buf-sym 'features
|
|
359 (nconc (get buf-sym 'features) meth-alist))))
|
|
360 )
|
|
361
|
|
362 ;;; ************************************************************************
|
|
363 ;;; END - Listing buffer entry tag property handling.
|
|
364 ;;; ************************************************************************
|
|
365
|
|
366 (defun br-feature-tags-init ()
|
100
|
367 "Set up `br-feature-tags-file' for writing."
|
0
|
368 (setq br-feature-tags-completions nil
|
|
369 br-feature-tags-file (br-feature-tags-file-name br-env-file)
|
|
370 br-tags-file (concat br-env-file "-TAGS"))
|
|
371 (set-buffer (funcall br-find-file-noselect-function br-feature-tags-file))
|
|
372 (setq buffer-read-only nil))
|
|
373
|
|
374 (defun br-feature-tags-file-name (env-file)
|
|
375 (concat env-file "-FTR"))
|
|
376
|
|
377 (defun br-feature-tags-save ()
|
100
|
378 "Filter out extraneous lines and save `br-feature-tags-file'."
|
0
|
379 (let ((obuf (current-buffer)))
|
|
380 (set-buffer (funcall br-find-file-noselect-function br-feature-tags-file))
|
|
381 (goto-char (point-min))
|
|
382 (delete-matching-lines "^[ \t]*$")
|
|
383 (goto-char (point-min))
|
|
384 (replace-regexp "^[ \t]+\\|[ \t]+$" "")
|
|
385 (and br-c-tags-flag
|
|
386 (br-member br-lang-prefix '("c++-" "objc-"))
|
|
387 (progn (c-build-element-tags)
|
|
388 (goto-char (point-min))
|
|
389 (replace-regexp "[ \t]*//.*" "")))
|
|
390 (goto-char (point-min))
|
|
391 (delete-matching-lines "^$")
|
|
392 (save-buffer)
|
|
393 (set-buffer obuf)))
|
|
394
|
|
395 (defun br-insert-features (feature-tag-list &optional indent)
|
|
396 "Insert feature names from FEATURE-TAG-LIST in current buffer indented INDENT columns."
|
|
397 (let ((start (point)))
|
|
398 (mapcar (function
|
|
399 (lambda (feature-tag)
|
|
400 (if indent (indent-to indent))
|
|
401 (if feature-tag
|
|
402 (insert (br-feature-signature-to-name feature-tag nil t)
|
|
403 "\n"))))
|
|
404 feature-tag-list)
|
|
405 (save-excursion
|
|
406 (goto-char start)
|
|
407 (br-feature-put-signatures feature-tag-list))))
|
|
408
|
|
409 ;;; ************************************************************************
|
|
410 ;;; Private functions
|
|
411 ;;; ************************************************************************
|
|
412
|
|
413 (defun br-feature-current ()
|
|
414 "Extract current feature from tags file and leave point at the end of line."
|
|
415 (beginning-of-line)
|
|
416 (buffer-substring (point) (progn (end-of-line) (point))))
|
|
417
|
|
418 (defun br-feature-file-of-tag ()
|
|
419 "Return the file name of the file whose tag point is within.
|
|
420 Assumes the tag table is the current buffer."
|
|
421 (save-excursion
|
120
|
422 (search-backward "\f" nil t)
|
0
|
423 (forward-line 1)
|
|
424 (let ((start (point)))
|
|
425 (end-of-line)
|
|
426 (buffer-substring start (point)))))
|
|
427
|
100
|
428 (defun br-feature-tag-and-file (feature-tag-regexp)
|
|
429 "Return a cons (FEATURE-TAG . FEATURE-DEF-FILENAME) for the first tag match of FEATURE-TAG-REGEXP, or nil.
|
|
430 Use br-feature-tag-regexp to create FEATURE-TAG-REGEXP.
|
|
431 Feature tags come from the file named by br-feature-tags-file."
|
|
432 (let ((obuf (current-buffer))
|
|
433 result)
|
|
434 (unwind-protect
|
|
435 (progn
|
120
|
436 (set-buffer
|
|
437 (funcall br-find-file-noselect-function br-feature-tags-file))
|
100
|
438 (setq result (br-feature-def-file feature-tag-regexp))
|
|
439 (if result (cons (br-feature-current) result)))
|
|
440 (set-buffer obuf))))
|
|
441
|
0
|
442 ;;; ************************************************************************
|
|
443 ;;; Private variables
|
|
444 ;;; ************************************************************************
|
|
445
|
|
446 (defconst br-feature-entry
|
|
447 (concat br-feature-type-regexp " \\([^\t\n\r]*[^ \t\n\r]\\)")
|
|
448 "Regexp matching a feature entry in a browser listing buffer.")
|
|
449
|
|
450 (defvar br-feature-tags-completions nil
|
|
451 "List of (envir-name tags-file-last-mod-time tags-completion-alist).")
|
|
452
|
|
453 (defvar br-feature-tags-file nil
|
|
454 "Pathname where current object-oriented feature tags are stored.")
|
|
455
|
|
456 (defvar br-tags-file nil
|
|
457 "Pathname where current non-object-oriented feature tags are stored.")
|
|
458
|
|
459 (provide 'br-ftr)
|