[Emacs-diffs] Changes to emacs/lisp/progmodes/etags.el [lexbind]

[Miles Bader]

Index: emacs/lisp/progmodes/etags.el
diff -c emacs/lisp/progmodes/etags.el:1.165.2.1 
emacs/lisp/progmodes/etags.el:1.165.2.2
*** emacs/lisp/progmodes/etags.el:1.165.2.1     Fri Apr  4 01:20:32 2003
--- emacs/lisp/progmodes/etags.el       Tue Oct 14 19:30:17 2003
***************
*** 222,234 ****
  of the format-parsing tags function variables if successful.")
  
  (defvar file-of-tag-function nil
!   "Function to do the work of `file-of-tag' (which see).")
  (defvar tags-table-files-function nil
    "Function to do the work of `tags-table-files' (which see).")
  (defvar tags-completion-table-function nil
    "Function to build the `tags-completion-table'.")
  (defvar snarf-tag-function nil
!   "Function to get info about a matched tag for 
`goto-tag-location-function'.")
  (defvar goto-tag-location-function nil
    "Function of to go to the location in the buffer specified by a tag.
  One argument, the tag info returned by `snarf-tag-function'.")
--- 222,238 ----
  of the format-parsing tags function variables if successful.")
  
  (defvar file-of-tag-function nil
!   "Function to do the work of `file-of-tag' (which see).
! One optional argument, a boolean specifying to return complete path (nil) or
! relative path (non-nil).")
  (defvar tags-table-files-function nil
    "Function to do the work of `tags-table-files' (which see).")
  (defvar tags-completion-table-function nil
    "Function to build the `tags-completion-table'.")
  (defvar snarf-tag-function nil
!   "Function to get info about a matched tag for `goto-tag-location-function'.
! One optional argument, specifying to use explicit tag (non-nil) or not (nil).
! The default is nil.")
  (defvar goto-tag-location-function nil
    "Function of to go to the location in the buffer specified by a tag.
  One argument, the tag info returned by `snarf-tag-function'.")
***************
*** 514,519 ****
--- 518,524 ----
      ;; Set tags-file-name to the name from the list.  It is already expanded.
      (setq tags-file-name (car tags-table-list-pointer))))
  
+ ;;;###autoload
  (defun visit-tags-table-buffer (&optional cont)
    "Select the buffer containing the current tags table.
  If optional arg is a string, visit that file as a tags table.
***************
*** 703,713 ****
        tags-table-list-started-at nil
        tags-table-set-list nil))
  
! (defun file-of-tag ()
    "Return the file name of the file whose tags point is within.
  Assumes the tags table is the current buffer.
! File name returned is relative to tags table file's directory."
!   (funcall file-of-tag-function))
  
  ;;;###autoload
  (defun tags-table-files ()
--- 708,720 ----
        tags-table-list-started-at nil
        tags-table-set-list nil))
  
! (defun file-of-tag (&optional relative)
    "Return the file name of the file whose tags point is within.
  Assumes the tags table is the current buffer.
! If RELATIVE is non-nil, file name returned is relative to tags
! table file's directory. If RELATIVE is nil, file name returned
! is complete."
!   (funcall file-of-tag-function relative))
  
  ;;;###autoload
  (defun tags-table-files ()
***************
*** 1143,1187 ****
  
        ;; Get the local value in the tags table buffer before switching 
buffers.
        (setq goto-func goto-tag-location-function)
! 
!       ;; 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)))
        (widen)
        (push-mark)
        (funcall goto-func tag-info)
  
        ;; Return the buffer where the tag was found.
        (current-buffer))))
  
  ;; `etags' TAGS file format support.
  
--- 1150,1202 ----
  
        ;; Get the local value in the tags table buffer before switching 
buffers.
        (setq goto-func goto-tag-location-function)
!       (tag-find-file-of-tag-noselect file)
        (widen)
        (push-mark)
        (funcall goto-func tag-info)
  
        ;; Return the buffer where the tag was found.
        (current-buffer))))
+ 
+ (defun tag-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))))
+ 
+ (defun tag-find-file-of-tag (file)
+   (let ((buf (tag-find-file-of-tag-noselect file)))
+     (condition-case nil
+       (switch-to-buffer buf)
+       (error (pop-to-buffer buf)))))
  
  ;; `etags' TAGS file format support.
  
***************
*** 1222,1232 ****
    ;; Use eq instead of = in case char-after returns nil.
    (eq (char-after (point-min)) ?\f))
  
! (defun etags-file-of-tag ()
    (save-excursion
      (re-search-backward "\f\n\\([^\n]+\\),[0-9]*\n")
!     (expand-file-name (buffer-substring (match-beginning 1) (match-end 1))
!                     (file-truename default-directory))))
  
  
  (defun etags-tags-completion-table ()
--- 1237,1250 ----
    ;; Use eq instead of = in case char-after returns nil.
    (eq (char-after (point-min)) ?\f))
  
! (defun etags-file-of-tag (&optional relative)
    (save-excursion
      (re-search-backward "\f\n\\([^\n]+\\),[0-9]*\n")
!     (let ((str (buffer-substring (match-beginning 1) (match-end 1))))
!       (if relative
!         str
!       (expand-file-name str
!                         (file-truename default-directory))))))
  
  
  (defun etags-tags-completion-table ()
***************
*** 1254,1261 ****
                table)))
      table))
  
! (defun etags-snarf-tag ()
!   (let (tag-text line startpos)
      (if (save-excursion
          (forward-line -1)
          (looking-at "\f\n"))
--- 1272,1279 ----
                table)))
      table))
  
! (defun etags-snarf-tag (&optional use-explicit)
!   (let (tag-text line startpos explicit-start)
      (if (save-excursion
          (forward-line -1)
          (looking-at "\f\n"))
***************
*** 1271,1278 ****
        (setq tag-text (buffer-substring (1- (point))
                                       (save-excursion (beginning-of-line)
                                                       (point))))
!       ;; Skip explicit tag name if present.
!       (search-forward "\001" (save-excursion (forward-line 1) (point)) t)
        (if (looking-at "[0-9]")
          (setq line (string-to-int (buffer-substring
                                     (point)
--- 1289,1302 ----
        (setq tag-text (buffer-substring (1- (point))
                                       (save-excursion (beginning-of-line)
                                                       (point))))
!       ;; If use-explicit is non nil and explicit tag is present, use it as 
part of
!       ;; return value. Else just skip it.
!       (setq explicit-start (point))
!       (when (and (search-forward "\001" (save-excursion (forward-line 1) 
(point)) t)
!                use-explicit)
!       (setq tag-text (buffer-substring explicit-start (1- (point)))))
! 
! 
        (if (looking-at "[0-9]")
          (setq line (string-to-int (buffer-substring
                                     (point)
***************
*** 1347,1373 ****
  
  (defun etags-list-tags (file)
    (goto-char (point-min))
!   (when (search-forward (concat "\f\n" file ",") nil t)
      (forward-line 1)
      (while (not (or (eobp) (looking-at "\f")))
!       (let ((tag (buffer-substring (point)
!                                  (progn (skip-chars-forward "^\177")
!                                         (point))))
!             (props `(action find-tag-other-window mouse-face highlight
!                           face ,tags-tag-face))
!             (pt (with-current-buffer standard-output (point))))
!         (when (looking-at "[^\n]+\001")
!         ;; There is an explicit tag name; use that.
!           (setq tag (buffer-substring (1+ (point)) ; skip \177
!                                     (progn (skip-chars-forward "^\001")
!                                              (point)))))
!         (princ tag)
!         (when (= (aref tag 0) ?\() (princ " ...)"))
!         (add-text-properties pt (with-current-buffer standard-output (point))
!                              (cons 'item (cons tag props)) standard-output))
        (terpri)
        (forward-line 1))
!     t))
  
  (defmacro tags-with-face (face &rest body)
    "Execute BODY, give output to `standard-output' face FACE."
--- 1371,1405 ----
  
  (defun etags-list-tags (file)
    (goto-char (point-min))
!   (when (re-search-forward (concat "\f\n" "\\(" file "\\)" ",") nil t)
!     (let ((path (save-excursion (forward-line 1) (file-of-tag)))
!         ;; Get the local value in the tags table
!         ;; buffer before switching buffers.
!         (goto-func goto-tag-location-function)
!         tag tag-info pt)
      (forward-line 1)
      (while (not (or (eobp) (looking-at "\f")))
!       (setq tag-info (save-excursion (funcall snarf-tag-function t))
!           tag (car tag-info)
!           pt (with-current-buffer standard-output (point)))
!       (princ tag)
!       (when (= (aref tag 0) ?\() (princ " ...)"))
!       (with-current-buffer standard-output
!       (make-text-button pt (point)
!                         'tag-info tag-info
!                         'file-path path
!                         'goto-func goto-func
!                         'action (lambda (button)
!                                   (let ((tag-info (button-get button 
'tag-info))
!                                         (goto-func (button-get button 
'goto-func)))
!                                     (tag-find-file-of-tag (button-get button 
'file-path))
!                                     (widen)
!                                     (funcall goto-func tag-info)))
!                         'face 'tags-tag-face
!                         'type 'button))
        (terpri)
        (forward-line 1))
!     t)))
  
  (defmacro tags-with-face (face &rest body)
    "Execute BODY, give output to `standard-output' face FACE."
***************
*** 1384,1399 ****
        (princ "\n\n")
        (tags-with-face 'highlight (princ (car oba)))
        (princ":\n\n")
!       (let* ((props `(action ,(cadr oba) mouse-face highlight face
!                            ,tags-tag-face))
!              (beg (point))
             (symbs (car (cddr oba)))
               (ins-symb (lambda (sy)
                           (let ((sn (symbol-name sy)))
                             (when (string-match regexp sn)
!                              (add-text-properties (point)
!                                                 (progn (princ sy) (point))
!                                                 (cons 'item (cons sn props)))
                               (terpri))))))
          (when (symbolp symbs)
            (if (boundp symbs)
--- 1416,1435 ----
        (princ "\n\n")
        (tags-with-face 'highlight (princ (car oba)))
        (princ":\n\n")
!       (let* ((beg (point))
             (symbs (car (cddr oba)))
               (ins-symb (lambda (sy)
                           (let ((sn (symbol-name sy)))
                             (when (string-match regexp sn)
!                              (make-text-button (point)
!                                         (progn (princ sy) (point))
!                                         'action-internal(cadr oba)
!                                         'action (lambda (button) (funcall
!                                                                   (button-get 
button 'action-internal)
!                                                                   (button-get 
button 'item)))
!                                         'item sn
!                                         'face tags-tag-face
!                                         'type 'button)
                               (terpri))))))
          (when (symbolp symbs)
            (if (boundp symbs)
***************
*** 1414,1453 ****
    (goto-char (point-min))
    (while (re-search-forward string nil t)
      (beginning-of-line)
!     (let* ((tag-info (save-excursion (funcall snarf-tag-function)))
           (tag (if (eq t (car tag-info)) nil (car tag-info)))
!          (file (if tag (file-of-tag)
!                  (save-excursion (next-line 1)
!                                  (file-of-tag))))
           (pt (with-current-buffer standard-output (point))))
        (if tag
          (progn
!           (princ (format "[%s]: " file))
            (princ tag)
            (when (= (aref tag 0) ?\() (princ " ...)"))
            (with-current-buffer standard-output
!           (make-text-button pt (point)
!                             'tag-info tag-info
!                             'file file
!                             'action (lambda (button)
!                                       ;; TODO: just `find-file is too simple.
!                                       ;; Use code `find-tag-in-order'.
!                                       (let ((tag-info (button-get button 
'tag-info)))
!                                         (find-file (button-get button 'file))
!                                         (etags-goto-tag-location tag-info)))
!                             'face 'tags-tag-face
!                             'type 'button)))
!       (princ (format "- %s" file))
        (with-current-buffer standard-output
          (make-text-button pt (point)
!         'file file
!         'action (lambda (button)
!                   ;; TODO: just `find-file is too simple.
!                   ;; Use code `find-tag-in-order'.
!                   (find-file (button-get button 'file))
!                   (goto-char (point-min)))
!         'face 'tags-tag-face
!         'type 'button))
        ))
      (terpri)
      (forward-line 1))
--- 1450,1497 ----
    (goto-char (point-min))
    (while (re-search-forward string nil t)
      (beginning-of-line)
! 
!     (let* (;; Get the local value in the tags table
!          ;; buffer before switching buffers.
!          (goto-func goto-tag-location-function)
!          (tag-info (save-excursion (funcall snarf-tag-function)))
           (tag (if (eq t (car tag-info)) nil (car tag-info)))
!          (file-path (save-excursion (if tag (file-of-tag)
!                                       (save-excursion (next-line 1)
!                                                       (file-of-tag)))))
!          (file-label (if tag (file-of-tag t)
!                        (save-excursion (next-line 1)
!                                        (file-of-tag t))))
           (pt (with-current-buffer standard-output (point))))
        (if tag
          (progn
!           (princ (format "[%s]: " file-label))
            (princ tag)
            (when (= (aref tag 0) ?\() (princ " ...)"))
            (with-current-buffer standard-output
!             (make-text-button pt (point)
!                               'tag-info tag-info
!                               'file-path file-path
!                               'goto-func goto-func
!                               'action (lambda (button)
!                                         (let ((tag-info (button-get button 
'tag-info))
!                                               (goto-func (button-get button 
'goto-func)))
!                                           (tag-find-file-of-tag (button-get 
button 'file-path))
!                                           (widen)
!                                           (funcall goto-func tag-info)))
!                               'face 'tags-tag-face
!                               'type 'button)))
!       (princ (format "- %s" file-label))
        (with-current-buffer standard-output
          (make-text-button pt (point)
!                           'file-path file-path
!                           'action (lambda (button)
!                                     (tag-find-file-of-tag (button-get button 
'file-path))
!                                     ;; Get the local value in the tags table
!                                     ;; buffer before switching buffers.
!                                     (goto-char (point-min)))
!                           'face 'tags-tag-face
!                           'type 'button))
        ))
      (terpri)
      (forward-line 1))
***************
*** 1822,1829 ****
        (or gotany
            (error "File %s not in current tags tables" file)))))
    (with-current-buffer "*Tags List*"
!     (setq buffer-read-only t)
!     (apropos-mode)))
  
  ;;;###autoload
  (defun tags-apropos (regexp)
--- 1866,1873 ----
        (or gotany
            (error "File %s not in current tags tables" file)))))
    (with-current-buffer "*Tags List*"
!     (apropos-mode)
!     (setq buffer-read-only t)))
  
  ;;;###autoload
  (defun tags-apropos (regexp)
***************
*** 1847,1852 ****
--- 1891,1900 ----
  
  ;; XXX Kludge interface.
  
+ (define-button-type 'tags-select-tags-table
+   'action (lambda (button) (select-tags-table-select))
+   'help-echo "RET, t or mouse-2: select tags table")
+ 
  ;; XXX If a file is in multiple tables, selection may get the wrong one.
  ;;;###autoload
  (defun select-tags-table ()
***************
*** 1858,1873 ****
    (setq buffer-read-only nil)
    (erase-buffer)
    (let ((set-list tags-table-set-list)
!       (desired-point nil))
      (when tags-table-list
          (setq desired-point (point-marker))
          (princ tags-table-list (current-buffer))
          (insert "\C-m")
          (prin1 (car tags-table-list) (current-buffer)) ;invisible
        (insert "\n"))
      (while set-list
        (unless (eq (car set-list) tags-table-list)
        (princ (car set-list) (current-buffer))
        (insert "\C-m")
        (prin1 (car (car set-list)) (current-buffer)) ;invisible
        (insert "\n"))
--- 1906,1926 ----
    (setq buffer-read-only nil)
    (erase-buffer)
    (let ((set-list tags-table-set-list)
!       (desired-point nil)
!       b)
      (when tags-table-list
          (setq desired-point (point-marker))
+         (setq b (point))
          (princ tags-table-list (current-buffer))
+         (make-text-button b (point) 'type 'tags-select-tags-table)
          (insert "\C-m")
          (prin1 (car tags-table-list) (current-buffer)) ;invisible
        (insert "\n"))
      (while set-list
        (unless (eq (car set-list) tags-table-list)
+       (setq b (point))
        (princ (car set-list) (current-buffer))
+       (make-text-button b (point) 'type 'tags-select-tags-table)
        (insert "\C-m")
        (prin1 (car (car set-list)) (current-buffer)) ;invisible
        (insert "\n"))
***************
*** 1875,1881 ****
      (when tags-file-name
          (or desired-point
              (setq desired-point (point-marker)))
!         (insert tags-file-name "\C-m")
          (prin1 tags-file-name (current-buffer)) ;invisible
        (insert "\n"))
      (setq set-list (delete tags-file-name
--- 1928,1937 ----
      (when tags-file-name
          (or desired-point
              (setq desired-point (point-marker)))
!         (setq b (point))
!         (insert tags-file-name)
!         (make-text-button b (point) 'type 'tags-select-tags-table)
!         (insert "\C-m")
          (prin1 tags-file-name (current-buffer)) ;invisible
        (insert "\n"))
      (setq set-list (delete tags-file-name
***************
*** 1883,1889 ****
                                               (mapcar 'copy-sequence
                                                       tags-table-set-list)))))
      (while set-list
!       (insert (car set-list) "\C-m")
        (prin1 (car set-list) (current-buffer)) ;invisible
        (insert "\n")
        (setq set-list (delete (car set-list) set-list)))
--- 1939,1948 ----
                                               (mapcar 'copy-sequence
                                                       tags-table-set-list)))))
      (while set-list
!       (setq b (point))
!       (insert (car set-list))
!       (make-text-button b (point) 'type 'tags-select-tags-table)
!       (insert "\C-m")
        (prin1 (car set-list) (current-buffer)) ;invisible
        (insert "\n")
        (setq set-list (delete (car set-list) set-list)))
***************
*** 1896,1910 ****
    (set-buffer-modified-p nil)
    (select-tags-table-mode))
  
! (defvar select-tags-table-mode-map)
! (let ((map (make-sparse-keymap)))
!   (define-key map "t" 'select-tags-table-select)
!   (define-key map " " 'next-line)
!   (define-key map "\^?" 'previous-line)
!   (define-key map "n" 'next-line)
!   (define-key map "p" 'previous-line)
!   (define-key map "q" 'select-tags-table-quit)
!   (setq select-tags-table-mode-map map))
  
  (defun select-tags-table-mode ()
    "Major mode for choosing a current tags table among those already loaded.
--- 1955,1969 ----
    (set-buffer-modified-p nil)
    (select-tags-table-mode))
  
! (defvar select-tags-table-mode-map
!   (let ((map (copy-keymap button-buffer-map)))
!     (define-key map "t" 'push-button)
!     (define-key map " " 'next-line)
!     (define-key map "\^?" 'previous-line)
!     (define-key map "n" 'next-line)
!     (define-key map "p" 'previous-line)
!     (define-key map "q" 'select-tags-table-quit)
!     map))
  
  (defun select-tags-table-mode ()
    "Major mode for choosing a current tags table among those already loaded.
***************
*** 1989,1992 ****
--- 2048,2052 ----
  
  (provide 'etags)
  
+ ;;; arch-tag: b897c2b5-08f3-4837-b2d3-0e7d6db1b63e
  ;;; etags.el ends here