From: Chris Hanson Date: Thu, 20 Nov 1997 05:51:30 +0000 (+0000) Subject: Define process filter to strip carriage-returns from the output of a X-Git-Tag: 20090517-FFI~4926 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=73bd1ab4861816df71147b49f3780591c5e76e15;p=mit-scheme.git Define process filter to strip carriage-returns from the output of a process. Change COMINT-EXEC to start a buffer's process -before- the buffer's major mode is set, so that process filters can be defined in the mode hooks. --- diff --git a/v7/src/edwin/comint.scm b/v7/src/edwin/comint.scm index 89360bcd5..c1cbf7c24 100644 --- a/v7/src/edwin/comint.scm +++ b/v7/src/edwin/comint.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: comint.scm,v 1.24 1997/06/14 01:22:05 cph Exp $ +$Id: comint.scm,v 1.25 1997/11/20 05:51:30 cph Exp $ Copyright (c) 1991-97 Massachusetts Institute of Technology @@ -51,8 +51,8 @@ license should have been included along with this file. |# (or (not process) (not (process-runnable? process)))) (begin - (set-buffer-major-mode! buffer mode) - (comint-exec buffer (buffer-name buffer) program switches))) + (comint-exec buffer (buffer-name buffer) program switches) + (set-buffer-major-mode! buffer mode))) buffer)) (define (comint-exec buffer name program switches) @@ -96,6 +96,25 @@ This is a good thing to set in mode hooks." (define-variable comint-program-name "File name of program that is running in this buffer." false) + +(define (comint-strip-carriage-returns buffer) + (let ((process (get-buffer-process buffer))) + (if process + (add-process-filter process process-filter:strip-carriage-returns)))) + +(define process-filter:strip-carriage-returns + (standard-process-filter + (lambda (mark string start end) + (let ((group (mark-group mark))) + (let loop ((start start)) + (let ((cr + (or (substring-find-next-char string start end #\return) + end)) + (index (mark-index mark))) + (group-insert-substring! group index string start cr) + (set-mark-index! mark (fix:+ index (fix:- cr start))) + (if (not (fix:= cr end)) + (loop (fix:+ cr 1))))))))) (define-major-mode comint fundamental "Comint" "Major mode for interacting with an inferior interpreter. diff --git a/v7/src/edwin/telnet.scm b/v7/src/edwin/telnet.scm index 83b06c4bb..d5dff8080 100644 --- a/v7/src/edwin/telnet.scm +++ b/v7/src/edwin/telnet.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: telnet.scm,v 1.12 1997/11/20 05:27:45 cph Exp $ +$Id: telnet.scm,v 1.13 1997/11/20 05:51:14 cph Exp $ Copyright (c) 1991-97 Massachusetts Institute of Technology @@ -77,31 +77,29 @@ If port number is typed after hostname (separated by a space), use it instead of the default." "sTelnet to host\nP" (lambda (host new-process?) - (let ((buffer - (let ((mode (ref-mode-object telnet)) - (buffer-name - (let ((buffer-name (string-append "*" host "-telnet*"))) - (if (not new-process?) - buffer-name - (new-buffer buffer-name))))) - (if (re-string-match "\\([^ ]+\\) \\([^ ]+\\)" host) - (let ((host - (substring host - (re-match-start-index 1) - (re-match-end-index 1))) - (port - (substring host - (re-match-start-index 2) - (re-match-end-index 2)))) - (if (not (exact-nonnegative-integer? (string->number port))) - (editor-error "Port must be a positive integer: " port)) - (make-comint mode buffer-name "telnet" host port)) - (make-comint mode buffer-name "telnet" host))))) - (let ((process (get-buffer-process buffer))) - (if process - (add-process-filter process - (standard-process-filter telnet-filter)))) - (select-buffer buffer)))) + (select-buffer + (let ((mode (ref-mode-object telnet)) + (buffer-name + (let ((buffer-name (string-append "*" host "-telnet*"))) + (if (not new-process?) + buffer-name + (new-buffer buffer-name))))) + (if (re-string-match "\\([^ ]+\\) \\([^ ]+\\)" host) + (let ((host + (substring host + (re-match-start-index 1) + (re-match-end-index 1))) + (port + (substring host + (re-match-start-index 2) + (re-match-end-index 2)))) + (if (not (exact-nonnegative-integer? (string->number port))) + (editor-error "Port must be a positive integer: " port)) + (make-comint mode buffer-name "telnet" host port)) + (make-comint mode buffer-name "telnet" host)))))) + +(add-event-receiver! (ref-variable telnet-mode-hook) + comint-strip-carriage-returns) (define-command telnet-send-input "Send input to telnet process. @@ -126,70 +124,4 @@ With prefix arg, the character is repeated that many times." (cond ((= argument 1) (process-send-char process char)) ((> argument 1) - (process-send-string process (make-string argument char))))))) - -(define (telnet-filter mark string start end) - (let ((index (mark-index mark)) - (new-string (telnet-filter-substring string start end))) - (let ((new-length (string-length new-string))) - (group-insert-substring! (mark-group mark) index new-string 0 new-length) - (set-mark-index! mark (+ index new-length))))) - -(define (telnet-filter-substring string start end) - (substring-substitute string start end - (ref-variable telnet-replacee) - (ref-variable telnet-replacement))) - -(define-variable telnet-replacee - "String to replace in telnet output." - (string #\return)) - -(define-variable telnet-replacement - "String to use as replacement in telnet output." - "") - -(define (substring-substitute string start end source target) - (let ((length (fix:- end start)) - (slength (string-length source)) - (tlength (string-length target))) - (let ((alloc-length - (fix:+ length - (fix:* (fix:quotient length slength) - tlength))) - (char (string-ref source 0))) - (let ((result (string-allocate alloc-length))) - - (define (loop copy-index read-index write-index) - (if (fix:>= read-index end) - (done copy-index write-index) - (let ((index - (substring-find-next-char string read-index end char))) - (cond ((not index) - (done copy-index write-index)) - ((or (fix:= slength 1) - (substring-prefix? source 0 slength - string index end)) - (substring-move-right! string copy-index index - result write-index) - (let ((next-write - (fix:+ write-index (fix:- index copy-index))) - (next-read (fix:+ index slength))) - (if (not (fix:= tlength 0)) - (substring-move-right! target 0 tlength - result next-write)) - (loop next-read - next-read - (fix:+ next-write tlength)))) - (else - (loop copy-index (fix:+ index 1) write-index)))))) - - (define (done copy-index write-index) - (if (fix:< copy-index end) - (substring-move-right! string copy-index end - result write-index)) - (set-string-length! result - (fix:+ write-index - (fix:- end copy-index))) - result) - - (loop start start 0))))) \ No newline at end of file + (process-send-string process (make-string argument char))))))) \ No newline at end of file