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 native-transcoder
  36           latin-1-codec utf-8-codec utf-16-codec
  37
  38           ;; input & output ports
  39           port? input-port? output-port?
  40           port-eof?
  41           port-transcoder binary-port? transcoded-port
  42           port-position set-port-position!
  43           port-has-port-position? port-has-set-port-position!?
  44           call-with-port close-port
  45
  46           ;; input ports
  47           open-bytevector-input-port
  48           open-string-input-port
  49           open-file-input-port
  50           make-custom-binary-input-port
  51
  52           ;; binary input
  53           get-u8 lookahead-u8
  54           get-bytevector-n get-bytevector-n!
  55           get-bytevector-some get-bytevector-all
  56
  57           ;; output ports
  58           open-bytevector-output-port
  59           open-string-output-port
  60           open-file-output-port
  61           make-custom-binary-output-port
  62           call-with-bytevector-output-port
  63           call-with-string-output-port
  64           make-custom-textual-output-port
  65           flush-output-port
  66
  67           ;; binary output
  68           put-u8 put-bytevector
  69
  70           ;; textual input
  71           get-char get-datum get-line get-string-all lookahead-char
  72
  73           ;; textual output
  74           put-char put-datum put-string
  75
  76           ;; standard ports
  77           standard-input-port standard-output-port standard-error-port
  78
  79           ;; condition types
  80           &i/o i/o-error? make-i/o-error
  81           &i/o-read i/o-read-error? make-i/o-read-error
  82           &i/o-write i/o-write-error? make-i/o-write-error
  83           &i/o-invalid-position i/o-invalid-position-error?
  84           make-i/o-invalid-position-error
  85           &i/o-filename i/o-filename-error? make-i/o-filename-error
  86           i/o-error-filename
  87           &i/o-file-protection i/o-file-protection-error?
  88           make-i/o-file-protection-error
  89           &i/o-file-is-read-only i/o-file-is-read-only-error?
  90           make-i/o-file-is-read-only-error
  91           &i/o-file-already-exists i/o-file-already-exists-error?
  92           make-i/o-file-already-exists-error
  93           &i/o-file-does-not-exist i/o-file-does-not-exist-error?
  94           make-i/o-file-does-not-exist-error
  95           &i/o-port i/o-port-error? make-i/o-port-error
  96           i/o-error-port)
  97   (import (only (rnrs base) assertion-violation)
  98           (rnrs enums)
  99           (rnrs records syntactic)
 100           (rnrs exceptions)
 101           (rnrs conditions)
 102           (rnrs files) ;for the condition types
 103           (srfi srfi-8)
 104           (ice-9 rdelim)
 105           (except (guile) raise))
 106
 107 (load-extension (string-append "libguile-" (effective-version))
 108                 "scm_init_r6rs_ports")
 109
 110
 111 \f
 112 ;;;
 113 ;;; Auxiliary types
 114 ;;;
 115
 116 (define-enumeration file-option
 117   (no-create no-fail no-truncate)
 118   file-options)
 119
 120 (define-enumeration buffer-mode
 121   (none line block)
 122   buffer-modes)
 123
 124 (define (buffer-mode? symbol)
 125   (enum-set-member? symbol (enum-set-universe (buffer-modes))))
 126
 127 (define-enumeration eol-style
 128   (lf cr crlf nel crnel ls)
 129   eol-styles)
 130
 131 (define (native-eol-style)
 132   (eol-style lf))
 133
 134 (define-enumeration error-handling-mode
 135   (ignore raise replace)
 136   error-handling-modes)
 137
 138 (define-record-type (transcoder %make-transcoder transcoder?)
 139   (fields codec eol-style error-handling-mode))
 140
 141 (define* (make-transcoder codec
 142                           #:optional
 143                           (eol-style (native-eol-style))
 144                           (handling-mode (error-handling-mode replace)))
 145   (%make-transcoder codec eol-style handling-mode))
 146
 147 (define (native-transcoder)
 148   (make-transcoder (or (fluid-ref %default-port-encoding)
 149                        (latin-1-codec))))
 150
 151 (define (latin-1-codec)
 152   "ISO-8859-1")
 153
 154 (define (utf-8-codec)
 155   "UTF-8")
 156
 157 (define (utf-16-codec)
 158   "UTF-16")
 159
 160 \f
 161 ;;;
 162 ;;; Internal helpers
 163 ;;;
 164
 165 (define (with-i/o-filename-conditions filename thunk)
 166   (catch 'system-error
 167          thunk
 168          (lambda args
 169            (let ((errno (system-error-errno args)))
 170              (let ((construct-condition
 171                     (cond ((= errno EACCES)
 172                            make-i/o-file-protection-error)
 173                           ((= errno EEXIST)
 174                            make-i/o-file-already-exists-error)
 175                           ((= errno ENOENT)
 176                            make-i/o-file-does-not-exist-error)
 177                           ((= errno EROFS)
 178                            make-i/o-file-is-read-only-error)
 179                           (else
 180                            make-i/o-filename-error))))
 181                (raise (construct-condition filename)))))))
 182
 183 \f
 184 ;;;
 185 ;;; Input and output ports.
 186 ;;;
 187
 188 (define (port-transcoder port)
 189   (error "port transcoders are not supported" port))
 190
 191 (define (binary-port? port)
 192   ;; So far, we don't support transcoders other than the binary transcoder.
 193   #t)
 194
 195 (define (port-eof? port)
 196   (eof-object? (if (binary-port? port)
 197                    (lookahead-u8 port)
 198                    (lookahead-char port))))
 199
 200 (define (transcoded-port port transcoder)
 201   "Return a new textual port based on @var{port}, using
 202 @var{transcoder} to encode and decode data written to or
 203 read from its underlying binary port @var{port}."
 204   (let ((result (%make-transcoded-port port)))
 205     (set-port-encoding! result (transcoder-codec transcoder))
 206     (case (transcoder-error-handling-mode transcoder)
 207       ((raise)
 208        (set-port-conversion-strategy! result 'error))
 209       ((replace)
 210        (set-port-conversion-strategy! result 'substitute))
 211       (else
 212        (error "unsupported error handling mode"
 213               (transcoder-error-handling-mode transcoder))))
 214     result))
 215
 216 (define (port-position port)
 217   "Return the offset (an integer) indicating where the next octet will be
 218 read from/written to in @var{port}."
 219
 220   ;; FIXME: We should raise an `&assertion' error when not supported.
 221   (seek port 0 SEEK_CUR))
 222
 223 (define (set-port-position! port offset)
 224   "Set the position where the next octet will be read from/written to
 225 @var{port}."
 226
 227   ;; FIXME: We should raise an `&assertion' error when not supported.
 228   (seek port offset SEEK_SET))
 229
 230 (define (port-has-port-position? port)
 231   "Return @code{#t} is @var{port} supports @code{port-position}."
 232   (and (false-if-exception (port-position port)) #t))
 233
 234 (define (port-has-set-port-position!? port)
 235   "Return @code{#t} is @var{port} supports @code{set-port-position!}."
 236   (and (false-if-exception (set-port-position! port (port-position port)))
 237        #t))
 238
 239 (define (call-with-port port proc)
 240   "Call @var{proc}, passing it @var{port} and closing @var{port} upon exit of
 241 @var{proc}.  Return the return values of @var{proc}."
 242   (call-with-values
 243       (lambda () (proc port))
 244     (lambda vals
 245       (close-port port)
 246       (apply values vals))))
 247
 248 (define* (call-with-bytevector-output-port proc #:optional (transcoder #f))
 249   (receive (port extract) (open-bytevector-output-port transcoder)
 250     (call-with-port port proc)
 251     (extract)))
 252
 253 (define (open-string-input-port str)
 254   "Open an input port that will read from @var{str}."
 255   (with-fluids ((%default-port-encoding "UTF-8"))
 256     (open-input-string str)))
 257
 258 (define* (open-file-input-port filename
 259                                #:optional
 260                                (file-options (file-options))
 261                                (buffer-mode (buffer-mode block))
 262                                maybe-transcoder)
 263   (let ((port (with-i/o-filename-conditions filename
 264                 (lambda () (open filename O_RDONLY)))))
 265     (cond (maybe-transcoder
 266            (set-port-encoding! port (transcoder-codec maybe-transcoder))))
 267     port))
 268
 269 (define (open-string-output-port)
 270   "Return two values: an output port that will collect characters written to it
 271 as a string, and a thunk to retrieve the characters associated with that port."
 272   (let ((port (with-fluids ((%default-port-encoding "UTF-8"))
 273                 (open-output-string))))
 274     (values port
 275             (lambda () (get-output-string port)))))
 276
 277 (define* (open-file-output-port filename
 278                                 #:optional
 279                                 (file-options (file-options))
 280                                 (buffer-mode (buffer-mode block))
 281                                 maybe-transcoder)
 282   (let* ((flags (logior O_WRONLY
 283                         (if (enum-set-member? 'no-create file-options)
 284                             0
 285                             O_CREAT)
 286                         (if (enum-set-member? 'no-truncate file-options)
 287                             0
 288                             O_TRUNC)))
 289          (port (with-i/o-filename-conditions filename
 290                  (lambda () (open filename flags)))))
 291     (cond (maybe-transcoder
 292            (set-port-encoding! port (transcoder-codec maybe-transcoder))))
 293     port))
 294
 295 (define (call-with-string-output-port proc)
 296   "Call @var{proc}, passing it a string output port. When @var{proc} returns,
 297 return the characters accumulated in that port."
 298   (let ((port (open-output-string)))
 299     (proc port)
 300     (get-output-string port)))
 301
 302 (define (make-custom-textual-output-port id
 303                                          write!
 304                                          get-position
 305                                          set-position!
 306                                          close)
 307   (make-soft-port (vector (lambda (c) (write! (string c) 0 1))
 308                           (lambda (s) (write! s 0 (string-length s)))
 309                           #f ;flush
 310                           #f ;read character
 311                           close)
 312                   "w"))
 313
 314 (define (flush-output-port port)
 315   (force-output port))
 316
 317 (define (put-char port char)
 318   (write-char char port))
 319
 320 (define (put-datum port datum)
 321   (write datum port))
 322
 323 (define* (put-string port s #:optional start count)
 324   (cond ((not (string? s))
 325          (assertion-violation 'put-string "expected string" s))
 326         ((and start count)
 327          (display (substring/shared s start (+ start count)) port))
 328         (start
 329          (display (substring/shared s start (string-length s)) port))
 330         (else
 331          (display s port))))
 332
 333 (define (get-char port)
 334   (read-char port))
 335
 336 (define (get-datum port)
 337   (read port))
 338
 339 (define (get-line port)
 340   (read-line port 'trim))
 341
 342 (define (get-string-all port)
 343   (read-delimited "" port 'concat))
 344
 345 (define (lookahead-char port)
 346   (peek-char port))
 347
 348
 349 \f
 350 (define (standard-input-port)
 351   (dup->inport 0))
 352
 353 (define (standard-output-port)
 354   (dup->outport 1))
 355
 356 (define (standard-error-port)
 357   (dup->outport 2))
 358
 359 )
 360
 361 ;;; ports.scm ends here