lisp/dirtrack.el

   1 ;;; dirtrack.el --- Directory Tracking by watching the prompt
   2
   3 ;; Copyright (C) 1996, 2001-2012 Free Software Foundation, Inc.
   4
   5 ;; Author: Peter Breton <pbreton@cs.umb.edu>
   6 ;; Created: Sun Nov 17 1996
   7 ;; Keywords: processes
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; GNU Emacs is free software: you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation, either version 3 of the License, or
  14 ;; (at your option) any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  23
  24 ;;; Commentary:
  25
  26 ;; Shell directory tracking by watching the prompt.
  27 ;;
  28 ;; This is yet another attempt at a directory-tracking package for
  29 ;; Emacs shell-mode.  However, this package makes one strong assumption:
  30 ;; that you can customize your shell's prompt to contain the
  31 ;; current working directory.  Most shells do support this, including
  32 ;; almost every type of Bourne and C shell on Unix, the native shells on
  33 ;; Windows95 (COMMAND.COM) and Windows NT (CMD.EXE), and most 3rd party
  34 ;; Windows shells.  If you cannot do this, or do not wish to, this package
  35 ;; will be useless to you.
  36 ;;
  37 ;; Installation:
  38 ;;
  39 ;; 1) Set your shell's prompt to contain the current working directory.
  40 ;; You may need to consult your shell's documentation to find out how to
  41 ;; do this.
  42 ;;
  43 ;; Note that directory tracking is done by matching regular expressions,
  44 ;; therefore it is *VERY IMPORTANT* for your prompt to be easily
  45 ;; distinguishable from other output.  If your prompt regexp is too general,
  46 ;; you will see error messages from the dirtrack filter as it attempts to cd
  47 ;; to non-existent directories.
  48 ;;
  49 ;; 2) Set the variable `dirtrack-list' to an appropriate value.  This
  50 ;; should be a list of two elements: the first is a regular expression
  51 ;; which matches your prompt up to and including the pathname part.
  52 ;; The second is a number which tells which regular expression group to
  53 ;; match to extract only the pathname.  If you use a multi-line prompt,
  54 ;; add 't' as a third element.  Note that some of the functions in
  55 ;; 'comint.el' assume a single-line prompt (eg, comint-bol).
  56 ;;
  57 ;; Determining this information may take some experimentation.  Using
  58 ;; `dirtrack-debug-mode' may help; it causes the directory-tracking
  59 ;; filter to log messages to the buffer `dirtrack-debug-buffer'.
  60 ;;
  61 ;; 3) Activate `dirtrack-mode'.  You may wish to turn ordinary shell
  62 ;; tracking off by calling `shell-dirtrack-mode'.
  63 ;;
  64 ;; Examples:
  65 ;;
  66 ;; 1) On Windows NT, my prompt is set to emacs$S$P$G.
  67 ;; 'dirtrack-list' is set to (list "^emacs \\([a-zA-Z]:.*\\)>" 1)
  68 ;;
  69 ;; 2) On Solaris running bash, my prompt is set like this:
  70 ;;    PS1="\w\012emacs@\h(\!) [\t]% "
  71 ;;    'dirtrack-list' is set to (list "^\\([/~].*\\)\nemacs@[^%]+% *" 1 t)
  72 ;;
  73 ;; I'd appreciate other examples from people who use this package.
  74 ;;
  75 ;; Here's one from Stephen Eglen:
  76 ;;
  77 ;;   Running under tcsh:
  78 ;;   (setq-default dirtrack-list '("^%E \\([^ ]+\\)" 1))
  79 ;;
  80 ;;   It might be worth mentioning in your file that emacs sources start up
  81 ;;   files of the form: ~/.emacs_<SHELL> where <SHELL> is the name of the
  82 ;;   shell.  So for example, I have the following in ~/.emacs_tcsh:
  83 ;;
  84 ;;   set prompt = "%%E %~ %h% "
  85 ;;
  86 ;;   This produces a prompt of the form:
  87 ;;   %E /var/spool 10%
  88 ;;
  89 ;;   This saves me from having to use the %E prefix in other non-emacs
  90 ;;   shells.
  91 ;;
  92 ;; A final note:
  93 ;;
  94 ;;   I run LOTS of shell buffers through Emacs, sometimes as different users
  95 ;;   (eg, when logged in as myself, I'll run a root shell in the same Emacs).
  96 ;;   If you do this, and the shell prompt contains a ~, Emacs will interpret
  97 ;;   this relative to the user which owns the Emacs process, not the user
  98 ;;   who owns the shell buffer.  This may cause dirtrack to behave strangely
  99 ;;   (typically it reports that it is unable to cd to a directory
 100 ;;   with a ~ in it).
 101 ;;
 102 ;;   The same behavior can occur if you use dirtrack with remote filesystems
 103 ;;   (using telnet, rlogin, etc) as Emacs will be checking the local
 104 ;;   filesystem, not the remote one.  This problem is not specific to dirtrack,
 105 ;;   but also affects file completion, etc.
 106
 107 ;;; Code:
 108
 109 (eval-when-compile
 110   (require 'comint)
 111   (require 'shell))
 112
 113 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 114 ;; Customization Variables
 115 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 116
 117 (defgroup dirtrack nil
 118   "Directory tracking by watching the prompt."
 119   :prefix "dirtrack-"
 120   :group 'shell)
 121
 122 (defcustom dirtrack-list (list "^emacs \\([a-zA-Z]:.*\\)>" 1)
 123   "List for directory tracking.
 124 First item is a regexp that describes where to find the path in a prompt.
 125 Second is a number, the regexp group to match."
 126   :group 'dirtrack
 127   :type  '(sexp (regexp  :tag "Prompt Expression")
 128                 (integer :tag "Regexp Group"))
 129   :version "24.1")
 130
 131 (make-variable-buffer-local 'dirtrack-list)
 132
 133 (defcustom dirtrack-debug nil
 134   "If non-nil, the function `dirtrack' will report debugging info."
 135   :group 'dirtrack
 136   :type  'boolean)
 137
 138 (defcustom dirtrack-debug-buffer "*Directory Tracking Log*"
 139   "Buffer in which to write directory tracking debug information."
 140   :group 'dirtrack
 141   :type  'string)
 142
 143 (defcustom dirtrack-directory-function
 144   (if (memq system-type '(ms-dos windows-nt cygwin))
 145       'dirtrack-windows-directory-function
 146     'file-name-as-directory)
 147   "Function to apply to the prompt directory for comparison purposes."
 148   :group 'dirtrack
 149   :type  'function)
 150
 151 (defcustom dirtrack-canonicalize-function
 152   (if (memq system-type '(ms-dos windows-nt cygwin))
 153       'downcase 'identity)
 154   "Function to apply to the default directory for comparison purposes."
 155   :group 'dirtrack
 156   :type  'function)
 157
 158 (defcustom dirtrack-directory-change-hook nil
 159   "Hook that is called when a directory change is made."
 160   :group 'dirtrack
 161   :type 'hook)
 162
 163
 164 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 165 ;; Functions
 166 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 167
 168
 169 (defun dirtrack-windows-directory-function (dir)
 170   "Return a canonical directory for comparison purposes.
 171 Such a directory is all lowercase, has forward-slashes as delimiters,
 172 and ends with a forward slash."
 173   (file-name-as-directory (downcase (subst-char-in-string ?\\ ?/ dir))))
 174
 175 (defun dirtrack-cygwin-directory-function (dir)
 176   "Return a canonical directory taken from a Cygwin path for comparison purposes."
 177   (if (string-match "/cygdrive/\\([A-Z]\\)\\(.*\\)" dir)
 178       (concat (match-string 1 dir) ":" (match-string 2 dir))
 179     dir))
 180
 181
 182 ;;;###autoload
 183 (define-minor-mode dirtrack-mode
 184   "Toggle directory tracking in shell buffers (Dirtrack mode).
 185 With a prefix argument ARG, enable Dirtrack mode if ARG is
 186 positive, and disable it otherwise.  If called from Lisp, enable
 187 the mode if ARG is omitted or nil.
 188
 189 This method requires that your shell prompt contain the current
 190 working directory at all times, and that you set the variable
 191 `dirtrack-list' to match the prompt.
 192
 193 This is an alternative to `shell-dirtrack-mode', which works by
 194 tracking `cd' and similar commands which change the shell working
 195 directory."
 196   nil nil nil
 197   (if dirtrack-mode
 198       (add-hook 'comint-preoutput-filter-functions 'dirtrack nil t)
 199     (remove-hook 'comint-preoutput-filter-functions 'dirtrack t)))
 200
 201 (define-obsolete-function-alias 'dirtrack-toggle 'dirtrack-mode "23.1")
 202 (define-obsolete-variable-alias 'dirtrackp 'dirtrack-mode "23.1")
 203
 204
 205 (define-minor-mode dirtrack-debug-mode
 206   "Toggle Dirtrack debugging."
 207   nil nil nil
 208   (if dirtrack-debug-mode
 209       (display-buffer (get-buffer-create dirtrack-debug-buffer))))
 210
 211 (define-obsolete-function-alias 'dirtrack-debug-toggle 'dirtrack-debug-mode
 212   "23.1")
 213 (define-obsolete-variable-alias 'dirtrack-debug 'dirtrack-debug-mode "23.1")
 214
 215
 216 (defun dirtrack-debug-message (msg1 msg2)
 217   "Insert strings at the end of `dirtrack-debug-buffer'."
 218   (when dirtrack-debug-mode
 219     (with-current-buffer (get-buffer-create dirtrack-debug-buffer)
 220       (goto-char (point-max))
 221       (insert msg1 msg2 "\n"))))
 222
 223 ;;;###autoload
 224 (defun dirtrack (input)
 225   "Determine the current directory from the process output for a prompt.
 226 This filter function is used by `dirtrack-mode'.  It looks for
 227 the prompt specified by `dirtrack-list', and calls
 228 `shell-process-cd' if the directory seems to have changed away
 229 from `default-directory'."
 230   (when (and dirtrack-mode
 231              (not (eq (point) (point-min)))) ; there must be output
 232     (save-excursion ; What's this for? -- cyd
 233       (if (not (string-match (nth 0 dirtrack-list) input))
 234           ;; No match
 235           (dirtrack-debug-message
 236            "Input failed to match `dirtrack-list': " input)
 237         (let ((prompt-path (match-string (nth 1 dirtrack-list) input))
 238               temp)
 239           (cond
 240            ;; Don't do anything for empty string
 241            ((string-equal prompt-path "")
 242             (dirtrack-debug-message "Prompt match gives empty string: " input))
 243            ;; If the prompt contains an absolute file name, call
 244            ;; `shell-process-cd' if the directory has changed.
 245            ((file-name-absolute-p prompt-path)
 246             ;; Transform prompts into canonical forms
 247             (let ((orig-prompt-path (funcall dirtrack-directory-function
 248                                              prompt-path))
 249                   (current-dir      (funcall dirtrack-canonicalize-function
 250                                              default-directory)))
 251               (setq prompt-path (shell-prefixed-directory-name orig-prompt-path))
 252               ;; Compare them
 253               (if (or (string-equal current-dir prompt-path)
 254                       (string-equal (expand-file-name current-dir)
 255                                     (expand-file-name prompt-path)))
 256                   (dirtrack-debug-message "Not changing directory: " current-dir)
 257                 ;; It's possible that Emacs thinks the directory
 258                 ;; doesn't exist (e.g. rlogin buffers)
 259                 (if (file-accessible-directory-p prompt-path)
 260                     ;; `shell-process-cd' adds the prefix, so we need
 261                     ;; to give it the original (un-prefixed) path.
 262                     (progn
 263                       (shell-process-cd orig-prompt-path)
 264                       (run-hooks 'dirtrack-directory-change-hook)
 265                       (dirtrack-debug-message "Changing directory to "
 266                                               prompt-path))
 267                   (dirtrack-debug-message "Not changing to non-existent directory: "
 268                                           prompt-path)))))
 269            ;; If the file name is non-absolute, try and see if it
 270            ;; seems to be up or down from where we were.
 271            ((string-match "\\`\\(.*\\)\\(?:/.*\\)?\n\\(.*/\\)\\1\\(?:/.*\\)?\\'"
 272                           (setq temp
 273                                 (concat prompt-path "\n" default-directory)))
 274             (shell-process-cd (concat (match-string 2 temp)
 275                                       prompt-path))
 276             (run-hooks 'dirtrack-directory-change-hook)))))))
 277   input)
 278
 279 (provide 'dirtrack)
 280
 281 ;;; dirtrack.el ends here