module/rnrs/io/ports.scm

   1 ;;;; ports.scm --- R6RS port API                    -*- coding: utf-8 -*-
   2
   3 ;;;;    Copyright (C) 2009, 2010, 2011 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 3 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 ;;; Author: Ludovic Courtès <ludo@gnu.org>
  20
  21 ;;; Commentary:
  22 ;;;
  23 ;;; The I/O port API of the R6RS is provided by this module.  In many areas
  24 ;;; it complements or refines Guile's own historical port API.  For instance,
  25 ;;; it allows for binary I/O with bytevectors.
  26 ;;;
  27 ;;; Code:
  28
  29 (library (rnrs io ports (6))
  30   (export eof-object eof-object?
  31
  32           ;; auxiliary types
  33           file-options buffer-mode buffer-mode?
  34           eol-style native-eol-style error-handling-mode
  35           make-transcoder transcoder-codec transcoder-eol-style
  36           transcoder-error-handling-mode native-transcoder
  37           latin-1-codec utf-8-codec utf-16-codec
  38
  39           ;; input & output ports
  40           port? input-port? output-port?
  41           port-eof?
  42           port-transcoder binary-port? textual-port? transcoded-port
  43           port-position set-port-position!
  44           port-has-port-position? port-has-set-port-position!?
  45           call-with-port close-port
  46
  47           ;; input ports
  48           open-bytevector-input-port
  49           open-string-input-port
  50           open-file-input-port
  51           make-custom-binary-input-port
  52
  53           ;; binary input
  54           get-u8 lookahead-u8
  55           get-bytevector-n get-bytevector-n!
  56           get-bytevector-some get-bytevector-all
  57
  58           ;; output ports
  59           open-bytevector-output-port
  60           open-string-output-port
  61           open-file-output-port
  62           make-custom-binary-output-port
  63           call-with-bytevector-output-port
  64           call-with-string-output-port
  65           make-custom-textual-output-port
  66           flush-output-port
  67
  68           ;; input/output ports
  69           open-file-input/output-port
  70
  71           ;; binary output
  72           put-u8 put-bytevector
  73
  74           ;; textual input
  75           get-char get-datum get-line get-string-all get-string-n get-string-n!
  76           lookahead-char
  77
  78           ;; textual output
  79           put-char put-datum put-string
  80
  81           ;; standard ports
  82           standard-input-port standard-output-port standard-error-port
  83           current-input-port current-output-port current-error-port
  84
  85           ;; condition types
  86           &i/o i/o-error? make-i/o-error
  87           &i/o-read i/o-read-error? make-i/o-read-error
  88           &i/o-write i/o-write-error? make-i/o-write-error
  89           &i/o-invalid-position i/o-invalid-position-error?
  90           make-i/o-invalid-position-error
  91           &i/o-filename i/o-filename-error? make-i/o-filename-error
  92           i/o-error-filename
  93           &i/o-file-protection i/o-file-protection-error?
  94           make-i/o-file-protection-error
  95           &i/o-file-is-read-only i/o-file-is-read-only-error?
  96           make-i/o-file-is-read-only-error
  97           &i/o-file-already-exists i/o-file-already-exists-error?
  98           make-i/o-file-already-exists-error
  99           &i/o-file-does-not-exist i/o-file-does-not-exist-error?
 100           make-i/o-file-does-not-exist-error
 101           &i/o-port i/o-port-error? make-i/o-port-error
 102           i/o-error-port
 103           &i/o-decoding-error i/o-decoding-error?
 104           make-i/o-decoding-error
 105           &i/o-encoding-error i/o-encoding-error?
 106           make-i/o-encoding-error i/o-encoding-error-char)
 107   (import (ice-9 binary-ports)
 108           (only (rnrs base) assertion-violation)
 109           (rnrs enums)
 110           (rnrs records syntactic)
 111           (rnrs exceptions)
 112           (rnrs conditions)
 113           (rnrs files) ;for the condition types
 114           (srfi srfi-8)
 115           (ice-9 rdelim)
 116           (except (guile) raise display)
 117           (prefix (only (guile) display)
 118                   guile:))
 119
 120
 121 \f
 122 ;;;
 123 ;;; Auxiliary types
 124 ;;;
 125
 126 (define-enumeration file-option
 127   (no-create no-fail no-truncate)
 128   file-options)
 129
 130 (define-enumeration buffer-mode
 131   (none line block)
 132   buffer-modes)
 133
 134 (define (buffer-mode? symbol)
 135   (enum-set-member? symbol (enum-set-universe (buffer-modes))))
 136
 137 (define-enumeration eol-style
 138   (lf cr crlf nel crnel ls none)
 139   eol-styles)
 140
 141 (define (native-eol-style)
 142   (eol-style none))
 143
 144 (define-enumeration error-handling-mode
 145   (ignore raise replace)
 146   error-handling-modes)
 147
 148 (define-record-type (transcoder %make-transcoder transcoder?)
 149   (fields codec eol-style error-handling-mode))
 150
 151 (define* (make-transcoder codec
 152                           #:optional
 153                           (eol-style (native-eol-style))
 154                           (handling-mode (error-handling-mode replace)))
 155   (%make-transcoder codec eol-style handling-mode))
 156
 157 (define (native-transcoder)
 158   (make-transcoder (or (fluid-ref %default-port-encoding)
 159                        (latin-1-codec))))
 160
 161 (define (latin-1-codec)
 162   "ISO-8859-1")
 163
 164 (define (utf-8-codec)
 165   "UTF-8")
 166
 167 (define (utf-16-codec)
 168   "UTF-16")
 169
 170 \f
 171 ;;;
 172 ;;; Internal helpers
 173 ;;;
 174
 175 (define (with-i/o-filename-conditions filename thunk)
 176   (with-throw-handler 'system-error
 177       thunk
 178     (lambda args
 179       (let ((errno (system-error-errno args)))
 180         (let ((construct-condition
 181                (cond ((= errno EACCES)
 182                       make-i/o-file-protection-error)
 183                      ((= errno EEXIST)
 184                       make-i/o-file-already-exists-error)
 185                      ((= errno ENOENT)
 186                       make-i/o-file-does-not-exist-error)
 187                      ((= errno EROFS)
 188                       make-i/o-file-is-read-only-error)
 189                      (else
 190                       make-i/o-filename-error))))
 191           (raise (construct-condition filename)))))))
 192
 193 (define (with-i/o-port-error port make-primary-condition thunk)
 194   (with-throw-handler 'system-error
 195       thunk
 196     (lambda args
 197       (let ((errno (system-error-errno args)))
 198         (if (memv errno (list EIO EFBIG ENOSPC EPIPE))
 199             (raise (condition (make-primary-condition)
 200                               (make-i/o-port-error port)))
 201             (apply throw args))))))
 202
 203 (define-syntax with-textual-output-conditions
 204   (syntax-rules ()
 205     ((_ port body0 body ...)
 206      (with-i/o-port-error port make-i/o-write-error
 207        (lambda () (with-i/o-encoding-error body0 body ...))))))
 208
 209 (define-syntax with-textual-input-conditions
 210   (syntax-rules ()
 211     ((_ port body0 body ...)
 212      (with-i/o-port-error port make-i/o-read-error
 213        (lambda () (with-i/o-decoding-error body0 body ...))))))
 214
 215 \f
 216 ;;;
 217 ;;; Input and output ports.
 218 ;;;
 219
 220 (define (port-transcoder port)
 221   "Return the transcoder object associated with @var{port}, or @code{#f}
 222 if the port has no transcoder."
 223   (cond ((port-encoding port)
 224          => (lambda (encoding)
 225               (make-transcoder
 226                encoding
 227                (native-eol-style)
 228                (case (port-conversion-strategy port)
 229                  ((error) 'raise)
 230                  ((substitute) 'replace)
 231                  (else
 232                   (assertion-violation 'port-transcoder
 233                                        "unsupported error handling mode"))))))
 234         (else
 235          #f)))
 236
 237 (define (binary-port? port)
 238   "Returns @code{#t} if @var{port} does not have an associated encoding,
 239 @code{#f} otherwise."
 240   (not (port-encoding port)))
 241
 242 (define (textual-port? port)
 243   "Always returns @code{#t}, as all ports can be used for textual I/O in
 244 Guile."
 245   #t)
 246
 247 (define (port-eof? port)
 248   (eof-object? (if (binary-port? port)
 249                    (lookahead-u8 port)
 250                    (lookahead-char port))))
 251
 252 (define (transcoded-port port transcoder)
 253   "Return a new textual port based on @var{port}, using
 254 @var{transcoder} to encode and decode data written to or
 255 read from its underlying binary port @var{port}."
 256   ;; Hackily get at %make-transcoded-port.
 257   (let ((result ((@@ (ice-9 binary-ports) %make-transcoded-port) port)))
 258     (set-port-encoding! result (transcoder-codec transcoder))
 259     (case (transcoder-error-handling-mode transcoder)
 260       ((raise)
 261        (set-port-conversion-strategy! result 'error))
 262       ((replace)
 263        (set-port-conversion-strategy! result 'substitute))
 264       (else
 265        (error "unsupported error handling mode"
 266               (transcoder-error-handling-mode transcoder))))
 267     result))
 268
 269 (define (port-position port)
 270   "Return the offset (an integer) indicating where the next octet will be
 271 read from/written to in @var{port}."
 272
 273   ;; FIXME: We should raise an `&assertion' error when not supported.
 274   (seek port 0 SEEK_CUR))
 275
 276 (define (set-port-position! port offset)
 277   "Set the position where the next octet will be read from/written to
 278 @var{port}."
 279
 280   ;; FIXME: We should raise an `&assertion' error when not supported.
 281   (seek port offset SEEK_SET))
 282
 283 (define (port-has-port-position? port)
 284   "Return @code{#t} is @var{port} supports @code{port-position}."
 285   (and (false-if-exception (port-position port)) #t))
 286
 287 (define (port-has-set-port-position!? port)
 288   "Return @code{#t} is @var{port} supports @code{set-port-position!}."
 289   (and (false-if-exception (set-port-position! port (port-position port)))
 290        #t))
 291
 292 (define (call-with-port port proc)
 293   "Call @var{proc}, passing it @var{port} and closing @var{port} upon exit of
 294 @var{proc}.  Return the return values of @var{proc}."
 295   (call-with-values
 296       (lambda () (proc port))
 297     (lambda vals
 298       (close-port port)
 299       (apply values vals))))
 300
 301 (define* (call-with-bytevector-output-port proc #:optional (transcoder #f))
 302   (receive (port extract) (open-bytevector-output-port transcoder)
 303     (call-with-port port proc)
 304     (extract)))
 305
 306 (define (open-string-input-port str)
 307   "Open an input port that will read from @var{str}."
 308   (with-fluids ((%default-port-encoding "UTF-8"))
 309     (open-input-string str)))
 310
 311 (define (r6rs-open filename mode buffer-mode transcoder)
 312   (let ((port (with-i/o-filename-conditions filename
 313                 (lambda ()
 314                   (with-fluids ((%default-port-encoding #f))
 315                     (open filename mode))))))
 316     (cond (transcoder
 317            (set-port-encoding! port (transcoder-codec transcoder))))
 318     port))
 319
 320 (define (file-options->mode file-options base-mode)
 321   (logior base-mode
 322           (if (enum-set-member? 'no-create file-options)
 323               0
 324               O_CREAT)
 325           (if (enum-set-member? 'no-truncate file-options)
 326               0
 327               O_TRUNC)
 328           (if (enum-set-member? 'no-fail file-options)
 329               0
 330               O_EXCL)))
 331
 332 (define* (open-file-input-port filename
 333                                #:optional
 334                                (file-options (file-options))
 335                                (buffer-mode (buffer-mode block))
 336                                transcoder)
 337   "Return an input port for reading from @var{filename}."
 338   (r6rs-open filename O_RDONLY buffer-mode transcoder))
 339
 340 (define* (open-file-input/output-port filename
 341                                       #:optional
 342                                       (file-options (file-options))
 343                                       (buffer-mode (buffer-mode block))
 344                                       transcoder)
 345   "Return a port for reading from and writing to @var{filename}."
 346   (r6rs-open filename
 347              (file-options->mode file-options O_RDWR)
 348              buffer-mode
 349              transcoder))
 350
 351 (define (open-string-output-port)
 352   "Return two values: an output port that will collect characters written to it
 353 as a string, and a thunk to retrieve the characters associated with that port."
 354   (let ((port (with-fluids ((%default-port-encoding "UTF-8"))
 355                 (open-output-string))))
 356     (values port
 357             (lambda () (get-output-string port)))))
 358
 359 (define* (open-file-output-port filename
 360                                 #:optional
 361                                 (file-options (file-options))
 362                                 (buffer-mode (buffer-mode block))
 363                                 maybe-transcoder)
 364   "Return an output port for writing to @var{filename}."
 365   (r6rs-open filename
 366              (file-options->mode file-options O_WRONLY)
 367              buffer-mode
 368              maybe-transcoder))
 369
 370 (define (call-with-string-output-port proc)
 371   "Call @var{proc}, passing it a string output port. When @var{proc} returns,
 372 return the characters accumulated in that port."
 373   (let ((port (open-output-string)))
 374     (proc port)
 375     (get-output-string port)))
 376
 377 (define (make-custom-textual-output-port id
 378                                          write!
 379                                          get-position
 380                                          set-position!
 381                                          close)
 382   (make-soft-port (vector (lambda (c) (write! (string c) 0 1))
 383                           (lambda (s) (write! s 0 (string-length s)))
 384                           #f ;flush
 385                           #f ;read character
 386                           close)
 387                   "w"))
 388
 389 (define (flush-output-port port)
 390   (force-output port))
 391
 392 \f
 393 ;;;
 394 ;;; Textual output.
 395 ;;;
 396
 397 (define-condition-type &i/o-encoding &i/o-port
 398   make-i/o-encoding-error i/o-encoding-error?
 399   (char i/o-encoding-error-char))
 400
 401 (define-syntax with-i/o-encoding-error
 402   (syntax-rules ()
 403     "Convert Guile throws to `encoding-error' to `&i/o-encoding-error'."
 404     ((_ body ...)
 405      ;; XXX: This is heavyweight for small functions like `put-char'.
 406      (with-throw-handler 'encoding-error
 407        (lambda ()
 408          (begin body ...))
 409        (lambda (key subr message errno port chr)
 410          (raise (make-i/o-encoding-error port chr)))))))
 411
 412 (define (put-char port char)
 413   (with-textual-output-conditions port (write-char char port)))
 414
 415 (define (put-datum port datum)
 416   (with-textual-output-conditions port (write datum port)))
 417
 418 (define* (put-string port s #:optional start count)
 419   (with-textual-output-conditions port
 420    (cond ((not (string? s))
 421           (assertion-violation 'put-string "expected string" s))
 422          ((and start count)
 423           (display (substring/shared s start (+ start count)) port))
 424          (start
 425           (display (substring/shared s start (string-length s)) port))
 426          (else
 427           (display s port)))))
 428
 429 ;; Defined here to be able to make use of `with-i/o-encoding-error', but
 430 ;; not exported from here, but from `(rnrs io simple)'.
 431 (define* (display object #:optional (port (current-output-port)))
 432   (with-textual-output-conditions port (guile:display object port)))
 433
 434 \f
 435 ;;;
 436 ;;; Textual input.
 437 ;;;
 438
 439 (define-condition-type &i/o-decoding &i/o-port
 440   make-i/o-decoding-error i/o-decoding-error?)
 441
 442 (define-syntax with-i/o-decoding-error
 443   (syntax-rules ()
 444     "Convert Guile throws to `decoding-error' to `&i/o-decoding-error'."
 445     ((_ body ...)
 446      ;; XXX: This is heavyweight for small functions like `get-char' and
 447      ;; `lookahead-char'.
 448      (with-throw-handler 'decoding-error
 449        (lambda ()
 450          (begin body ...))
 451        (lambda (key subr message errno port)
 452          (raise (make-i/o-decoding-error port)))))))
 453
 454 (define (get-char port)
 455   (with-textual-input-conditions port (read-char port)))
 456
 457 (define (get-datum port)
 458   (with-textual-input-conditions port (read port)))
 459
 460 (define (get-line port)
 461   (with-textual-input-conditions port (read-line port 'trim)))
 462
 463 (define (get-string-all port)
 464   (with-textual-input-conditions port (read-delimited "" port 'concat)))
 465
 466 (define (get-string-n port count)
 467   "Read up to @var{count} characters from @var{port}.
 468 If no characters could be read before encountering the end of file,
 469 return the end-of-file object, otherwise return a string containing
 470 the characters read."
 471   (let* ((s (make-string count))
 472          (rv (get-string-n! port s 0 count)))
 473     (cond ((eof-object? rv) rv)
 474           ((= rv count)     s)
 475           (else             (substring/shared s 0 rv)))))
 476
 477 (define (lookahead-char port)
 478   (with-textual-input-conditions port (peek-char port)))
 479
 480 \f
 481 ;;;
 482 ;;; Standard ports.
 483 ;;;
 484
 485 (define (standard-input-port)
 486   (with-fluids ((%default-port-encoding #f))
 487     (dup->inport 0)))
 488
 489 (define (standard-output-port)
 490   (with-fluids ((%default-port-encoding #f))
 491     (dup->outport 1)))
 492
 493 (define (standard-error-port)
 494   (with-fluids ((%default-port-encoding #f))
 495     (dup->outport 2)))
 496
 497 )
 498
 499 ;;; ports.scm ends here