cgit.sxemacs.org Git - packages/blob - xemacs-packages/os-utils/background.el

   1 ;;; background.el --- fun with background jobs
   2
   3 ;; Copyright (C) 1988 Joe Keane <jk3k+@andrew.cmu.edu>
   4 ;; Keywords: processes
   5
   6 ;; This file is part of XEmacs.
   7
   8 ;; XEmacs is free software; you can redistribute it and/or modify
   9 ;; it under the terms of the GNU General Public License as published by
  10 ;; the Free Software Foundation; either version 2 of the License, or
  11 ;; (at your option) any later version.
  12
  13 ;; XEmacs is distributed in the hope that it will be useful,
  14 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 ;; GNU General Public License for more details.
  17
  18 ;; You should have received a copy of the GNU General Public License
  19 ;; along with XEmacs; if not, write to the Free Software
  20 ;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
  21 ;; 02111-1307, USA.
  22
  23 ;;; Synched up with: Not in FSF
  24
  25 ;;; Commentary:
  26
  27 ;; - Adapted to use comint and cleaned up somewhat. Olin Shivers 5/90
  28 ;; - Background failed to set the process buffer's working directory
  29 ;;   in some cases. Fixed. Olin 6/14/90
  30 ;; - Background failed to strip leading cd's off the command string
  31 ;;   after performing them. This screwed up relative pathnames.
  32 ;;   Furthermore, the proc buffer's default dir wasn't initialised
  33 ;;   to the user's buffer's default dir before doing the leading cd.
  34 ;;   This also screwed up relative pathnames if the proc buffer already
  35 ;;   existed and was set to a different default dir. Hopefully we've
  36 ;;   finally got it right. The pwd is now reported in the buffer
  37 ;;   just to let the user know. Bug reported by Piet Van Oostrum.
  38 ;;   Olin 10/19/90
  39 ;; - Fixed up the sentinel to protect match-data around invocations.
  40 ;;   Also slightly rearranged the cd match code for similar reasons.
  41 ;;   Olin 7/16/91
  42 ;; - Dec 29 1995: changed for new stuff (shell-command-switch, second
  43 ;;   arg to shell-command --> BUFFER-NAME arg to background) from
  44 ;;   FSF 19.30.  Ben Wing
  45
  46 ;;; Code:
  47
  48 (provide 'background)
  49 (require 'comint)
  50
  51 (defgroup background nil
  52   "Fun with background jobs"
  53   :group 'processes)
  54
  55
  56 ;; user variables
  57 (defcustom background-show t
  58   "*If non-nil, background jobs' buffers are shown when they're started."
  59   :type 'boolean
  60   :group 'background)
  61 (defcustom background-select nil
  62   "*If non-nil, background jobs' buffers are selected when they're started."
  63   :type 'boolean
  64   :group 'background)
  65
  66 (defcustom background-get-job-name 'background-get-job-name-simple
  67   "Function to use to generate the job name (and therefore the buffer name
  68 of processes run in the background."
  69   :type '(choice
  70            (function-item :tag "Simple Numbered"
  71                           :value background-get-job-name-simple)
  72            (function-item :tag "Command based"
  73                           :value background-get-job-name-command)
  74            (function-item :tag "Command and Directory based"
  75                           :value background-get-job-name-command-n-dir)
  76            )
  77   :group 'background)
  78
  79
  80 (defun background-search-job-space (form)
  81   (let ((job-number 1))
  82     (while (get-process (format form job-number))
  83       (setq job-number (1+ job-number)))
  84     job-number))
  85
  86 (defun background-get-job-name-simple (command dir)
  87   (let* ((form "background-%d")
  88          (job-num (background-search-job-space form)))
  89     (format form job-num)))
  90
  91 (defun format-quote-string (str)
  92   (replace-in-string str "%" "%%"))
  93
  94 (defun get-bottom-dir (str)
  95   (let* ((dasplit (split-string str "\/"))
  96          (dalen (length dasplit)))
  97     (if (= dalen 2)
  98         (elt dasplit (- dalen 1))
  99       (if (= (length (elt dasplit (- dalen 1))) 0)
 100           (elt dasplit (- dalen 2))
 101         (elt dasplit (- dalen 1))))))
 102
 103 (defun background-get-job-name-command (command dir)
 104   (let* ((form (concat (format "BG(%s" (format-quote-string command)) ")%d"))
 105          (job-num (background-search-job-space form)))
 106     (format form job-num)))
 107
 108 (defun background-get-job-name-command-n-dir (command dir)
 109   (let* ((form (concat (format "BG(%s)(%s"
 110                                (format-quote-string (get-bottom-dir dir))
 111                                (format-quote-string command)) ")%d"))
 112          (job-num (background-search-job-space form)))
 113     (format form job-num)))
 114
 115 ;;;###autoload
 116 (defun background (command &optional buffer-name)
 117   "Run COMMAND in the background like csh.
 118 A message is displayed when the job starts and finishes.  The buffer is in
 119 comint mode, so you can send input and signals to the job.  The process object
 120 is returned if anyone cares.  See also comint-mode and the variables
 121 background-show and background-select.
 122
 123 Optional second argument BUFFER-NAME is a buffer to insert the output into.
 124 If omitted, a buffer name is constructed from the command run."
 125   (interactive "s%% ")
 126   (let* ((dir default-directory)
 127          (job-name (if (functionp background-get-job-name)
 128                        (apply background-get-job-name (list command dir))
 129                      (background-get-job-name-simple command dir))))
 130     (or buffer-name
 131         (setq buffer-name (format "*%s*" job-name)))
 132     (if background-select (pop-to-buffer buffer-name)
 133       (if background-show (with-output-to-temp-buffer buffer-name)) ; cute
 134       (set-buffer (get-buffer-create buffer-name)))
 135     (erase-buffer)
 136
 137     (setq default-directory dir) ; Do this first, in case cd is relative path.
 138     (if (string-match "^cd[\t ]+\\([^\t ;]+\\)[\t ]*;[\t ]*" command)
 139         (let ((dir (substring command (match-beginning 1) (match-end 1))))
 140            (setq command (substring command (match-end 0)))
 141            (setq default-directory
 142                  (file-name-as-directory (expand-file-name dir)))))
 143
 144     (insert-before-markers "--- working directory: " default-directory
 145             "\n% " command ?\n)
 146
 147     (let ((proc (get-buffer-process
 148                  (comint-exec buffer-name job-name shell-file-name
 149                               nil (list shell-command-switch command)))))
 150       (comint-mode)
 151       ;; COND because the proc may have died before the G-B-P is called.
 152       (cond (proc (set-process-sentinel proc 'background-sentinel)
 153                   (message "%d" (process-id proc))))
 154       (setq mode-name "Background")
 155       proc)))
 156
 157 (defun background-sentinel (process msg)
 158   "Called when a background job changes state."
 159   (let ((ms (match-data))) ; barf
 160     (unwind-protect
 161          (let ((msg (cond ((string= msg "finished\n") "Done")
 162                           ((string-match "^exited" msg)
 163                            (concat "Exit " (substring msg 28 -1)))
 164                           ((zerop (length msg)) "Continuing")
 165                           (t (concat (upcase (substring msg 0 1))
 166                                      (substring msg 1 -1))))))
 167            (message "[%s] %s %s" (process-name process)
 168                     msg
 169                     (nth 2 (process-command process)))
 170            (if (null (buffer-name (process-buffer process)))
 171                (set-process-buffer process nil) ; WHY? Olin.
 172                (if (memq (process-status process) '(signal exit))
 173                    (save-excursion
 174                      (set-buffer (process-buffer process))
 175                      (let ((at-end (eobp)))
 176                        (save-excursion
 177                          (goto-char (point-max))
 178                          (insert ?\n msg ?
 179                                  (substring (current-time-string) 11 19) ?\n))
 180                        (if at-end (goto-char (point-max))))
 181                      (set-buffer-modified-p nil)))))
 182       (store-match-data ms))))
 183
 184 ;;; background.el ends here