~ chicken-core (chicken-5) /port.scm

  1;;; port.scm - Optional non-standard ports
  2;
  3; Copyright (c) 2008-2022, The CHICKEN Team
  4; Copyright (c) 2000-2007, Felix L. Winkelmann
  5; All rights reserved.
  6;
  7; Redistribution and use in source and binary forms, with or without
  8; modification, are permitted provided that the following conditions
  9; are met:
 10;
 11;   Redistributions of source code must retain the above copyright
 12;   notice, this list of conditions and the following disclaimer.
 13;   Redistributions in binary form must reproduce the above copyright
 14;   notice, this list of conditions and the following disclaimer in
 15;   the documentation and/or other materials provided with the
 16;   distribution.
 17;   Neither the name of the author nor the names of its contributors
 18;   may be used to endorse or promote products derived from this
 19;   software without specific prior written permission.
 20;
 21; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
 22; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
 23; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
 24; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
 25; COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
 26; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
 27; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
 28; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
 29; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
 30; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
 31; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
 32; OF THE POSSIBILITY OF SUCH DAMAGE.
 33
 34
 35(declare
 36  (unit port)
 37  (uses extras))
 38
 39(module chicken.port
 40  (call-with-input-string
 41   call-with-output-string
 42   copy-port
 43   make-input-port
 44   make-output-port
 45   port-fold
 46   port-for-each
 47   port-map
 48   port-name
 49   port-position
 50   make-bidirectional-port
 51   make-broadcast-port
 52   make-concatenated-port
 53   set-buffering-mode!
 54   set-port-name!
 55   terminal-name
 56   terminal-port?
 57   terminal-size
 58   with-error-output-to-port
 59   with-input-from-port
 60   with-input-from-string
 61   with-output-to-port
 62   with-output-to-string
 63   with-error-output-to-string)
 64
 65(import scheme
 66	chicken.base
 67	chicken.fixnum
 68	chicken.foreign
 69	chicken.io)
 70
 71(include "common-declarations.scm")
 72
 73#>
 74
 75#if !defined(_WIN32)
 76# include <sys/ioctl.h>
 77# include <termios.h>
 78#endif
 79
 80#if !defined(__ANDROID__) && defined(TIOCGWINSZ)
 81static int get_tty_size(int fd, int *rows, int *cols)
 82{
 83  struct winsize tty_size;
 84  int r;
 85
 86  memset(&tty_size, 0, sizeof tty_size);
 87
 88  r = ioctl(fd, TIOCGWINSZ, &tty_size);
 89  if (r == 0) {
 90     *rows = tty_size.ws_row;
 91     *cols = tty_size.ws_col;
 92  }
 93  return r;
 94}
 95#else
 96static int get_tty_size(int fd, int *rows, int *cols)
 97{
 98  *rows = *cols = 0;
 99  errno = ENOSYS;
100  return -1;
101}
102#endif
103
104#if defined(_WIN32) && !defined(__CYGWIN__)
105char *ttyname(int fd) {
106  errno = ENOSYS;
107  return NULL;
108}
109#endif
110
111<#
112
113
114(define-foreign-variable _iofbf int "_IOFBF")
115(define-foreign-variable _iolbf int "_IOLBF")
116(define-foreign-variable _ionbf int "_IONBF")
117(define-foreign-variable _bufsiz int "BUFSIZ")
118
119(define (port-name #!optional (port ##sys#standard-input))
120  (##sys#check-port port 'port-name)
121  (##sys#slot port 3))
122
123(define (set-port-name! port name)
124  (##sys#check-port port 'set-port-name!)
125  (##sys#check-string name 'set-port-name!)
126  (##sys#setslot port 3 name))
127
128(define (port-position #!optional (port ##sys#standard-input))
129  (##sys#check-port port 'port-position)
130  (if (##core#inline "C_input_portp" port)
131      (##sys#values (##sys#slot port 4) (##sys#slot port 5))
132      (##sys#error 'port-position "cannot compute position of port" port)))
133
134(define (set-buffering-mode! port mode . size)
135  (##sys#check-port port 'set-buffering-mode!)
136  (let ((size (if (pair? size) (car size) _bufsiz))
137	(mode (case mode
138		((#:full) _iofbf)
139		((#:line) _iolbf)
140		((#:none) _ionbf)
141		(else (##sys#error 'set-buffering-mode! "invalid buffering-mode" mode port)))))
142    (##sys#check-fixnum size 'set-buffering-mode!)
143    (when (fx< (if (eq? 'stream (##sys#slot port 7))
144		   ((foreign-lambda* int ((scheme-object p) (int m) (int s))
145		     "C_return(setvbuf(C_port_file(p), NULL, m, s));")
146		    port mode size)
147		   -1)
148	       0)
149      (##sys#error 'set-buffering-mode! "cannot set buffering mode" port mode size))))
150
151;;;; Port-mapping (found in Gauche):
152
153(define (port-for-each fn thunk)
154  (let loop ()
155    (let ((x (thunk)))
156      (unless (eof-object? x)
157	(fn x)
158	(loop) ) ) ) )
159
160(define port-map
161  (lambda (fn thunk)
162    (let loop ((xs '()))
163      (let ((x (thunk)))
164	(if (eof-object? x)
165	    (##sys#fast-reverse xs)
166	    (loop (cons (fn x) xs)))))))
167
168(define (port-fold fn acc thunk)
169  (let loop ((acc acc))
170    (let ((x (thunk)))
171      (if (eof-object? x)
172          acc
173          (loop (fn x acc))) ) ) )
174
175(define-constant +buf-size+ 1024)
176
177(define copy-port 
178  (let ((read-char read-char)
179	(write-char write-char))
180    (define (read-buf port writer)
181      (let ((buf (make-string +buf-size+)))
182	(let loop ()
183	  (let ((n (read-string! +buf-size+ buf port)))
184	    (unless (eq? n 0)
185	      (writer buf n)
186	      (loop))))))
187    (define (write-buf buf n port writer)
188      (do ((i 0 (fx+ i 1)))
189	  ((fx>= i n))
190	(writer (integer->char (##sys#byte buf i)) port)))
191    (define (read-and-write reader writer)
192      (let loop ()
193	(let ((x (reader)))
194	  (unless (eof-object? x)
195	    (writer x)
196	    (loop)))))
197    (define (read-and-write-buf src dest reader)
198      (let ((buf (make-string +buf-size+)))
199	(let loop ((n 0))
200	  (when (fx>= n +buf-size+)
201	    (write-string buf +buf-size+ dest)
202	    (set! n 0))
203	  (let ((c (reader src)))
204	    (cond ((eof-object? c)
205		   (when (fx>= n 0)
206		     (write-string buf n dest)))
207		  (else
208		   (##sys#setbyte buf n (char->integer c))
209		   (loop (fx+ n 1))))))))
210    (lambda (src dest #!optional (read read-char) (write write-char))
211      ;; does not check port args intentionally
212      (cond ((eq? read read-char)
213	     (read-buf
214	      src
215	      (if (eq? write write-char)
216		  (lambda (buf n) (write-string buf n dest))
217		  (lambda (buf n) (write-buf buf n dest write)))))
218	    ((eq? write write-char)
219	     (read-and-write-buf src dest read))
220	    (else
221	     (read-and-write 
222	      (lambda () (read src))
223	      (lambda (x) (write x dest))))))))
224
225
226;;;; funky-ports
227
228(define (make-broadcast-port . ports)
229  (make-output-port
230   (lambda (s) (for-each (cut write-string s #f <>) ports))
231   void
232   (lambda () (for-each flush-output ports)) ) )
233
234(define (make-concatenated-port p1 . ports)
235  (let ((ports (cons p1 ports)))
236    ;;XXX should also forward other port-methods
237    (make-input-port
238     (lambda ()
239       (let loop ()
240	 (if (null? ports)
241	     #!eof
242	     (let ((c (read-char (car ports))))
243	       (cond ((eof-object? c)
244		      (set! ports (cdr ports))
245		      (loop) )
246		     (else c) ) ) ) ) )
247     (lambda ()
248       (and (not (null? ports))
249	    (char-ready? (car ports))))
250     void
251     (lambda ()
252       (let loop ()
253	 (if (null? ports)
254	     #!eof
255	     (let ((c (peek-char (car ports))))
256	       (cond ((eof-object? c)
257		      (set! ports (cdr ports))
258		      (loop) )
259		     (else c))))))
260     (lambda (p n dest start)
261       (let loop ((n n) (c 0))
262	 (cond ((null? ports) c)
263	       ((fx<= n 0) c)
264	       (else
265		(let ((m (read-string! n dest (car ports) (fx+ start c))))
266		  (when (fx< m n)
267		    (set! ports (cdr ports)) )
268		  (loop (fx- n m) (fx+ c m))))))))))
269
270
271;;; Redirect standard ports:
272
273(define (with-input-from-port port thunk)
274  (##sys#check-input-port port #t 'with-input-from-port)
275  (fluid-let ((##sys#standard-input port))
276    (thunk) ) )
277
278(define (with-output-to-port port thunk)
279  (##sys#check-output-port port #t 'with-output-to-port)
280  (fluid-let ((##sys#standard-output port))
281    (thunk) ) )
282
283(define (with-error-output-to-port port thunk)
284  (##sys#check-output-port port #t 'with-error-output-to-port)
285  (fluid-let ((##sys#standard-error port))
286    (thunk) ) )
287
288;;; Extended string-port operations:
289  
290(define call-with-input-string 
291  (lambda (str proc)
292    (let ((in (open-input-string str)))
293      (proc in) ) ) )
294
295(define call-with-output-string
296  (lambda (proc)
297    (let ((out (open-output-string)))
298      (proc out)
299      (get-output-string out) ) ) )
300
301(define with-input-from-string
302  (lambda (str thunk)
303    (fluid-let ([##sys#standard-input (open-input-string str)])
304      (thunk) ) ) )
305
306(define with-output-to-string
307  (lambda (thunk)
308    (fluid-let ((##sys#standard-output (open-output-string)))
309      (thunk) 
310      (get-output-string ##sys#standard-output) ) ) )
311
312(define with-error-output-to-string
313  (lambda (thunk)
314    (fluid-let ((##sys#standard-error (open-output-string)))
315      (thunk)
316      (get-output-string ##sys#standard-error) ) ) )
317
318;;; Custom ports:
319;
320; - Port-slots:
321;
322;   10: last
323
324(define make-input-port
325  (lambda (read ready? close #!optional peek read-string read-line read-buffered)
326    (let* ((class
327	    (vector 
328	     (lambda (p)		; read-char
329	       (let ([last (##sys#slot p 10)])
330		 (cond [peek (read)]
331		       [last
332			(##sys#setislot p 10 #f)
333			last]
334		       [else (read)] ) ) )
335	     (lambda (p)		; peek-char
336	       (let ([last (##sys#slot p 10)])
337		 (cond [peek (peek)]
338		       [last last]
339		       [else
340			(let ([last (read)])
341			  (##sys#setslot p 10 last)
342			  last) ] ) ) )
343	     #f				; write-char
344	     #f				; write-string
345	     (lambda (p d)		; close
346	       (close))
347	     #f				; flush-output
348	     (lambda (p)		; char-ready?
349	       (ready?) )
350	     read-string		; read-string!
351	     read-line			; read-line
352	     read-buffered))
353	   (data (vector #f))
354	   (port (##sys#make-port 1 class "(custom)" 'custom)))
355      (##sys#set-port-data! port data) 
356      port) ) )
357
358(define make-output-port
359  (lambda (write close #!optional flush)
360    (let* ((class
361	    (vector
362	     #f				; read-char
363	     #f				; peek-char
364	     (lambda (p c)		; write-char
365	       (write (string c)) )
366	     (lambda (p s)		; write-string
367	       (write s) )
368	     (lambda (p d)		; close
369	       (close))
370	     (lambda (p)		; flush-output
371	       (when flush (flush)) )
372	     #f				; char-ready?
373	     #f				; read-string!
374	     #f) )			; read-line
375	   (data (vector #f))
376	   (port (##sys#make-port 2 class "(custom)" 'custom)))
377      (##sys#set-port-data! port data) 
378      port) ) )
379
380(define (make-bidirectional-port i o)
381  (let* ((class (vector
382		 (lambda (_)             ; read-char
383		   (read-char i))
384		 (lambda (_)             ; peek-char
385		   (peek-char i))
386		 (lambda (_ c)           ; write-char
387		   (write-char c o))
388		 (lambda (_ s)           ; write-string
389		   (write-string s #f o))
390		 (lambda (_ d)           ; close
391		   (case d
392		     ((1) (close-input-port i))
393		     ((2) (close-output-port o))))
394		 (lambda (_)             ; flush-output
395		   (flush-output o))
396		 (lambda (_)             ; char-ready?
397		   (char-ready? i))
398		 (lambda (_ n d s)       ; read-string!
399		   (read-string! n d i s))
400		 (lambda (_ l)           ; read-line
401		   (read-line i l))
402		 (lambda ()              ; read-buffered
403		   (read-buffered i))))
404	 (port (##sys#make-port 3 class "(bidirectional)" 'bidirectional)))
405    (##sys#set-port-data! port (vector #f))
406    port))
407
408;; Duplication from posix-common.scm
409(define posix-error
410  (let ((strerror (foreign-lambda c-string "strerror" int))
411	(string-append string-append))
412    (lambda (type loc msg . args)
413      (let ((rn (##sys#update-errno)))
414        (apply ##sys#signal-hook/errno
415               type rn loc (string-append msg " - " (strerror rn)) args)))))
416
417;; Terminal ports
418(define (terminal-port? port)
419  (##sys#check-open-port port 'terminal-port?)
420  (let ((fp (##sys#peek-unsigned-integer port 0)))
421    (and (not (eq? 0 fp)) (##core#inline "C_tty_portp" port))))
422
423(define (check-terminal! caller port)
424  (##sys#check-open-port port caller)
425  (unless (and (eq? 'stream (##sys#slot port 7))
426	       (##core#inline "C_tty_portp" port))
427    (##sys#error caller "port is not connected to a terminal" port)))
428
429(define terminal-name
430  (let ((ttyname (foreign-lambda c-string "ttyname" int)))
431    (lambda (port)
432      (check-terminal! 'terminal-name port)
433      (or (ttyname (##core#inline "C_port_fileno" port))
434	  (posix-error #:error 'terminal-name
435		       "cannot determine terminal name" port)))))
436
437(define terminal-size
438  (let ((ttysize (foreign-lambda int "get_tty_size" int
439				 (nonnull-c-pointer int)
440				 (nonnull-c-pointer int))))
441    (lambda (port)
442      (check-terminal! 'terminal-size port)
443      (let-location ((columns int)
444		     (rows int))
445	(if (fx= 0 (ttysize (##core#inline "C_port_fileno" port)
446			    (location columns)
447			    (location rows)))
448	    (values columns rows)
449	    (posix-error #:error 'terminal-size
450			 "cannot determine terminal size" port))))))
451
452)