all messages for Emacs-related lists mirrored at yhetil.org
 help / color / mirror / code / Atom feed
blob f0ef98cfb6b3c22dae7da9cd2746cc71cc660b76 11131 bytes (raw)
name: lisp/dirtrack.el 	 # note: path name is non-authoritative(*)

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
 
;;; dirtrack.el --- Directory Tracking by watching the prompt

;; Copyright (C) 1996, 2001-2016 Free Software Foundation, Inc.

;; Author: Peter Breton <pbreton@cs.umb.edu>
;; Created: Sun Nov 17 1996
;; Keywords: processes

;; This file is part of GNU Emacs.

;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:

;; Shell directory tracking by watching the prompt.
;;
;; This is yet another attempt at a directory-tracking package for
;; Emacs shell-mode.  However, this package makes one strong assumption:
;; that you can customize your shell's prompt to contain the
;; current working directory.  Most shells do support this, including
;; almost every type of Bourne and C shell on Unix, the native shells on
;; Windows95 (COMMAND.COM) and Windows NT (CMD.EXE), and most 3rd party
;; Windows shells.  If you cannot do this, or do not wish to, this package
;; will be useless to you.
;;
;; Installation:
;;
;; 1) Set your shell's prompt to contain the current working directory.
;; You may need to consult your shell's documentation to find out how to
;; do this.
;;
;; Note that directory tracking is done by matching regular expressions,
;; therefore it is *VERY IMPORTANT* for your prompt to be easily
;; distinguishable from other output.  If your prompt regexp is too general,
;; you will see error messages from the dirtrack filter as it attempts to cd
;; to non-existent directories.
;;
;; 2) Set the variable `dirtrack-list' to an appropriate value.  This
;; should be a list of two elements: the first is a regular expression
;; which matches your prompt up to and including the pathname part.
;; The second is a number which tells which regular expression group to
;; match to extract only the pathname.  If you use a multi-line prompt,
;; add t as a third element.  Note that some of the functions in
;; 'comint.el' assume a single-line prompt (eg, comint-bol).
;;
;; Determining this information may take some experimentation.  Using
;; `dirtrack-debug-mode' may help; it causes the directory-tracking
;; filter to log messages to the buffer `dirtrack-debug-buffer'.
;;
;; 3) Activate `dirtrack-mode'.  You may wish to turn ordinary shell
;; tracking off by calling `shell-dirtrack-mode'.
;;
;; Examples:
;;
;; 1) On Windows NT, my prompt is set to emacs$S$P$G.
;; 'dirtrack-list' is set to (list "^emacs \\([a-zA-Z]:.*\\)>" 1)
;;
;; 2) On Solaris running bash, my prompt is set like this:
;;    PS1="\w\012emacs@\h(\!) [\t]% "
;;    'dirtrack-list' is set to (list "^\\([/~].*\\)\nemacs@[^%]+% *" 1 t)
;;
;; I'd appreciate other examples from people who use this package.
;;
;; Here's one from Stephen Eglen:
;;
;;   Running under tcsh:
;;   (setq-default dirtrack-list '("^%E \\([^ ]+\\)" 1))
;;
;;   It might be worth mentioning in your file that emacs sources start up
;;   files of the form: ~/.emacs_<SHELL> where <SHELL> is the name of the
;;   shell.  So for example, I have the following in ~/.emacs_tcsh:
;;
;;   set prompt = "%%E %~ %h% "
;;
;;   This produces a prompt of the form:
;;   %E /var/spool 10%
;;
;;   This saves me from having to use the %E prefix in other non-emacs
;;   shells.
;;
;; A final note:
;;
;;   I run LOTS of shell buffers through Emacs, sometimes as different users
;;   (eg, when logged in as myself, I'll run a root shell in the same Emacs).
;;   If you do this, and the shell prompt contains a ~, Emacs will interpret
;;   this relative to the user which owns the Emacs process, not the user
;;   who owns the shell buffer.  This may cause dirtrack to behave strangely
;;   (typically it reports that it is unable to cd to a directory
;;   with a ~ in it).
;;
;;   The same behavior can occur if you use dirtrack with remote filesystems
;;   (using telnet, rlogin, etc) as Emacs will be checking the local
;;   filesystem, not the remote one.  This problem is not specific to dirtrack,
;;   but also affects file completion, etc.

;;; Code:

(eval-when-compile
  (require 'comint)
  (require 'shell))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Customization Variables
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defgroup dirtrack nil
  "Directory tracking by watching the prompt."
  :prefix "dirtrack-"
  :group 'shell)

(defcustom dirtrack-list (list "^emacs \\([a-zA-Z]:.*\\)>" 1)
  "List for directory tracking.
First item is a regexp that describes where to find the path in a prompt.
Second is a number, the regexp group to match."
  :group 'dirtrack
  :type  '(sexp (regexp  :tag "Prompt Expression")
		(integer :tag "Regexp Group"))
  :version "24.1")

(make-variable-buffer-local 'dirtrack-list)

(defcustom dirtrack-debug nil
  "If non-nil, the function `dirtrack' will report debugging info."
  :group 'dirtrack
  :type  'boolean)

(defcustom dirtrack-debug-buffer "*Directory Tracking Log*"
  "Buffer in which to write directory tracking debug information."
  :group 'dirtrack
  :type  'string)

(defcustom dirtrack-directory-function
  (if (memq system-type '(ms-dos windows-nt cygwin))
      'dirtrack-windows-directory-function
    'file-name-as-directory)
  "Function to apply to the prompt directory for comparison purposes."
  :group 'dirtrack
  :type  'function)

(defcustom dirtrack-canonicalize-function
  (if (memq system-type '(ms-dos windows-nt cygwin))
      'downcase 'identity)
  "Function to apply to the default directory for comparison purposes."
  :group 'dirtrack
  :type  'function)

(defcustom dirtrack-directory-change-hook nil
  "Hook that is called when a directory change is made."
  :group 'dirtrack
  :type 'hook)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


(defun dirtrack-windows-directory-function (dir)
  "Return a canonical directory for comparison purposes.
Such a directory is all lowercase, has forward-slashes as delimiters,
and ends with a forward slash."
  (file-name-as-directory (downcase (subst-char-in-string ?\\ ?/ dir))))

(defun dirtrack-cygwin-directory-function (dir)
  "Return a canonical directory taken from a Cygwin path for comparison purposes."
  (if (string-match "/cygdrive/\\([A-Z]\\)\\(.*\\)" dir)
      (concat (match-string 1 dir) ":" (match-string 2 dir))
    dir))


(define-obsolete-function-alias 'dirtrack-toggle 'dirtrack-mode "23.1")
(define-obsolete-variable-alias 'dirtrackp 'dirtrack-mode "23.1")
;;;###autoload
(define-minor-mode dirtrack-mode
  "Toggle directory tracking in shell buffers (Dirtrack mode).
With a prefix argument ARG, enable Dirtrack mode if ARG is
positive, and disable it otherwise.  If called from Lisp, enable
the mode if ARG is omitted or nil.

This method requires that your shell prompt contain the current
working directory at all times, and that you set the variable
`dirtrack-list' to match the prompt.

This is an alternative to `shell-dirtrack-mode', which works by
tracking `cd' and similar commands which change the shell working
directory."
  nil nil nil
  (if dirtrack-mode
      (add-hook 'comint-preoutput-filter-functions 'dirtrack nil t)
    (remove-hook 'comint-preoutput-filter-functions 'dirtrack t)))


(define-obsolete-function-alias 'dirtrack-debug-toggle 'dirtrack-debug-mode
  "23.1")
(define-obsolete-variable-alias 'dirtrack-debug 'dirtrack-debug-mode "23.1")
(define-minor-mode dirtrack-debug-mode
  "Toggle Dirtrack debugging.
With a prefix argument ARG, enable Dirtrack debugging if ARG is
positive, and disable it otherwise.  If called from Lisp, enable
the mode if ARG is omitted or nil."
  nil nil nil
  (if dirtrack-debug-mode
      (display-buffer (get-buffer-create dirtrack-debug-buffer))))

(defun dirtrack-debug-message (msg1 msg2)
  "Insert strings at the end of `dirtrack-debug-buffer'."
  (when dirtrack-debug-mode
    (with-current-buffer (get-buffer-create dirtrack-debug-buffer)
      (goto-char (point-max))
      (insert (substitute-command-keys msg1) msg2 "\n"))))

(declare-function shell-prefixed-directory-name "shell" (dir))
(declare-function shell-process-cd "shell" (arg))

;;;###autoload
(defun dirtrack (input)
  "Determine the current directory from the process output for a prompt.
This filter function is used by `dirtrack-mode'.  It looks for
the prompt specified by `dirtrack-list', and calls
`shell-process-cd' if the directory seems to have changed away
from `default-directory'."
  (when (and dirtrack-mode
	     (not (eq (point) (point-min)))) ; there must be output
    (save-excursion ; What's this for? -- cyd
      (if (not (string-match (nth 0 dirtrack-list) input))
	  ;; No match
	  (dirtrack-debug-message
	   "Input failed to match `dirtrack-list': " input)
	(let ((prompt-path (match-string (nth 1 dirtrack-list) input))
	      temp)
	  (cond
	   ;; Don't do anything for empty string
	   ((string-equal prompt-path "")
	    (dirtrack-debug-message "Prompt match gives empty string: " input))
	   ;; If the prompt contains an absolute file name, call
	   ;; `shell-process-cd' if the directory has changed.
	   ((file-name-absolute-p prompt-path)
	    ;; Transform prompts into canonical forms
	    (let ((orig-prompt-path (funcall dirtrack-directory-function
					     prompt-path))
		  (current-dir      (funcall dirtrack-canonicalize-function
					     default-directory)))
	      (setq prompt-path (shell-prefixed-directory-name orig-prompt-path))
	      ;; Compare them
	      (if (or (string-equal current-dir prompt-path)
		      (string-equal (expand-file-name current-dir)
				    (expand-file-name prompt-path)))
		  (dirtrack-debug-message "Not changing directory: " current-dir)
		;; It's possible that Emacs thinks the directory
		;; doesn't exist (e.g. rlogin buffers)
		(if (file-accessible-directory-p prompt-path)
		    ;; `shell-process-cd' adds the prefix, so we need
		    ;; to give it the original (un-prefixed) path.
		    (progn
		      (shell-process-cd orig-prompt-path)
		      (run-hooks 'dirtrack-directory-change-hook)
		      (dirtrack-debug-message "Changing directory to "
					      prompt-path))
		  (dirtrack-debug-message "Not changing to non-existent directory: "
					  prompt-path)))))
	   ;; If the file name is non-absolute, try and see if it
	   ;; seems to be up or down from where we were.
	   ((string-match "\\`\\(.*\\)\\(?:/.*\\)?\n\\(.*/\\)\\1\\(?:/.*\\)?\\'"
			  (setq temp
				(concat prompt-path "\n" default-directory)))
	    (shell-process-cd (concat (match-string 2 temp)
				      prompt-path))
	    (run-hooks 'dirtrack-directory-change-hook)))))))
  input)

(provide 'dirtrack)

;;; dirtrack.el ends here

debug log:

solving f0ef98c ...
found f0ef98c in https://git.savannah.gnu.org/cgit/emacs.git

(*) Git path names are given by the tree(s) the blob belongs to.
    Blobs themselves have no identifier aside from the hash of its contents.^

Code repositories for project(s) associated with this external index

	https://git.savannah.gnu.org/cgit/emacs.git
	https://git.savannah.gnu.org/cgit/emacs/org-mode.git

This is an external index of several public inboxes,
see mirroring instructions on how to clone and mirror
all data and code used by this external index.