/[emacs]/emacs/lisp/progmodes/etags.el
ViewVC logotype

Diff of /emacs/lisp/progmodes/etags.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.172 by lektu, Thu Apr 3 15:55:37 2003 UTC revision 1.173 by lektu, Fri Apr 4 20:01:36 2003 UTC
# Line 222  until one returns non-nil.  The function Line 222  until one returns non-nil.  The function
222  of the format-parsing tags function variables if successful.")  of the format-parsing tags function variables if successful.")
223    
224  (defvar file-of-tag-function nil  (defvar file-of-tag-function nil
225    "Function to do the work of `file-of-tag' (which see).")    "Function to do the work of `file-of-tag' (which see).
226    One optional argument, a boolean specifying to return complete path (nil) or
227    relative path (non-nil).")
228  (defvar tags-table-files-function nil  (defvar tags-table-files-function nil
229    "Function to do the work of `tags-table-files' (which see).")    "Function to do the work of `tags-table-files' (which see).")
230  (defvar tags-completion-table-function nil  (defvar tags-completion-table-function nil
231    "Function to build the `tags-completion-table'.")    "Function to build the `tags-completion-table'.")
232  (defvar snarf-tag-function nil  (defvar snarf-tag-function nil
233    "Function to get info about a matched tag for `goto-tag-location-function'.")    "Function to get info about a matched tag for `goto-tag-location-function'.
234    One optional argument, specifying to use explicit tag (non-nil) or not (nil).
235    The default is nil.")
236  (defvar goto-tag-location-function nil  (defvar goto-tag-location-function nil
237    "Function of to go to the location in the buffer specified by a tag.    "Function of to go to the location in the buffer specified by a tag.
238  One argument, the tag info returned by `snarf-tag-function'.")  One argument, the tag info returned by `snarf-tag-function'.")
# Line 703  Returns t if it visits a tags table, or Line 707  Returns t if it visits a tags table, or
707          tags-table-list-started-at nil          tags-table-list-started-at nil
708          tags-table-set-list nil))          tags-table-set-list nil))
709    
710  (defun file-of-tag ()  (defun file-of-tag (&optional relative)
711    "Return the file name of the file whose tags point is within.    "Return the file name of the file whose tags point is within.
712  Assumes the tags table is the current buffer.  Assumes the tags table is the current buffer.
713  File name returned is relative to tags table file's directory."  If RELATIVE is non-nil, file name returned is relative to tags
714    (funcall file-of-tag-function))  table file's directory. If RELATIVE is nil, file name returned
715    is complete."
716      (funcall file-of-tag-function relative))
717    
718  ;;;###autoload  ;;;###autoload
719  (defun tags-table-files ()  (defun tags-table-files ()
# Line 1143  where they were found." Line 1149  where they were found."
1149    
1150        ;; Get the local value in the tags table buffer before switching buffers.        ;; Get the local value in the tags table buffer before switching buffers.
1151        (setq goto-func goto-tag-location-function)        (setq goto-func goto-tag-location-function)
1152          (find-file-of-tag-noselect file)
       ;; Find the right line in the specified file.  
       ;; If we are interested in compressed-files,  
       ;; we search files with extensions.  
       ;; otherwise only the real file.  
       (let* ((buffer-search-extensions (if (featurep 'jka-compr)  
                                            tags-compression-info-list  
                                          '("")))  
              the-buffer  
              (file-search-extensions buffer-search-extensions))  
         ;; search a buffer visiting the file with each possible extension  
         ;; Note: there is a small inefficiency in find-buffer-visiting :  
         ;;   truename is computed even if not needed. Not too sure about this  
         ;;   but I suspect truename computation accesses the disk.  
         ;;   It is maybe a good idea to optimise this find-buffer-visiting.  
         ;; An alternative would be to use only get-file-buffer  
         ;; but this looks less "sure" to find the buffer for the file.  
         (while (and (not the-buffer) buffer-search-extensions)  
           (setq the-buffer (find-buffer-visiting (concat file (car buffer-search-extensions))))  
           (setq buffer-search-extensions (cdr buffer-search-extensions)))  
         ;; if found a buffer but file modified, ensure we re-read !  
         (if (and the-buffer (not (verify-visited-file-modtime the-buffer)))  
             (find-file-noselect (buffer-file-name the-buffer)))  
         ;; if no buffer found, search for files with possible extensions on disk  
         (while (and (not the-buffer) file-search-extensions)  
           (if (not (file-exists-p (concat file (car file-search-extensions))))  
               (setq file-search-extensions (cdr file-search-extensions))  
             (setq the-buffer (find-file-noselect (concat file (car file-search-extensions))))))  
         (if (not the-buffer)  
             (if (featurep 'jka-compr)  
                 (error "File %s (with or without extensions %s) not found" file tags-compression-info-list)  
               (error "File %s not found" file))  
           (set-buffer the-buffer)))  
1153        (widen)        (widen)
1154        (push-mark)        (push-mark)
1155        (funcall goto-func tag-info)        (funcall goto-func tag-info)
1156    
1157        ;; Return the buffer where the tag was found.        ;; Return the buffer where the tag was found.
1158        (current-buffer))))        (current-buffer))))
1159    
1160    (defun find-file-of-tag-noselect (file)
1161      ;; Find the right line in the specified file.
1162      ;; If we are interested in compressed-files,
1163      ;; we search files with extensions.
1164      ;; otherwise only the real file.
1165      (let* ((buffer-search-extensions (if (featurep 'jka-compr)
1166                                           tags-compression-info-list
1167                                         '("")))
1168             the-buffer
1169             (file-search-extensions buffer-search-extensions))
1170        ;; search a buffer visiting the file with each possible extension
1171        ;; Note: there is a small inefficiency in find-buffer-visiting :
1172        ;;   truename is computed even if not needed. Not too sure about this
1173        ;;   but I suspect truename computation accesses the disk.
1174        ;;   It is maybe a good idea to optimise this find-buffer-visiting.
1175        ;; An alternative would be to use only get-file-buffer
1176        ;; but this looks less "sure" to find the buffer for the file.
1177        (while (and (not the-buffer) buffer-search-extensions)
1178          (setq the-buffer (find-buffer-visiting (concat file (car buffer-search-extensions))))
1179          (setq buffer-search-extensions (cdr buffer-search-extensions)))
1180        ;; if found a buffer but file modified, ensure we re-read !
1181        (if (and the-buffer (not (verify-visited-file-modtime the-buffer)))
1182            (find-file-noselect (buffer-file-name the-buffer)))
1183        ;; if no buffer found, search for files with possible extensions on disk
1184        (while (and (not the-buffer) file-search-extensions)
1185          (if (not (file-exists-p (concat file (car file-search-extensions))))
1186              (setq file-search-extensions (cdr file-search-extensions))
1187            (setq the-buffer (find-file-noselect (concat file (car file-search-extensions))))))
1188        (if (not the-buffer)
1189            (if (featurep 'jka-compr)
1190                (error "File %s (with or without extensions %s) not found" file tags-compression-info-list)
1191              (error "File %s not found" file))
1192          (set-buffer the-buffer))))
1193    
1194    (defun find-file-of-tag (file)
1195      (let ((buf (find-file-of-tag-noselect file)))
1196        (condition-case nil
1197            (switch-to-buffer buf)
1198          (error (pop-to-buffer buf)))))
1199    
1200  ;; `etags' TAGS file format support.  ;; `etags' TAGS file format support.
1201    
# Line 1222  where they were found." Line 1236  where they were found."
1236    ;; Use eq instead of = in case char-after returns nil.    ;; Use eq instead of = in case char-after returns nil.
1237    (eq (char-after (point-min)) ?\f))    (eq (char-after (point-min)) ?\f))
1238    
1239  (defun etags-file-of-tag ()  (defun etags-file-of-tag (&optional relative)
1240    (save-excursion    (save-excursion
1241      (re-search-backward "\f\n\\([^\n]+\\),[0-9]*\n")      (re-search-backward "\f\n\\([^\n]+\\),[0-9]*\n")
1242      (expand-file-name (buffer-substring (match-beginning 1) (match-end 1))      (let ((str (buffer-substring (match-beginning 1) (match-end 1))))
1243                        (file-truename default-directory))))        (if relative
1244              str
1245            (expand-file-name str
1246                              (file-truename default-directory))))))
1247    
1248    
1249  (defun etags-tags-completion-table ()  (defun etags-tags-completion-table ()
# Line 1254  where they were found." Line 1271  where they were found."
1271                  table)))                  table)))
1272      table))      table))
1273    
1274  (defun etags-snarf-tag ()  (defun etags-snarf-tag (&optional use-explicit)
1275    (let (tag-text line startpos)    (let (tag-text line startpos explicit-start)
1276      (if (save-excursion      (if (save-excursion
1277            (forward-line -1)            (forward-line -1)
1278            (looking-at "\f\n"))            (looking-at "\f\n"))
# Line 1271  where they were found." Line 1288  where they were found."
1288        (setq tag-text (buffer-substring (1- (point))        (setq tag-text (buffer-substring (1- (point))
1289                                         (save-excursion (beginning-of-line)                                         (save-excursion (beginning-of-line)
1290                                                         (point))))                                                         (point))))
1291        ;; Skip explicit tag name if present.        ;; If use-explicit is non nil and explicit tag is present, use it as part of
1292        (search-forward "\001" (save-excursion (forward-line 1) (point)) t)        ;; return value. Else just skip it.
1293          (setq explicit-start (point))
1294          (when (and (search-forward "\001" (save-excursion (forward-line 1) (point)) t)
1295                     use-explicit)
1296            (setq tag-text (buffer-substring explicit-start (1- (point)))))
1297    
1298    
1299        (if (looking-at "[0-9]")        (if (looking-at "[0-9]")
1300            (setq line (string-to-int (buffer-substring            (setq line (string-to-int (buffer-substring
1301                                       (point)                                       (point)
# Line 1347  where they were found." Line 1370  where they were found."
1370    
1371  (defun etags-list-tags (file)  (defun etags-list-tags (file)
1372    (goto-char (point-min))    (goto-char (point-min))
1373    (when (search-forward (concat "\f\n" file ",") nil t)    (when (re-search-forward (concat "\f\n" "\\(" file "\\)" ",") nil t)
1374        (let ((path (save-excursion (forward-line 1) (file-of-tag)))
1375              ;; Get the local value in the tags table
1376              ;; buffer before switching buffers.
1377              (goto-func goto-tag-location-function)
1378              tag tag-info pt)
1379      (forward-line 1)      (forward-line 1)
1380      (while (not (or (eobp) (looking-at "\f")))      (while (not (or (eobp) (looking-at "\f")))
1381        (let ((tag (buffer-substring (point)        (setq tag-info (save-excursion (funcall snarf-tag-function t))
1382                                     (progn (skip-chars-forward "^\177")              tag (car tag-info)
1383                                            (point))))              pt (with-current-buffer standard-output (point)))
1384              (props `(action find-tag-other-window mouse-face highlight        (princ tag)
1385                              face ,tags-tag-face))        (when (= (aref tag 0) ?\() (princ " ...)"))
1386              (pt (with-current-buffer standard-output (point))))        (with-current-buffer standard-output
1387          (when (looking-at "[^\n]+\001")          (make-text-button pt (point)
1388            ;; There is an explicit tag name; use that.                            'tag-info tag-info
1389            (setq tag (buffer-substring (1+ (point)) ; skip \177                            'file-path path
1390                                        (progn (skip-chars-forward "^\001")                            'goto-func goto-func
1391                                               (point)))))                            'action (lambda (button)
1392          (princ tag)                                      (let ((tag-info (button-get button 'tag-info))
1393          (when (= (aref tag 0) ?\() (princ " ...)"))                                            (goto-func (button-get button 'goto-func)))
1394          (add-text-properties pt (with-current-buffer standard-output (point))                                        (find-file-of-tag (button-get button 'file-path))
1395                               (cons 'item (cons tag props)) standard-output))                                        (widen)
1396                                          (funcall goto-func tag-info)))
1397                              'face 'tags-tag-face
1398                              'type 'button))
1399        (terpri)        (terpri)
1400        (forward-line 1))        (forward-line 1))
1401      t))      t)))
1402    
1403  (defmacro tags-with-face (face &rest body)  (defmacro tags-with-face (face &rest body)
1404    "Execute BODY, give output to `standard-output' face FACE."    "Execute BODY, give output to `standard-output' face FACE."
# Line 1384  where they were found." Line 1415  where they were found."
1415        (princ "\n\n")        (princ "\n\n")
1416        (tags-with-face 'highlight (princ (car oba)))        (tags-with-face 'highlight (princ (car oba)))
1417        (princ":\n\n")        (princ":\n\n")
1418        (let* ((props `(action ,(cadr oba) mouse-face highlight face        (let* ((beg (point))
                              ,tags-tag-face))  
              (beg (point))  
1419               (symbs (car (cddr oba)))               (symbs (car (cddr oba)))
1420               (ins-symb (lambda (sy)               (ins-symb (lambda (sy)
1421                           (let ((sn (symbol-name sy)))                           (let ((sn (symbol-name sy)))
1422                             (when (string-match regexp sn)                             (when (string-match regexp sn)
1423                               (add-text-properties (point)                               (make-text-button (point)
1424                                                    (progn (princ sy) (point))                                            (progn (princ sy) (point))
1425                                                    (cons 'item (cons sn props)))                                            'action-internal(cadr oba)
1426                                              'action (lambda (button) (funcall
1427                                                                        (button-get button 'action-internal)
1428                                                                        (button-get button 'item)))
1429                                              'item sn
1430                                              'face tags-tag-face
1431                                              'type 'button)
1432                               (terpri))))))                               (terpri))))))
1433          (when (symbolp symbs)          (when (symbolp symbs)
1434            (if (boundp symbs)            (if (boundp symbs)
# Line 1414  where they were found." Line 1449  where they were found."
1449    (goto-char (point-min))    (goto-char (point-min))
1450    (while (re-search-forward string nil t)    (while (re-search-forward string nil t)
1451      (beginning-of-line)      (beginning-of-line)
1452      (let* ((tag-info (save-excursion (funcall snarf-tag-function)))  
1453        (let* (;; Get the local value in the tags table
1454               ;; buffer before switching buffers.
1455               (goto-func goto-tag-location-function)
1456               (tag-info (save-excursion (funcall snarf-tag-function)))
1457             (tag (if (eq t (car tag-info)) nil (car tag-info)))             (tag (if (eq t (car tag-info)) nil (car tag-info)))
1458             (file (if tag (file-of-tag)             (file-path (save-excursion (if tag (file-of-tag)
1459                     (save-excursion (next-line 1)                                          (save-excursion (next-line 1)
1460                                     (file-of-tag))))                                                          (file-of-tag)))))
1461               (file-label (if tag (file-of-tag t)
1462                             (save-excursion (next-line 1)
1463                                             (file-of-tag t))))
1464             (pt (with-current-buffer standard-output (point))))             (pt (with-current-buffer standard-output (point))))
1465        (if tag        (if tag
1466            (progn            (progn
1467              (princ (format "[%s]: " file))              (princ (format "[%s]: " file-label))
1468              (princ tag)              (princ tag)
1469              (when (= (aref tag 0) ?\() (princ " ...)"))              (when (= (aref tag 0) ?\() (princ " ...)"))
1470              (with-current-buffer standard-output              (with-current-buffer standard-output
1471              (make-text-button pt (point)                (make-text-button pt (point)
1472                                'tag-info tag-info                                  'tag-info tag-info
1473                                'file file                                  'file-path file-path
1474                                'action (lambda (button)                                  'goto-func goto-func
1475                                          ;; TODO: just `find-file is too simple.                                  'action (lambda (button)
1476                                          ;; Use code `find-tag-in-order'.                                            (let ((tag-info (button-get button 'tag-info))
1477                                          (let ((tag-info (button-get button 'tag-info)))                                                  (goto-func (button-get button 'goto-func)))
1478                                            (find-file (button-get button 'file))                                              (find-file-of-tag (button-get button 'file-path))
1479                                            (etags-goto-tag-location tag-info)))                                              (widen)
1480                                'face 'tags-tag-face                                              (funcall goto-func tag-info)))
1481                                'type 'button)))                                  'face 'tags-tag-face
1482          (princ (format "- %s" file))                                  'type 'button)))
1483            (princ (format "- %s" file-label))
1484          (with-current-buffer standard-output          (with-current-buffer standard-output
1485            (make-text-button pt (point)            (make-text-button pt (point)
1486            'file file                              'file-path file-path
1487            'action (lambda (button)                              'action (lambda (button)
1488                      ;; TODO: just `find-file is too simple.                                        (find-file-of-tag (button-get button 'file-path))
1489                      ;; Use code `find-tag-in-order'.                                        ;; Get the local value in the tags table
1490                      (find-file (button-get button 'file))                                        ;; buffer before switching buffers.
1491                      (goto-char (point-min)))                                        (goto-char (point-min)))
1492            'face 'tags-tag-face                              'face 'tags-tag-face
1493            'type 'button))                              'type 'button))
1494          ))          ))
1495      (terpri)      (terpri)
1496      (forward-line 1))      (forward-line 1))
# Line 1822  directory specification." Line 1865  directory specification."
1865          (or gotany          (or gotany
1866              (error "File %s not in current tags tables" file)))))              (error "File %s not in current tags tables" file)))))
1867    (with-current-buffer "*Tags List*"    (with-current-buffer "*Tags List*"
1868      (setq buffer-read-only t)      (apropos-mode)
1869      (apropos-mode)))      (setq buffer-read-only t)))
1870    
1871  ;;;###autoload  ;;;###autoload
1872  (defun tags-apropos (regexp)  (defun tags-apropos (regexp)

Legend:
Removed from v.1.172  
changed lines
  Added in v.1.173

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26