lisp/dirtrack.el

   1 ;;; dirtrack.el --- Directory Tracking by watching the prompt
   2
   3 ;; Copyright (C) 1996, 2001-2017 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 <https://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 (define-obsolete-function-alias 'dirtrack-toggle 'dirtrack-mode "23.1")
 183 (define-obsolete-variable-alias 'dirtrackp 'dirtrack-mode "23.1")
 184 ;;;###autoload
 185 (define-minor-mode dirtrack-mode
 186   "Toggle directory tracking in shell buffers (Dirtrack mode).
 187 With a prefix argument ARG, enable Dirtrack mode if ARG is
 188 positive, and disable it otherwise.  If called from Lisp, enable
 189 the mode if ARG is omitted or nil.
 190
 191 This method requires that your shell prompt contain the current
 192 working directory at all times, and that you set the variable
 193 `dirtrack-list' to match the prompt.
 194
 195 This is an alternative to `shell-dirtrack-mode', which works by
 196 tracking `cd' and similar commands which change the shell working
 197 directory."
 198   nil nil nil
 199   (if dirtrack-mode
 200       (add-hook 'comint-preoutput-filter-functions 'dirtrack nil t)
 201     (remove-hook 'comint-preoutput-filter-functions 'dirtrack t)))
 202
 203
 204 (define-obsolete-function-alias 'dirtrack-debug-toggle 'dirtrack-debug-mode
 205   "23.1")
 206 (define-obsolete-variable-alias 'dirtrack-debug 'dirtrack-debug-mode "23.1")
 207 (define-minor-mode dirtrack-debug-mode
 208   "Toggle Dirtrack debugging.
 209 With a prefix argument ARG, enable Dirtrack debugging if ARG is
 210 positive, and disable it otherwise.  If called from Lisp, enable
 211 the mode if ARG is omitted or nil."
 212   nil nil nil
 213   (if dirtrack-debug-mode
 214       (display-buffer (get-buffer-create dirtrack-debug-buffer))))
 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 (substitute-command-keys msg1) msg2 "\n"))))
 222
 223 (declare-function shell-prefixed-directory-name "shell" (dir))
 224 (declare-function shell-process-cd "shell" (arg))
 225
 226 ;;;###autoload
 227 (defun dirtrack (input)
 228   "Determine the current directory from the process output for a prompt.
 229 This filter function is used by `dirtrack-mode'.  It looks for
 230 the prompt specified by `dirtrack-list', and calls
 231 `shell-process-cd' if the directory seems to have changed away
 232 from `default-directory'."
 233   (when (and dirtrack-mode
 234              (not (eq (point) (point-min)))) ; there must be output
 235     (save-excursion ; What's this for? -- cyd
 236       (if (not (string-match (nth 0 dirtrack-list) input))
 237           ;; No match
 238           (dirtrack-debug-message
 239            "Input failed to match `dirtrack-list': " input)
 240         (let ((prompt-path (match-string (nth 1 dirtrack-list) input))
 241               temp)
 242           (cond
 243            ;; Don't do anything for empty string
 244            ((string-equal prompt-path "")
 245             (dirtrack-debug-message "Prompt match gives empty string: " input))
 246            ;; If the prompt contains an absolute file name, call
 247            ;; `shell-process-cd' if the directory has changed.
 248            ((file-name-absolute-p prompt-path)
 249             ;; Transform prompts into canonical forms
 250             (let ((orig-prompt-path (funcall dirtrack-directory-function
 251                                              prompt-path))
 252                   (current-dir      (funcall dirtrack-canonicalize-function
 253                                              default-directory)))
 254               (setq prompt-path (shell-prefixed-directory-name orig-prompt-path))
 255               ;; Compare them
 256               (if (or (string-equal current-dir prompt-path)
 257                       (string-equal (expand-file-name current-dir)
 258                                     (expand-file-name prompt-path)))
 259                   (dirtrack-debug-message "Not changing directory: " current-dir)
 260                 ;; It's possible that Emacs thinks the directory
 261                 ;; doesn't exist (e.g. rlogin buffers)
 262                 (if (file-accessible-directory-p prompt-path)
 263                     ;; `shell-process-cd' adds the prefix, so we need
 264                     ;; to give it the original (un-prefixed) path.
 265                     (progn
 266                       (shell-process-cd orig-prompt-path)
 267                       (run-hooks 'dirtrack-directory-change-hook)
 268                       (dirtrack-debug-message "Changing directory to "
 269                                               prompt-path))
 270                   (dirtrack-debug-message "Not changing to non-existent directory: "
 271                                           prompt-path)))))
 272            ;; If the file name is non-absolute, try and see if it
 273            ;; seems to be up or down from where we were.
 274            ((string-match "\\`\\(.*\\)\\(?:/.*\\)?\n\\(.*/\\)\\1\\(?:/.*\\)?\\'"
 275                           (setq temp
 276                                 (concat prompt-path "\n" default-directory)))
 277             (shell-process-cd (concat (match-string 2 temp)
 278                                       prompt-path))
 279             (run-hooks 'dirtrack-directory-change-hook)))))))
 280   input)
 281
 282 (provide 'dirtrack)
 283
 284 ;;; dirtrack.el ends here