share/guile/1.6.0/ice-9/rdelim.scm

   1 ;;; installed-scm-file
   2
   3 ;;;; Copyright (C) 1997, 1999, 2000, 2001 Free Software Foundation, Inc.
   4 ;;;;
   5 ;;;; This program is free software; you can redistribute it and/or modify
   6 ;;;; it under the terms of the GNU General Public License as published by
   7 ;;;; the Free Software Foundation; either version 2, or (at your option)
   8 ;;;; any later version.
   9 ;;;;
  10 ;;;; This program 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
  13 ;;;; GNU General Public License for more details.
  14 ;;;;
  15 ;;;; You should have received a copy of the GNU General Public License
  16 ;;;; along with this software; see the file COPYING.  If not, write to
  17 ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  18 ;;;; Boston, MA 02111-1307 USA
  19 ;;;;
  20 ;;;; As a special exception, the Free Software Foundation gives permission
  21 ;;;; for additional uses of the text contained in its release of GUILE.
  22 ;;;;
  23 ;;;; The exception is that, if you link the GUILE library with other files
  24 ;;;; to produce an executable, this does not by itself cause the
  25 ;;;; resulting executable to be covered by the GNU General Public License.
  26 ;;;; Your use of that executable is in no way restricted on account of
  27 ;;;; linking the GUILE library code into it.
  28 ;;;;
  29 ;;;; This exception does not however invalidate any other reasons why
  30 ;;;; the executable file might be covered by the GNU General Public License.
  31 ;;;;
  32 ;;;; This exception applies only to the code released by the
  33 ;;;; Free Software Foundation under the name GUILE.  If you copy
  34 ;;;; code from other Free Software Foundation releases into a copy of
  35 ;;;; GUILE, as the General Public License permits, the exception does
  36 ;;;; not apply to the code that you add in this way.  To avoid misleading
  37 ;;;; anyone as to the status of such modified files, you must delete
  38 ;;;; this exception notice from them.
  39 ;;;;
  40 ;;;; If you write modifications of your own for GUILE, it is your choice
  41 ;;;; whether to permit this exception to apply to your modifications.
  42 ;;;; If you do not wish that, delete this exception notice.
  43 ;;;;
  44 \f
  45
  46 ;;; This is the Scheme part of the module for delimited I/O.  It's
  47 ;;; similar to (scsh rdelim) but somewhat incompatible.
  48
  49 (define-module (ice-9 rdelim)
  50   :export (read-line read-line! read-delimited read-delimited!
  51            %read-delimited! %read-line write-line)  ; C
  52   )
  53
  54 (%init-rdelim-builtins)
  55
  56 (define (read-line! string . maybe-port)
  57   ;; corresponds to SCM_LINE_INCREMENTORS in libguile.
  58   (define scm-line-incrementors "\n")
  59
  60   (let* ((port (if (pair? maybe-port)
  61                    (car maybe-port)
  62                    (current-input-port))))
  63     (let* ((rv (%read-delimited! scm-line-incrementors
  64                                  string
  65                                  #t
  66                                  port))
  67            (terminator (car rv))
  68            (nchars (cdr rv)))
  69       (cond ((and (= nchars 0)
  70                   (eof-object? terminator))
  71              terminator)
  72             ((not terminator) #f)
  73             (else nchars)))))
  74
  75 (define (read-delimited! delims buf . args)
  76   (let* ((num-args (length args))
  77          (port (if (> num-args 0)
  78                    (car args)
  79                    (current-input-port)))
  80          (handle-delim (if (> num-args 1)
  81                            (cadr args)
  82                            'trim))
  83          (start (if (> num-args 2)
  84                     (caddr args)
  85                     0))
  86          (end (if (> num-args 3)
  87                   (cadddr args)
  88                   (string-length buf))))
  89     (let* ((rv (%read-delimited! delims
  90                                  buf
  91                                  (not (eq? handle-delim 'peek))
  92                                  port
  93                                  start
  94                                  end))
  95            (terminator (car rv))
  96            (nchars (cdr rv)))
  97       (cond ((or (not terminator)       ; buffer filled
  98                  (eof-object? terminator))
  99              (if (zero? nchars)
 100                  (if (eq? handle-delim 'split)
 101                      (cons terminator terminator)
 102                      terminator)
 103                  (if (eq? handle-delim 'split)
 104                      (cons nchars terminator)
 105                      nchars)))
 106             (else
 107              (case handle-delim
 108                ((trim peek) nchars)
 109                ((concat) (string-set! buf (+ nchars start) terminator)
 110                          (+ nchars 1))
 111                ((split) (cons nchars terminator))
 112                (else (error "unexpected handle-delim value: "
 113                             handle-delim))))))))
 114
 115 (define (read-delimited delims . args)
 116   (let* ((port (if (pair? args)
 117                    (let ((pt (car args)))
 118                      (set! args (cdr args))
 119                      pt)
 120                    (current-input-port)))
 121          (handle-delim (if (pair? args)
 122                            (car args)
 123                            'trim)))
 124     (let loop ((substrings '())
 125                (total-chars 0)
 126                (buf-size 100))          ; doubled each time through.
 127       (let* ((buf (make-string buf-size))
 128              (rv (%read-delimited! delims
 129                                    buf
 130                                    (not (eq? handle-delim 'peek))
 131                                    port))
 132              (terminator (car rv))
 133              (nchars (cdr rv))
 134              (join-substrings
 135               (lambda ()
 136                 (apply string-append
 137                        (reverse
 138                         (cons (if (and (eq? handle-delim 'concat)
 139                                        (not (eof-object? terminator)))
 140                                   (string terminator)
 141                                   "")
 142                               (cons (substring buf 0 nchars)
 143                                     substrings))))))
 144              (new-total (+ total-chars nchars)))
 145         (cond ((not terminator)
 146                ;; buffer filled.
 147                (loop (cons (substring buf 0 nchars) substrings)
 148                      new-total
 149                      (* buf-size 2)))
 150               ((eof-object? terminator)
 151                (if (zero? new-total)
 152                    (if (eq? handle-delim 'split)
 153                        (cons terminator terminator)
 154                        terminator)
 155                    (if (eq? handle-delim 'split)
 156                        (cons (join-substrings) terminator)
 157                        (join-substrings))))
 158               (else
 159                (case handle-delim
 160                    ((trim peek concat) (join-substrings))
 161                    ((split) (cons (join-substrings) terminator))
 162
 163
 164                    (else (error "unexpected handle-delim value: "
 165                                 handle-delim)))))))))
 166
 167 ;;; read-line [PORT [HANDLE-DELIM]] reads a newline-terminated string
 168 ;;; from PORT.  The return value depends on the value of HANDLE-DELIM,
 169 ;;; which may be one of the symbols `trim', `concat', `peek' and
 170 ;;; `split'.  If it is `trim' (the default), the trailing newline is
 171 ;;; removed and the string is returned.  If `concat', the string is
 172 ;;; returned with the trailing newline intact.  If `peek', the newline
 173 ;;; is left in the input port buffer and the string is returned.  If
 174 ;;; `split', the newline is split from the string and read-line
 175 ;;; returns a pair consisting of the truncated string and the newline.
 176
 177 (define (read-line . args)
 178   (let* ((port          (if (null? args)
 179                             (current-input-port)
 180                             (car args)))
 181          (handle-delim  (if (> (length args) 1)
 182                             (cadr args)
 183                             'trim))
 184          (line/delim    (%read-line port))
 185          (line          (car line/delim))
 186          (delim         (cdr line/delim)))
 187     (case handle-delim
 188       ((trim) line)
 189       ((split) line/delim)
 190       ((concat) (if (and (string? line) (char? delim))
 191                     (string-append line (string delim))
 192                     line))
 193       ((peek) (if (char? delim)
 194                   (unread-char delim port))
 195               line)
 196       (else
 197        (error "unexpected handle-delim value: " handle-delim)))))