code.delx.au - gnu-emacs-elpa/blob - poptoshell.el

   1 ;;; poptoshell.el --- get to the process buffer and input mark
   2
   3 ;; Copyright (C) 1999-2011 Free Software Foundation, Inc. and Ken Manheimer
   4
   5 ;; Author: Ken Manheimer <ken dot manheimer at gmail...>
   6 ;; Maintainer: Ken Manheimer <ken dot manheimer at gmail...>
   7 ;; Created: 1999 -- first public release
   8 ;; Keywords: processes
   9 ;; Website: http://myriadicity.net/software-and-systems/craft/crafty-hacks/emacs-sundries/poptoshell.el/view
  10 ;;
  11 ;;; Commentary:
  12 ;;
  13 ;; I bind to M-<space>, via eg: (global-set-key "\M- " 'pop-to-shell)
  14 ;; See the pop-to-shell docstring for details.
  15 ;;
  16 ;; klm, 02/09/1999.
  17
  18 (defvar non-interactive-process-buffers '("*compilation*" "*grep*"))
  19
  20 (require 'comint)
  21 (require 'shell)
  22
  23 (provide 'poptoshell)
  24
  25 (defcustom pop-to-shell-frame nil
  26   "*If non-nil, jump to a frame already showing the shell, if any.
  27
  28 Otherwise, open a new window in the current frame."
  29   :type 'boolean
  30   :group 'comint)
  31
  32 (defvar pop-to-shell-primary-name "*shell*"
  33   "Shell name to use for un-modified pop-to-shell buffer target.")
  34
  35 (defun pop-to-shell (&optional arg)
  36
  37   "Navigate to or within a shell buffer.
  38
  39 Use this command from within a shell subprocess buffer to get to
  40 the shell input point, or from outside a shell buffer to pop to a
  41 shell buffer, without displacing the current buffer.
  42
  43 Specifically, like 'shell' command but:
  44
  45  - If the current buffer is associated with a subprocess (and one not
  46    among those named on `non-interactive-process-buffers'), then focus
  47    is moved to the process input point, else...
  48  - Goes to a window that is already showing a shell buffer, if any.
  49    In this case, the cursor is left in its prior position in the shell
  50    buffer. (Repeating the command will then go to the process input
  51    point, by the behavior mentioned just before this.) Else...
  52  - Pops open a new shell buffer, if none is around.
  53
  54 In any cases where the shell buffer already existed, the process
  55 is resumed if it was stopped.
  56
  57 Further,
  58
  59  - With a universal argument, the user is prompted for the buffer name to
  60    use (it will be bracketed by asterisks - a regrettable comint
  61    requirement), defaulting to 'shell'.  This makes it easy to switch
  62    between multiple process-associated buffers.
  63  - A double universal argument will set the default target shell buffer name
  64    to the provided one, making the target shell subsequently primary."
  65
  66   (interactive "P")
  67
  68   (if (not (boundp 'shell-buffer-name))
  69       (setq shell-buffer-name "*shell*"))
  70
  71   (let* ((from (current-buffer))
  72          (doublearg (equal arg '(16)))
  73          (temp (if arg
  74                    (read-shell-buffer-name-sans
  75                     (format "Shell buffer name [%s]%s "
  76                             pop-to-shell-primary-name
  77                             (if doublearg " <==" ":"))
  78                     pop-to-shell-primary-name)
  79                  pop-to-shell-primary-name))
  80          ;; Make sure it is bracketed with asterisks; silly.
  81          (target-shell-buffer-name (if (string= temp "")
  82                                        pop-to-shell-primary-name
  83                                      (bracket-asterisks temp)))
  84          (curr-buff-proc (or (get-buffer-process from)
  85                              (and (fboundp 'rcirc-buffer-process)
  86                                   (rcirc-buffer-process))
  87                              (and (boundp 'erc-process)
  88                                   erc-process)))
  89          (buff (if (and curr-buff-proc
  90                         (not (member (buffer-name from)
  91                                      non-interactive-process-buffers)))
  92                    from
  93                  (get-buffer target-shell-buffer-name)))
  94          (inwin nil)
  95          (num 0)
  96          already-there)
  97     (when doublearg
  98       (setq pop-to-shell-primary-name target-shell-buffer-name))
  99     (if (and curr-buff-proc
 100              (not arg)
 101              (eq from buff)
 102              (not (eq target-shell-buffer-name (buffer-name from))))
 103         ;; We're in a buffer with a shell process, but not named shell
 104         ;; - stick with it, but go to end:
 105         (setq already-there t)
 106       (cond
 107                                         ; Already in the shell buffer:
 108        ((string= (buffer-name) target-shell-buffer-name)
 109         (setq already-there t))
 110        ((or (not buff)
 111             (not (catch 'got-a-vis
 112                    (my-walk-windows
 113                     (function (lambda (win)
 114                                 (if (and (eq (window-buffer win) buff)
 115                                          (equal (frame-parameter
 116                                                  (selected-frame) 'display)
 117                                                 (frame-parameter
 118                                                  (window-frame win) 'display)))
 119                                     (progn (setq inwin win)
 120                                            (throw 'got-a-vis win))
 121                                   (setq num (1+ num)))))
 122                     nil 'visible t)
 123                    nil)))
 124         ;; No preexisting shell buffer, or not in a visible window:
 125         (pop-to-buffer target-shell-buffer-name pop-up-windows))
 126        ;; Buffer exists and already has a window - jump to it:
 127        (t (if (and pop-to-shell-frame
 128                    inwin
 129                    (not (equal (window-frame (selected-window))
 130                                (window-frame inwin))))
 131               (select-frame-set-input-focus (window-frame inwin)))
 132           (if (not (string= (buffer-name (current-buffer))
 133                             target-shell-buffer-name))
 134               (pop-to-buffer target-shell-buffer-name t))))
 135       (condition-case err
 136           (if (not (comint-check-proc (current-buffer)))
 137               (start-shell-in-buffer (buffer-name (current-buffer))))
 138         (file-error
 139          ;; Whoops - can't get to the default directory, keep trying
 140          ;; superior ones till we get somewhere that's acceptable:
 141          (while (and (not (string= default-directory ""))
 142                      (not (condition-case err (progn (shell) t)
 143                             (file-error nil))))
 144            (setq default-directory
 145                  (file-name-directory
 146                   (substring default-directory
 147                              0
 148                              (1- (length default-directory)))))))
 149         ))
 150     ;; If the destination buffer has a stopped process, resume it:
 151     (let ((process (get-buffer-process (current-buffer))))
 152       (if (and process (equal 'stop (process-status process)))
 153           (continue-process process)))
 154     (if (and (not already-there)
 155              (not (equal (current-buffer) from)))
 156         t
 157       (goto-char (point-max))
 158       (and (get-buffer-process from)
 159            (goto-char (process-mark (get-buffer-process from)))))
 160     )
 161   )
 162 (defun my-walk-windows (func &optional minibuf all-frames selected)
 163   (if (featurep 'xemacs)
 164       (walk-windows func minibuf all-frames (selected-device))
 165     (walk-windows func minibuf all-frames)))
 166
 167 (defun my-set-mouse-position (window x y)
 168   "Adapt for both xemacs and fsf emacs"
 169   (if (string= (substring (emacs-version) 0 6) "XEmacs")
 170       (set-mouse-position window x y)
 171     (let ((frame (window-frame window)))
 172       (select-frame-set-input-focus frame))))
 173
 174
 175 (defun read-shell-buffer-name-sans (prompt default)
 176   "Obtain name without asterisks of shell buffer, adding the asterisks.
 177
 178 Return indicated default on empty input."
 179   (let ((got
 180          (completing-read
 181           prompt
 182           (filter 'identity
 183                   (mapcar (lambda (buffer)
 184                             (let ((name (buffer-name buffer)))
 185                               (if (with-current-buffer buffer
 186                                          (eq major-mode 'shell-mode))
 187                                   (if (> (length name) 2)
 188                                       (substring name 1 (1- (length
 189                                                              name)))
 190                                     name))))
 191                           (buffer-list))))))
 192     (if (not (string= got "")) (bracket-asterisks got) default)))
 193
 194 (defun bracket-asterisks (name)
 195   "Return a copy of name, ensuring it has an asterisk at the beginning and end."
 196   (if (not (string= (substring name 0 1) "*"))
 197       (setq name (concat "*" name)))
 198   (if (not (string= (substring name -1) "*"))
 199       (setq name (concat name "*")))
 200   name)
 201 (defun unbracket-asterisks (name)
 202   "Return a copy of name, removing asterisks at beg and end, if any."
 203   (if (string= (substring name 0 1) "*")
 204       (setq name (substring name 1)))
 205   (if (string= (substring name -1) "*")
 206       (setq name (substring name 0 -1)))
 207   name)
 208 (defun start-shell-in-buffer (buffer-name)
 209   ;; Damn comint requires buffer name be bracketed by "*" asterisks.
 210   (require 'comint)
 211   (require 'shell)
 212
 213   (let* ((buffer buffer-name)
 214          (prog (or explicit-shell-file-name
 215                    (getenv "ESHELL")
 216                    (getenv "SHELL")
 217                    "/bin/sh"))
 218          (name (file-name-nondirectory prog))
 219          (startfile (concat "~/.emacs_" name))
 220          (xargs-name (intern-soft (concat "explicit-" name "-args"))))
 221     (setq buffer (set-buffer (apply 'make-comint
 222                                     (unbracket-asterisks buffer-name)
 223                                     prog
 224                                     (if (file-exists-p startfile)
 225                                         startfile)
 226                                     (if (and xargs-name
 227                                              (boundp xargs-name))
 228                                         (symbol-value xargs-name)
 229                                       '("-i")))))
 230     (set-buffer buffer-name)
 231     (shell-mode)))