lineio.scm 4.0 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120
  1. ;;; installed-scm-file
  2. ;;;; Copyright (C) 1996, 1998, 2001, 2003, 2006, 2023 Free Software Foundation, Inc.
  3. ;;;;
  4. ;;;; This library is free software; you can redistribute it and/or
  5. ;;;; modify it under the terms of the GNU Lesser General Public
  6. ;;;; License as published by the Free Software Foundation; either
  7. ;;;; version 3 of the License, or (at your option) any later version.
  8. ;;;;
  9. ;;;; This library is distributed in the hope that it will be useful,
  10. ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11. ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
  12. ;;;; Lesser General Public License for more details.
  13. ;;;;
  14. ;;;; You should have received a copy of the GNU Lesser General Public
  15. ;;;; License along with this library; if not, write to the Free Software
  16. ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  17. ;;;;
  18. (define-module (ice-9 lineio)
  19. :use-module (ice-9 rdelim)
  20. :export (unread-string read-string lineio-port?
  21. make-line-buffering-input-port))
  22. (issue-deprecation-warning
  23. "(ice-9 lineio) is deprecated. Use read-line together with
  24. unread-string instead.")
  25. ;;; {Line Buffering Input Ports}
  26. ;;;
  27. ;;; [This is a work-around to get past certain deficiencies in the capabilities
  28. ;;; of ports. Eventually, ports should be fixed and this module nuked.]
  29. ;;;
  30. ;;; A line buffering input port supports:
  31. ;;;
  32. ;;; read-string which returns the next line of input
  33. ;;; unread-string which pushes a line back onto the stream
  34. ;;;
  35. ;;; The implementation of unread-string is kind of limited; it doesn't
  36. ;;; interact properly with unread-char, or any of the other port
  37. ;;; reading functions. Only read-string will get you back the things that
  38. ;;; unread-string accepts.
  39. ;;;
  40. ;;; Normally a "line" is all characters up to and including a newline.
  41. ;;; If lines are put back using unread-string, they can be broken arbitrarily
  42. ;;; -- that is, read-string returns strings passed to unread-string (or
  43. ;;; shared substrings of them).
  44. ;;;
  45. ;; read-string port
  46. ;; unread-string port str
  47. ;; Read (or buffer) a line from PORT.
  48. ;;
  49. ;; Not all ports support these functions -- only those with
  50. ;; 'unread-string and 'read-string properties, bound to hooks
  51. ;; implementing these functions.
  52. ;;
  53. (define (unread-string str line-buffering-input-port)
  54. ((object-property line-buffering-input-port 'unread-string) str))
  55. ;;
  56. (define (read-string line-buffering-input-port)
  57. ((object-property line-buffering-input-port 'read-string)))
  58. (define (lineio-port? port)
  59. (not (not (object-property port 'read-string))))
  60. ;; make-line-buffering-input-port port
  61. ;; Return a wrapper for PORT. The wrapper handles read-string/unread-string.
  62. ;;
  63. ;; The port returned by this function reads newline terminated lines from PORT.
  64. ;; It buffers these characters internally, and parsels them out via calls
  65. ;; to read-char, read-string, and unread-string.
  66. ;;
  67. (define (make-line-buffering-input-port underlying-port)
  68. (let* (;; buffers - a list of strings put back by unread-string or cached
  69. ;; using read-line.
  70. ;;
  71. (buffers '())
  72. ;; getc - return the next character from a buffer or from the underlying
  73. ;; port.
  74. ;;
  75. (getc (lambda ()
  76. (if (not buffers)
  77. (read-char underlying-port)
  78. (let ((c (string-ref (car buffers) 0)))
  79. (if (= 1 (string-length (car buffers)))
  80. (set! buffers (cdr buffers))
  81. (set-car! buffers (substring (car buffers) 1)))
  82. c))))
  83. (propogate-close (lambda () (close-port underlying-port)))
  84. (self (make-soft-port (vector #f #f #f getc propogate-close) "r"))
  85. (unread-string (lambda (str)
  86. (and (< 0 (string-length str))
  87. (set! buffers (cons str buffers)))))
  88. (read-string (lambda ()
  89. (cond
  90. ((not (null? buffers))
  91. (let ((answer (car buffers)))
  92. (set! buffers (cdr buffers))
  93. answer))
  94. (else
  95. (read-line underlying-port 'concat)))))) ;handle-newline->concat
  96. (set-object-property! self 'unread-string unread-string)
  97. (set-object-property! self 'read-string read-string)
  98. self))