InfoMagic Source Code 1993 July/THE_SOURCE_CODE_CD_ROM.iso/languages/elisp/misc/baw-tracker.el

Text File | 1991-05-03 | 12.5 KB | 378 lines

;; baw-tracker.el
;;
;; a better tracker of directory navigation

;; Does a better, but still not perfect job of tracking csh builtin
;; commands that modify the directory and directory stack.  Correctly
;; tracks commands `cd', `pushd', `popd' and `dirs' with arguments.
;; Correctly expands paths containing environment variables, `~', `.'
;; and `..'.  Still can't track paths which contain shell variables,
;; execs, etc.  Currently only tested with /bin/csh, on Suns.
;; Compatible with both *shell* mode and *cmushell* mode.

;; Builtins recognized:
;;
;; cd [path]
;; pushd [+n | path]
;; popd [+n]
;; dirs [-l]
;;
;; Other commands recognized:
;;
;; ftp  (this shuts off auto tracking, waits for "quit")
;;
;; path can be either absolute or relative, n must be > 0.

;; Interactive commands available to you:
;; tk-on     : explicitly turn on directory tracking
;; tk-off    : explicitly turn off directory tracking
;; tk-resync : explicitly resync tracking engine

;; To use cons this to your shell-mode-hook:
;; (load "baw-tracker")

;; This file is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY.  No author or distributor accepts
;; responsibility to anyone for the consequences of using it or for
;; whether it serves any particular purpose or works at all, unless
;; s/he says so in writing.

;; This software was written as part of the author's official duty as
;; an employee of the United States Government and is thus in the
;; public domain.  You are free to use this software as you wish, but
;; WITHOUT ANY WARRANTY WHATSOEVER.  It would be nice, though if when
;; you use this code, you give due credit to the author.

;; ======================================================================
;; Author:
;;
;; NAME: Barry A. Warsaw           USMAIL: National Institute of Standards
;; TELE: [phone]                      and Technology (formerly NBS)
;; UUCP: {...}!uunet!cme-durer!warsaw      Rm. B-124, Bldg. 220
;; ARPA: [e-mail]               Gaithersburg, MD 20899

;; ======================================================================
;; Modification history:
;;
;; posted  :  1-Mar-1990 baw (comp.emacs, gnu.emacs)
;; modified:  1-Mar-1990 baw (turn tracking on and off with ftp/quit)
;;                           (explicit resync)
;; modified: 26-Feb-1990 baw (fixed front end for *shell* mode)
;; modified: 22-Jan-1990 baw (for compatibility w/ cmushell)
;;                           (fix some algorithms, factor code)
;; modified: 16-Nov-1989 baw (buffer local variables)
;; posted  : 14-Sep-1989 baw (comp.emacs, gnu.emacs)
;; modified: 14-Sep-1989 baw (cleaned up for posting)
;; modified: 11-Sep-1989 baw (fixed regexps)
;; created :  8-Sep-1989 baw

;; ======================================================================
;; Wish list:
;;
;; 1) Would like to be able to glob directory better to find the actual
;;    directory cd'd to in the case of shell variables, execs, etc.
;;
;; 2) Really would to be able to query the shell process for the current
;;    working directory.
;;
;; 3) Perhaps finagle "pwd" command for resyncing directory tracker when
;;    it gets off track.  This is a little more difficult since tracker
;;    has to watch for input that comes after its done processing the
;;    current line.  I'm currently opting for a manual resync of the
;;    the tracking engine via tk-resync


(defvar tk-track-p t
  "*Boolean flag which indicates whether tracking should or should not
be done. This is used to turn off tracking when entering ftp mode and
turning it back on when exiting ftp mode. Non-nil means to track
directories, nil means don't track directories.")

(defvar tk-eos-regexp "\\s *\\([\n;]\\|$\\)"
  "*Regular expression signifying the end of a shell builtin command,
correctly locating either a newline terminated statement, or a \";\"
delimited compound statement.")

(defvar tk-cd-regexp "cd"
  "*Regular expression signifying builtin `cd' command.")

(defvar tk-popd-regexp "popd"
  "*Regular expression signifying builtin `popd' command.")

(defvar tk-pushd-regexp "pushd"
  "*Regular expression signifying builtin `pushd' command.")

(defvar tk-dirs-regexp "dirs"
  "*Regular expression signifying builtin `dirs' command.")

(defvar tk-ftp-regexp "ftp"
  "*Regular expression signifying builtin `ftp' commands.")

(defvar tk-tracking-error-hook 'ignore
  "*Function called with no arguments when tracking in either
shell-mode or cmushell-mode results in an error.")

(defvar tk-start-tracking-regexp "quit"
  "*Regular expression which tells tracker to start tracking once
turned off.")

(setq shell-set-directory-error-hook tk-tracking-error-hook)
(setq tk-directory-stack nil)
(make-variable-buffer-local 'default-directory)
(make-variable-buffer-local 'tk-directory-stack)


(defun tk-parse-statement (statement regexp)
  "Parse STATEMENT to see if it contains the builtin command signified
by REGEXP.  Returns nil if the statement is not the signified builtin
command, otherwise returns a list specifying the arguments passed to
command, in the form: (N (ARG1 ARG2 ...)) where N is the number of
arguments."
  (let ((n 0)
    (args nil)
    arg
    (command (string-match (concat "^\\("
                       regexp
                       "\\)\\(\\s +\\|$\\)")
                   statement))
    (nextargi (match-end 0))
    )
    (if (not command) nil
      (while (string-match "\\S +" statement nextargi)
    (setq arg (substring statement (match-beginning 0) (match-end 0)))
    (setq args (append args (list arg)))
    (setq n (1+ n))
    (string-match "\\S +\\s +" statement nextargi)
    (setq nextargi (match-end 0))
    )
      (list n args)
      )
    ))


(defun tk-wholenum-arg-p (string)
  "Predicate which tests whether STRING is a whole number (i.e. an
integer greater than zero).  It returns the whole number if STRING
does not contain any non-numeric charcters, and is greater than zero,
otherwise returns nil. Also note that since this is an argument to a
builtin command, the first character of the string *must* be a plus
sign."
  (cond
   ((not (string-match "^\\+[1-9]+[0-9]*$" string))
    nil)
   ((> (string-to-int string) 0)
    (string-to-int string))
   (t nil)
   ))


(defun tk-listify-compound-command (command)
  "Convert COMMAND, which may be a compound statement (i.e. cd; ls)
into a list of simple statements. Only separators I know of are
\";\"."
  (let ((statements nil)
    (nextstatementi 0))
    (while (< nextstatementi (length command))
      (string-match tk-eos-regexp command nextstatementi)
      (setq statements
        (append statements (list (substring command
                        nextstatementi
                        (match-beginning 0)))))
      (setq nextstatementi (1+ (match-end 0)))
      )
    statements
    ))


(defun tk-on ()
  "Turn on directory tracker."
  (interactive)
  (message "Turning on directory tracker.")
  (setq tk-track-p t)
  )


(defun tk-off ()
  "Turn off directory tracker."
  (interactive)
  (message "Turning off directory tracker.")
  (setq tk-track-p nil)
  )


(defun tk-resync (dir)
  "Resync directory tracking engine."
  (interactive "DResync to: ")
  (cd dir)
  )


(defun tk-tracking-engine (statement)
  "Parse the STATEMENT for one of the directory navigating builtin
commands and modify the directory stack accordingly.  STATEMENT should
be a single statement, not a compound statement."
  (let ((dir0 default-directory)
    args
    numeric)

    ;; test for each builtin command
    (cond
     ((setq args (tk-parse-statement statement tk-start-tracking-regexp))
      ;; we're looking at a command that restarts tracking, set by
      ;; various tracked commands
      (tk-on)
      )

     ((not tk-track-p))
     ;; is the tracking flag turned off?

     ((setq args (tk-parse-statement statement tk-ftp-regexp))
      ;; we're looking at an ftp command which shouldn't track
      (setq tk-start-tracking-regexp "quit")
      (tk-off)
      )

     ((setq args (tk-parse-statement statement tk-cd-regexp))
      ;; we're looking at a cd command
      (cond
       ((= (car args) 0)
    ;; looking at a no arg'd cd command, means cd to $HOME
    (cd (expand-file-name (substitute-in-file-name "$HOME"))))
       ((> (car args) 1)
    (error "cd: Too many arguments."))
       ((= (car args) 1)
    (cd (expand-file-name
         (substitute-in-file-name (car (car (cdr args)))))))
       (t
    (error "How did you get a negative number of arguments?"))
       ))

     ((setq args (tk-parse-statement statement tk-popd-regexp))
      ;; we're looking at a popd command
      (cond
       ((= (car args) 0)
    ;; looking at a no arg'd popd, pop "top" directory from stack
    (cd (or (car tk-directory-stack)
        (error "popd: Directory stack empty.")))
    (setq tk-directory-stack (cdr tk-directory-stack)))
       ((> (car args) 1)
    (error "popd: Too many arguments."))
       ((< (car args) 0)
    (error "How did you get a negative number of arguments?"))
       ((not (setq numeric (tk-wholenum-arg-p (car (car (cdr args))))))
    (error "popd: Invalid argument: %s" (car (car (cdr args)))))
       ;; check to be sure there *is* an nth dir on the stack
       ((not (nth (1- numeric) tk-directory-stack))
    (error "popd: Directory stack not that deep."))
       ;; first pecial case when only two dirs are on the stack
       ((not (cdr tk-directory-stack))
    (setq tk-directory-stack nil))
       ;; second special case when popping the first dir on stack
       ((= numeric 1)
    (let ((tcdr (nthcdr numeric tk-directory-stack)))
      (setcar tk-directory-stack (car tcdr))
      (setcdr tk-directory-stack (cdr tcdr))
      ))
       (t
    (setcdr (nthcdr (- numeric 2) tk-directory-stack)
        (nthcdr numeric tk-directory-stack)))
       ))

     ((setq args (tk-parse-statement statement tk-pushd-regexp))
      ;; we're looking at a pushd command
      (cond
       ((= (car args) 0)
    ;; looking at a no arg'd pushd, exchange top two directories
    (cd (or (car tk-directory-stack)
        (error "pushd: No other directory.")))
    (setq tk-directory-stack (append (list dir0)
                     (cdr tk-directory-stack))))
       ;; looking at a numeric argument
       ((setq numeric (tk-wholenum-arg-p (car (car (cdr args)))))
    (cd (or (nth (1- numeric) tk-directory-stack)
        (error "pushd: Directory stack not that deep.")))
    (while (< 0 numeric)
      (setq tk-directory-stack (append tk-directory-stack (list dir0))
        dir0 (car tk-directory-stack)
        tk-directory-stack (cdr tk-directory-stack)
        numeric (1- numeric)
        ))
    )
       (t
    ;; must be looking at a directory pathname
    (cd (expand-file-name
         (substitute-in-file-name (car (car (cdr args))))))
    (setq tk-directory-stack (append (list dir0) tk-directory-stack)))
       ))

     ((setq args (tk-parse-statement statement tk-dirs-regexp))
      ;; we're looking at a dirs command
      (cond
       ((= (car args) 0)
    ;; looking at a no arg'd dirs command
    (let ((dirs ""))
      (mapcar
       (function
        (lambda (dir)
          (and (string-match (concat "^" (substitute-in-file-name "$HOME"))
                 dir)
           (setq dir (concat "~" (substring dir (match-end 0))))
           )
          (setq dirs (concat dirs (if (string-match "^~/$" dir)
                      "~"
                    (directory-file-name dir))
                 " "))
          )) ;; function
       (append (list default-directory) tk-directory-stack)) ;; mapcar
      (message "%s" dirs)
      ))
       ((< (car args) 0)
    (error "How did you get a negative number of arguments?"))
       ((> (car args) 1)
    (error "dirs: Too many arguments."))
       ;; -l option is only one I know of for dirs
       ((string-match "^-l$" (car (car (cdr args))))
    (let ((dirs ""))
      (mapcar
       (function
        (lambda (dir)
          (setq dirs (concat dirs (directory-file-name dir) " "))
          ))
       (append (list default-directory) tk-directory-stack))
      (message "%s" dirs)))
       (t
    (error "Usage: dirs [ -l ]."))
       ))
     )
    ))


(defun shell-set-directory ()
  "Better directory navigation tracker for shell-mode."
  (let* ((commandline (buffer-substring (point)
                    (save-excursion
                      (end-of-line)
                      (point))))
     (statements (tk-listify-compound-command commandline)))
    (while statements
      (tk-tracking-engine (car statements))
      (setq statements (cdr statements))
      )
    ))


(defun shell-directory-tracker (commandline)
  "Better directory navigation tracker for cmushell-mode."
  (let ((statements (tk-listify-compound-command commandline)))
    (while statements
      ;; note that we need to encase the call to the tracking engine
      ;; in a condition case to trap any errors that are signaled in
      ;; tk-tracking-engine.  Shell-mode automatically does this and we
      ;; want the two to be compatible. Ripped this from shell.el
      (condition-case ()
      (tk-tracking-engine (car statements))
    (error (funcall tk-tracking-error-hook)))
      (setq statements (cdr statements))
      )
    ))