Mercurial > hg > xemacs-beta

comparison lisp/oobr/br-ftr.el @ 0:376386a54a3c r19-14

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