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