/[cmucl]/src/hemlock/shell.lisp
ViewVC logotype

Contents of /src/hemlock/shell.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.5 - (show annotations)
Mon May 4 01:27:20 1998 UTC (15 years, 11 months ago) by dtc
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, double-double-array-base, post-merge-intl-branch, release-19b-pre1, release-19b-pre2, merged-unicode-utf16-extfmt-2009-06-11, double-double-init-sparc-2, unicode-utf16-extfmt-2009-03-27, double-double-base, snapshot-2007-09, snapshot-2007-08, snapshot-2008-08, snapshot-2008-09, ppc_gencgc_snap_2006-01-06, sse2-packed-2008-11-12, snapshot-2008-05, snapshot-2008-06, snapshot-2008-07, snapshot-2007-05, snapshot-2008-01, snapshot-2008-02, snapshot-2008-03, intl-branch-working-2010-02-19-1000, snapshot-2006-11, snapshot-2006-10, double-double-init-sparc, snapshot-2006-12, unicode-string-buffer-impl-base, sse2-base, release-20b-pre1, release-20b-pre2, unicode-string-buffer-base, sse2-packed-base, sparc-tramp-assem-2010-07-19, amd64-dd-start, snapshot-2003-10, snapshot-2004-10, release-18e-base, release-19f-pre1, snapshot-2008-12, snapshot-2008-11, intl-2-branch-base, snapshot-2004-08, snapshot-2004-09, remove_negative_zero_not_zero, snapshot-2007-01, snapshot-2007-02, snapshot-2004-05, snapshot-2004-06, snapshot-2004-07, release-19e, release-19d, GIT-CONVERSION, double-double-init-ppc, release-19c, dynamic-extent-base, unicode-utf16-sync-2008-12, LINKAGE_TABLE, release-19c-base, cross-sol-x86-merged, label-2009-03-16, release-19f-base, PRE_LINKAGE_TABLE, merge-sse2-packed, mod-arith-base, sparc_gencgc_merge, merge-with-19f, snapshot-2004-12, snapshot-2004-11, intl-branch-working-2010-02-11-1000, unicode-snapshot-2009-05, unicode-snapshot-2009-06, amd64-merge-start, ppc_gencgc_snap_2005-12-17, double-double-init-%make-sparc, unicode-utf16-sync-2008-07, release-18e-pre2, unicode-utf16-sync-2008-09, unicode-utf16-extfmts-sync-2008-12, prm-before-macosx-merge-tag, cold-pcl-base, RELEASE_20b, snapshot-2008-04, snapshot-2003-11, snapshot-2005-07, unicode-utf16-sync-label-2009-03-16, RELEASE_19f, snapshot-2007-03, release-20a-base, cross-sol-x86-base, unicode-utf16-char-support-2009-03-26, unicode-utf16-char-support-2009-03-25, release-19a-base, unicode-utf16-extfmts-pre-sync-2008-11, snapshot-2008-10, sparc_gencgc, snapshot-2007-04, snapshot-2010-12, snapshot-2010-11, unicode-utf16-sync-2008-11, snapshot-2007-07, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2007-06, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2003-12, release-19a-pre1, release-19a-pre3, release-19a-pre2, pre-merge-intl-branch, release-19a, UNICODE-BASE, double-double-array-checkpoint, double-double-reader-checkpoint-1, release-19d-base, release-19e-pre1, double-double-irrat-end, release-19e-pre2, snapshot-2010-05, snapshot-2010-04, snapshot-2010-07, snapshot-2010-06, snapshot-2010-01, snapshot-2010-03, snapshot-2010-02, release-19d-pre2, release-19d-pre1, snapshot-2010-08, release-18e, double-double-init-checkpoint-1, double-double-reader-base, label-2009-03-25, snapshot-2005-03, release-19b-base, cross-sol-x86-2010-12-20, double-double-init-x86, sse2-checkpoint-2008-10-01, intl-branch-2010-03-18-1300, snapshot-2005-11, double-double-sparc-checkpoint-1, snapshot-2004-04, sse2-merge-with-2008-11, sse2-merge-with-2008-10, snapshot-2005-10, RELEASE_20a, snapshot-2005-12, release-20a-pre1, snapshot-2005-01, snapshot-2009-11, snapshot-2009-12, unicode-utf16-extfmt-2009-06-11, portable-clx-import-2009-06-16, unicode-utf16-string-support, release-19c-pre1, cross-sparc-branch-base, release-19e-base, intl-branch-base, double-double-irrat-start, snapshot-2005-06, snapshot-2005-05, snapshot-2005-04, ppc_gencgc_snap_2005-05-14, snapshot-2005-02, unicode-utf16-base, portable-clx-base, snapshot-2005-09, snapshot-2005-08, lisp-executable-base, snapshot-2009-08, snapshot-2007-12, snapshot-2007-10, snapshot-2007-11, snapshot-2009-02, snapshot-2009-01, snapshot-2009-07, snapshot-2009-05, snapshot-2009-04, snapshot-2006-02, snapshot-2006-03, release-18e-pre1, snapshot-2006-01, snapshot-2006-06, snapshot-2006-07, snapshot-2006-04, snapshot-2006-05, pre-telent-clx, snapshot-2006-08, snapshot-2006-09, HEAD
Branch point for: release-19b-branch, double-double-reader-branch, double-double-array-branch, mod-arith-branch, RELEASE-19F-BRANCH, portable-clx-branch, sparc_gencgc_branch, cross-sparc-branch, RELEASE-20B-BRANCH, unicode-string-buffer-branch, sparc-tramp-assem-branch, dynamic-extent, UNICODE-BRANCH, release-19d-branch, ppc_gencgc_branch, sse2-packed-branch, lisp-executable, RELEASE-20A-BRANCH, amd64-dd-branch, double-double-branch, unicode-string-buffer-impl-branch, intl-branch, release-18e-branch, cold-pcl, unicode-utf16-branch, cross-sol-x86-branch, release-19e-branch, sse2-branch, release-19a-branch, release-19c-branch, intl-2-branch, unicode-utf16-extfmt-branch
Changes since 1.4: +2 -2 lines
Gray streams support:
* Rename the 'stream structure class to sys:lisp-stream.
* Add a new none hierarchical 'stream built-in class which inherits
  from: instance, t.
* Hack in the new stream class as a mixin for the structure base
  lisp-stream class which now inherits from: stream, structure-object,
  instance, t.
* Add a new 'fundamental-stream standard-class which includes 'stream
  as a mixin, and add PCL hacks to allow this to be redefined after PCL is
  loaded to be (defclass fundamental-stream (standard-object stream) ...).
* Add appropriate support to the base stream functions to dispatch to
  the Gray stream functions for the handling of fundamental-streams.
  Some of the lisp-streams encapsulating CLOS streams still need
  a little work.
1 ;;; -*- Log: hemlock.log; Package: Hemlock -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;;
7 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/hemlock/shell.lisp,v 1.5 1998/05/04 01:27:20 dtc Rel $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; Hemlock command level support for processes.
13 ;;;
14 ;;; Written by Blaine Burks.
15 ;;;
16
17 (in-package "HEMLOCK")
18
19
20 (defun setup-process-buffer (buffer)
21 (let ((mark (copy-mark (buffer-point buffer) :right-inserting)))
22 (defhvar "Buffer Input Mark"
23 "The buffer input mark for this buffer."
24 :buffer buffer
25 :value mark)
26 (defhvar "Process Output Stream"
27 "The process structure for this buffer."
28 :buffer buffer
29 :value (make-hemlock-output-stream mark :full))
30 (defhvar "Interactive History"
31 "A ring of the regions input to an interactive mode (Eval or Typescript)."
32 :buffer buffer
33 :value (make-ring (value interactive-history-length)))
34 (defhvar "Interactive Pointer"
35 "Pointer into \"Interactive History\"."
36 :buffer buffer
37 :value 0)
38 (defhvar "Searching Interactive Pointer"
39 "Pointer into \"Interactive History\"."
40 :buffer buffer
41 :value 0)
42 (unless (buffer-modeline-field-p buffer :process-status)
43 (setf (buffer-modeline-fields buffer)
44 (nconc (buffer-modeline-fields buffer)
45 (list (modeline-field :process-status)))))))
46
47 (defmode "Process" :major-p nil :setup-function #'setup-process-buffer)
48
49
50
51 ;;;; Shell-filter streams.
52
53 ;;; We use shell-filter-streams to capture text going from the shell process to
54 ;;; a Hemlock output stream. They pass character and misc operations through
55 ;;; to the attached hemlock-output-stream. The string output function scans
56 ;;; the string for ^A_____^B, denoting a change of directory.
57 ;;;
58 ;;; The following aliases in a .cshrc file are required for using filename
59 ;;; completion:
60 ;;; alias cd 'cd \!* ; echo ""`pwd`"/"'
61 ;;; alias popd 'popd \!* ; echo ""`pwd`"/"'
62 ;;; alias pushd 'pushd \!* ; echo ""`pwd`"/"'
63 ;;;
64
65 (defstruct (shell-filter-stream
66 (:include sys:lisp-stream
67 (:out #'shell-filter-out)
68 (:sout #'shell-filter-string-out)
69 (:misc #'shell-filter-output-misc))
70 (:print-function print-shell-filter-stream)
71 (:constructor
72 make-shell-filter-stream (buffer hemlock-stream)))
73 ;; The buffer where output will be going
74 buffer
75 ;; The Hemlock stream to which output will be directed
76 hemlock-stream)
77
78
79 ;;; PRINT-SHELL-FILTER-STREAM -- Internal
80 ;;;
81 ;;; Function for printing a shell-filter-stream.
82 ;;;
83 (defun print-shell-filter-stream (s stream d)
84 (declare (ignore d s))
85 (write-string "#<Shell filter stream>" stream))
86
87
88 ;;; SHELL-FILTER-OUT -- Internal
89 ;;;
90 ;;; This is the character-out handler for the shell-filter-stream.
91 ;;; It writes the character it is given to the underlying
92 ;;; hemlock-output-stream.
93 ;;;
94 (defun shell-filter-out (stream character)
95 (write-char character (shell-filter-stream-hemlock-stream stream)))
96
97
98 ;;; SHELL-FILTER-OUTPUT-MISC -- Internal
99 ;;;
100 ;;; This will also simply pass the output request on the the
101 ;;; attached hemlock-output-stream.
102 ;;;
103 (defun shell-filter-output-misc (stream operation &optional arg1 arg2)
104 (let ((hemlock-stream (shell-filter-stream-hemlock-stream stream)))
105 (funcall (hi::hemlock-output-stream-misc hemlock-stream)
106 hemlock-stream operation arg1 arg2)))
107
108
109 ;;; CATCH-CD-STRING -- Internal
110 ;;;
111 ;;; Scans String for the sequence ^A...^B. Returns as multiple values
112 ;;; the breaks in the string. If the second start/end pair is nil, there
113 ;;; was no cd sequence.
114 ;;;
115 (defun catch-cd-string (string start end)
116 (declare (simple-string string))
117 (let ((cd-start (position (code-char 1) string :start start :end end)))
118 (if cd-start
119 (let ((cd-end (position (code-char 2) string :start cd-start :end end)))
120 (if cd-end
121 (values start cd-start cd-end end)
122 (values start end nil nil)))
123 (values start end nil nil))))
124
125 ;;; SHELL-FILTER-STRING-OUT -- Internal
126 ;;;
127 ;;; The string output function for shell-filter-stream's.
128 ;;; Any string containing a ^A...^B is caught and assumed to be
129 ;;; the path-name of the new current working directory. This is
130 ;;; removed from the orginal string and the result is passed along
131 ;;; to the Hemlock stream.
132 ;;;
133 (defun shell-filter-string-out (stream string start end)
134 (declare (simple-string string))
135 (let ((hemlock-stream (shell-filter-stream-hemlock-stream stream))
136 (buffer (shell-filter-stream-buffer stream)))
137
138 (multiple-value-bind (start1 end1 start2 end2)
139 (catch-cd-string string start end)
140 (write-string string hemlock-stream :start start1 :end end1)
141 (when start2
142 (write-string string hemlock-stream :start (+ 2 start2) :end end2)
143 (let ((cd-string (subseq string (1+ end1) start2)))
144 (setf (variable-value 'current-working-directory :buffer buffer)
145 (pathname cd-string)))))))
146
147
148 ;;; FILTER-TILDES -- Internal
149 ;;;
150 ;;; Since COMPLETE-FILE does not seem to deal with ~'s in the filename
151 ;;; this function expands them to a full path name.
152 ;;;
153 (defun filter-tildes (name)
154 (declare (simple-string name))
155 (if (char= (schar name 0) #\~)
156 (concatenate 'simple-string
157 (if (or (= (length name) 1)
158 (char= (schar name 1) #\/))
159 (cdr (assoc :home *environment-list*))
160 "/usr/")
161 (subseq name 1))
162 name))
163
164
165
166 ;;;; Support for handling input before the prompt in process buffers.
167
168 (defun unwedge-process-buffer ()
169 (buffer-end (current-point))
170 (deliver-signal-to-process :SIGINT (value process))
171 (editor-error "Aborted."))
172
173 (defhvar "Unwedge Interactive Input Fun"
174 "Function to call when input is confirmed, but the point is not past the
175 input mark."
176 :value #'unwedge-process-buffer
177 :mode "Process")
178
179 (defhvar "Unwedge Interactive Input String"
180 "String to add to \"Point not past input mark. \" explaining what will
181 happen if the the user chooses to be unwedged."
182 :value "Interrupt and throw to end of buffer?"
183 :mode "Process")
184
185
186
187 ;;;; Some Global Variables.
188
189 (defhvar "Current Shell"
190 "The shell to which \"Select Shell\" goes."
191 :value nil)
192
193 (defhvar "Ask about Old Shells"
194 "When set (the default), Hemlock prompts for an existing shell buffer in
195 preference to making a new one when there is no \"Current Shell\"."
196 :value t)
197
198 (defhvar "Kill Process Confirm"
199 "When set, Hemlock prompts for confirmation before killing a buffer's process."
200 :value t)
201
202 (defhvar "Shell Utility"
203 "The \"Shell\" command uses this as the default command line."
204 :value "/bin/csh")
205
206 (defhvar "Shell Utility Switches"
207 "This is a string containing the default command line arguments to the
208 utility in \"Shell Utility\". This is a string since the utility is
209 typically \"/bin/csh\", and this string can contain I/O redirection and
210 other shell directives."
211 :value "")
212
213
214
215 ;;;; The Shell, New Shell, and Set Current Shell Commands.
216
217 (defvar *shell-names* (make-string-table)
218 "A string-table of the string-name of all process buffers and corresponding
219 buffer structures.")
220
221 (defcommand "Set Current Shell" (p)
222 "Sets the value of \"Current Shell\", which the \"Shell\" command uses."
223 "Sets the value of \"Current Shell\", which the \"Shell\" command uses."
224 (declare (ignore p))
225 (set-current-shell))
226
227 ;;; SET-CURRENT-SHELL -- Internal.
228 ;;;
229 ;;; This prompts for a known shell buffer to which it sets "Current Shell".
230 ;;; It signals an error if there are none.
231 ;;;
232 (defun set-current-shell ()
233 (let ((old-buffer (value current-shell))
234 (first-old-shell (do-strings (var val *shell-names* nil)
235 (declare (ignore val))
236 (return var))))
237 (when (and (not old-buffer) (not first-old-shell))
238 (editor-error "Nothing to set current shell to."))
239 (let ((default-shell (if old-buffer
240 (buffer-name old-buffer)
241 first-old-shell)))
242 (multiple-value-bind
243 (new-buffer-name new-buffer)
244 (prompt-for-keyword (list *shell-names*)
245 :must-exist t
246 :default default-shell
247 :default-string default-shell
248 :prompt "Existing Shell: "
249 :help "Enter the name of an existing shell.")
250 (declare (ignore new-buffer-name))
251 (setf (value current-shell) new-buffer)))))
252
253 (defcommand "Shell" (p)
254 "This spawns a shell in a buffer. If there already is a \"Current Shell\",
255 this goes to that buffer. If there is no \"Current Shell\", there are
256 shell buffers, and \"Ask about Old Shells\" is set, this prompts for one
257 of them, setting \"Current Shell\" to that shell. Supplying an argument
258 forces the creation of a new shell buffer."
259 "This spawns a shell in a buffer. If there already is a \"Current Shell\",
260 this goes to that buffer. If there is no \"Current Shell\", there are
261 shell buffers, and \"Ask about Old Shells\" is set, this prompts for one
262 of them, setting \"Current Shell\" to that shell. Supplying an argument
263 forces the creation of a new shell buffer."
264 (let ((shell (value current-shell))
265 (no-shells-p (do-strings (var val *shell-names* t)
266 (declare (ignore var val))
267 (return nil))))
268 (cond (p (make-new-shell nil no-shells-p))
269 (shell (change-to-buffer shell))
270 ((and (value ask-about-old-shells) (not no-shells-p))
271 (set-current-shell)
272 (change-to-buffer (value current-shell)))
273 (t (make-new-shell nil)))))
274
275 (defcommand "Shell Command Line in Buffer" (p)
276 "Prompts the user for a process and a buffer in which to run the process."
277 "Prompts the user for a process and a buffer in which to run the process."
278 (declare (ignore p))
279 (make-new-shell t))
280
281 ;;; MAKE-NEW-SHELL -- Internal.
282 ;;;
283 ;;; This makes new shells for us dealing with prompting for various things and
284 ;;; setting "Current Shell" according to user documentation.
285 ;;;
286 (defun make-new-shell (prompt-for-command-p &optional (set-current-shell-p t)
287 (command-line (get-command-line) clp))
288 (let* ((command (or (and clp command-line)
289 (if prompt-for-command-p
290 (prompt-for-string
291 :default command-line :trim t
292 :prompt "Command to execute: "
293 :help "Shell command line to execute.")
294 command-line)))
295 (buffer-name (if prompt-for-command-p
296 (prompt-for-string
297 :default
298 (concatenate 'simple-string command " process")
299 :trim t
300 :prompt `("Buffer in which to execute ~A? "
301 ,command)
302 :help "Where output from this process will appear.")
303 (new-shell-name)))
304 (temp (make-buffer
305 buffer-name
306 :modes '("Fundamental" "Process")
307 :delete-hook
308 (list #'(lambda (buffer)
309 (when (eq (value current-shell) buffer)
310 (setf (value current-shell) nil))
311 (delete-string (buffer-name buffer) *shell-names*)
312 (kill-process (variable-value 'process
313 :buffer buffer))))))
314 (buffer (or temp (getstring buffer-name *buffer-names*)))
315 (stream (variable-value 'process-output-stream :buffer buffer))
316 (output-stream
317 ;; If we re-used an old shell buffer, this isn't necessary.
318 (if (hemlock-output-stream-p stream)
319 (setf (variable-value 'process-output-stream :buffer buffer)
320 (make-shell-filter-stream buffer stream))
321 stream)))
322 (buffer-end (buffer-point buffer))
323 (defhvar "Process"
324 "The process for Shell and Process buffers."
325 :buffer buffer
326 :value (ext::run-program "/bin/sh" (list "-c" command)
327 :wait nil
328 :pty output-stream
329 :env (frob-environment-list
330 (car (buffer-windows buffer)))
331 :status-hook #'(lambda (process)
332 (declare (ignore process))
333 (update-process-buffer buffer))
334 :input t :output t))
335 (defhvar "Current Working Directory"
336 "The pathname of the current working directory for this buffer."
337 :buffer buffer
338 :value (default-directory))
339 (setf (getstring buffer-name *shell-names*) buffer)
340 (update-process-buffer buffer)
341 (when (and (not (value current-shell)) set-current-shell-p)
342 (setf (value current-shell) buffer))
343 (change-to-buffer buffer)))
344
345 ;;; GET-COMMAND-LINE -- Internal.
346 ;;;
347 ;;; This just conses up a string to feed to the shell.
348 ;;;
349 (defun get-command-line ()
350 (concatenate 'simple-string (value shell-utility) " "
351 (value shell-utility-switches)))
352
353 ;;; FROB-ENVIRONMENT-LIST -- Internal.
354 ;;;
355 ;;; This sets some environment variables so the shell will be in the proper
356 ;;; state when it comes up.
357 ;;;
358 (defun frob-environment-list (window)
359 (list* (cons :termcap (concatenate 'simple-string
360 "emacs:co#"
361 (if window
362 (lisp::quick-integer-to-string
363 (window-width window))
364 "")
365 ":tc=unkown:"))
366 (cons :emacs "t") (cons :term "emacs")
367 (remove-if #'(lambda (keyword)
368 (member keyword '(:termcap :emacs :term)
369 :test #'(lambda (cons keyword)
370 (eql (car cons) keyword))))
371 ext:*environment-list*)))
372
373 ;;; NEW-SHELL-NAME -- Internal.
374 ;;;
375 ;;; This returns a unique buffer name for a shell by incrementing the value of
376 ;;; *process-number* until "Process <*process-number*> is not already the name
377 ;;; of a buffer. Perhaps this is being overly cautious, but I've seen some
378 ;;; really stupid users.
379 ;;;
380 (defvar *process-number* 0)
381 ;;;
382 (defun new-shell-name ()
383 (loop
384 (let ((buffer-name (format nil "Shell ~D" (incf *process-number*))))
385 (unless (getstring buffer-name *buffer-names*) (return buffer-name)))))
386
387
388 ;;;; Modeline support.
389
390 (defun modeline-process-status (buffer window)
391 (declare (ignore window))
392 (when (hemlock-bound-p 'process :buffer buffer)
393 (let ((process (variable-value 'process :buffer buffer)))
394 (ecase (ext:process-status process)
395 (:running "running")
396 (:stopped "stopped")
397 (:signaled "killed by signal ~D" (unix:unix-signal-name
398 (ext:process-exit-code process)))
399 (:exited (format nil "exited with status ~D"
400 (ext:process-exit-code process)))))))
401
402
403 (make-modeline-field :name :process-status
404 :function #'modeline-process-status)
405
406 (defun update-process-buffer (buffer)
407 (when (buffer-modeline-field-p buffer :process-status)
408 (dolist (window (buffer-windows buffer))
409 (update-modeline-field buffer window :process-status)))
410 (let ((process (variable-value 'process :buffer buffer)))
411 (unless (ext:process-alive-p process)
412 (ext:process-close process)
413 (when (eq (value current-shell) buffer)
414 (setf (value current-shell) nil)))))
415
416
417 ;;;; Supporting Commands.
418
419 (defcommand "Confirm Process Input" (p)
420 "Evaluate Process Mode input between the point and last prompt."
421 "Evaluate Process Mode input between the point and last prompt."
422 (declare (ignore p))
423 (unless (hemlock-bound-p 'process :buffer (current-buffer))
424 (editor-error "Not in a process buffer."))
425 (let* ((process (value process))
426 (stream (ext:process-pty process)))
427 (case (ext:process-status process)
428 (:running)
429 (:stopped (editor-error "The process has been stopped."))
430 (t (editor-error "The process is dead.")))
431 (let ((input-region (get-interactive-input)))
432 (write-line (region-to-string input-region) stream)
433 (force-output (ext:process-pty process))
434 (insert-character (current-point) #\newline)
435 ;; Move "Buffer Input Mark" to end of buffer.
436 (move-mark (region-start input-region) (region-end input-region)))))
437
438 (defcommand "Shell Complete Filename" (p)
439 "Attempts to complete the filename immediately preceding the point.
440 It will beep if the result of completion is not unique."
441 "Attempts to complete the filename immediately preceding the point.
442 It will beep if the result of completion is not unique."
443 (declare (ignore p))
444 (unless (hemlock-bound-p 'current-working-directory)
445 (editor-error "Shell filename completion only works in shells."))
446 (let ((point (current-point)))
447 (with-mark ((start point))
448 (pre-command-parse-check start)
449 (unless (form-offset start -1) (editor-error "Can't grab filename."))
450 (when (member (next-character start) '(#\" #\' #\< #\>))
451 (mark-after start))
452 (let* ((name-region (region start point))
453 (fragment (filter-tildes (region-to-string name-region)))
454 (dir (default-directory))
455 (shell-dir (value current-working-directory)))
456 (multiple-value-bind (filename unique)
457 (unwind-protect
458 (progn
459 (setf (default-directory) shell-dir)
460 (complete-file fragment :defaults shell-dir))
461 (setf (default-directory) dir))
462 (cond (filename
463 (delete-region name-region)
464 (insert-string point (namestring filename))
465 (when (not unique)
466 (editor-error)))
467 (t (editor-error "No such file exists."))))))))
468
469 (defcommand "Kill Main Process" (p)
470 "Kills the process in the current buffer."
471 "Kills the process in the current buffer."
472 (declare (ignore p))
473 (unless (hemlock-bound-p 'process :buffer (current-buffer))
474 (editor-error "Not in a process buffer."))
475 (when (or (not (value kill-process-confirm))
476 (prompt-for-y-or-n :default nil
477 :prompt "Really blow away shell? "
478 :default nil
479 :default-string "no"))
480 (kill-process (value process))))
481
482 (defcommand "Stop Main Process" (p)
483 "Stops the process in the current buffer. With an argument use :SIGSTOP
484 instead of :SIGTSTP."
485 "Stops the process in the current buffer. With an argument use :SIGSTOP
486 instead of :SIGTSTP."
487 (unless (hemlock-bound-p 'process :buffer (current-buffer))
488 (editor-error "Not in a process buffer."))
489 (deliver-signal-to-process (if p :SIGSTOP :SIGTSTP) (value process)))
490
491 (defcommand "Continue Main Process" (p)
492 "Continues the process in the current buffer."
493 "Continues the process in the current buffer."
494 (declare (ignore p))
495 (unless (hemlock-bound-p 'process :buffer (current-buffer))
496 (editor-error "Not in a process buffer."))
497 (deliver-signal-to-process :SIGCONT (value process)))
498
499 (defun kill-process (process)
500 "Self-explanatory."
501 (deliver-signal-to-process :SIGKILL process))
502
503 (defun deliver-signal-to-process (signal process)
504 "Delivers a signal to a process."
505 (ext:process-kill process signal :process-group))
506
507 (defcommand "Send EOF to Process" (p)
508 "Sends a Ctrl-D to the process in the current buffer."
509 "Sends a Ctrl-D to the process in the current buffer."
510 (declare (ignore p))
511 (unless (hemlock-bound-p 'process :buffer (current-buffer))
512 (editor-error "Not in a process buffer."))
513 (let ((stream (ext:process-pty (value process))))
514 (write-char (code-char 4) stream)
515 (force-output stream)))
516
517 (defcommand "Interrupt Buffer Subprocess" (p)
518 "Stop the subprocess currently executing in this shell."
519 "Stop the subprocess currently executing in this shell."
520 (declare (ignore p))
521 (unless (hemlock-bound-p 'process :buffer (current-buffer))
522 (editor-error "Not in a process buffer."))
523 (buffer-end (current-point))
524 (buffer-end (value buffer-input-mark))
525 (deliver-signal-to-subprocess :SIGINT (value process)))
526
527 (defcommand "Kill Buffer Subprocess" (p)
528 "Kill the subprocess currently executing in this shell."
529 "Kill the subprocess currently executing in this shell."
530 (declare (ignore p))
531 (unless (hemlock-bound-p 'process :buffer (current-buffer))
532 (editor-error "Not in a process buffer."))
533 (deliver-signal-to-subprocess :SIGKILL (value process)))
534
535 (defcommand "Quit Buffer Subprocess" (p)
536 "Quit the subprocess currently executing int his shell."
537 "Quit the subprocess currently executing int his shell."
538 (declare (ignore p))
539 (unless (hemlock-bound-p 'process :buffer (current-buffer))
540 (editor-error "Not in a process buffer."))
541 (deliver-signal-to-subprocess :SIGQUIT (value process)))
542
543 (defcommand "Stop Buffer Subprocess" (p)
544 "Stop the subprocess currently executing in this shell."
545 "Stop the subprocess currently executing in this shell."
546 (unless (hemlock-bound-p 'process :buffer (current-buffer))
547 (editor-error "Not in a process buffer."))
548 (deliver-signal-to-subprocess (if p :SIGSTOP :SIGTSTP) (value process)))
549
550 (defun deliver-signal-to-subprocess (signal process)
551 "Delivers a signal to a subprocess of a shell."
552 (ext:process-kill process signal :pty-process-group))

  ViewVC Help
Powered by ViewVC 1.1.5