module/ice-9/iconv.scm

   1 ;;; Encoding and decoding byte representations of strings
   2
   3 ;; Copyright (C) 2013 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 ;;; Code:
  20
  21 (define-module (ice-9 iconv)
  22   #:use-module (rnrs bytevectors)
  23   #:use-module (ice-9 binary-ports)
  24   #:use-module ((ice-9 rdelim) #:select (read-string))
  25   #:export (string->bytevector
  26             bytevector->string
  27             call-with-encoded-output-string))
  28
  29 ;; Like call-with-output-string, but actually closes the port.
  30 (define (call-with-output-string* proc)
  31   (let ((port (open-output-string)))
  32     (proc port)
  33     (let ((str (get-output-string port)))
  34       (close-port port)
  35       str)))
  36
  37 (define (call-with-output-bytevector* proc)
  38   (call-with-values (lambda () (open-bytevector-output-port))
  39     (lambda (port get-bytevector)
  40       (proc port)
  41       (let ((bv (get-bytevector)))
  42         (close-port port)
  43         bv))))
  44
  45 (define* (call-with-encoded-output-string encoding proc
  46                                           #:optional
  47                                           (conversion-strategy 'error))
  48   "Call PROC on a fresh port.  Encode the resulting string as a
  49 bytevector according to ENCODING, and return the bytevector."
  50   (if (and (string-ci=? encoding "utf-8")
  51            (eq? conversion-strategy 'error))
  52       ;; I don't know why, but this appears to be faster; at least for
  53       ;; serving examples/debug-sxml.scm (1464 reqs/s versus 850
  54       ;; reqs/s).
  55       (string->utf8 (call-with-output-string* proc))
  56       (call-with-output-bytevector*
  57        (lambda (port)
  58          (set-port-encoding! port encoding)
  59          (if conversion-strategy
  60              (set-port-conversion-strategy! port conversion-strategy))
  61          (proc port)))))
  62
  63 ;; TODO: Provide C implementations that call scm_from_stringn and
  64 ;; friends?
  65
  66 (define* (string->bytevector str encoding
  67                              #:optional (conversion-strategy 'error))
  68   "Encode STRING according to ENCODING, which should be a string naming
  69 a character encoding, like \"utf-8\"."
  70   (if (and (string-ci=? encoding "utf-8")
  71            (eq? conversion-strategy 'error))
  72       (string->utf8 str)
  73       (call-with-encoded-output-string
  74        encoding
  75        (lambda (port)
  76          (display str port))
  77        conversion-strategy)))
  78
  79 (define* (bytevector->string bv encoding
  80                              #:optional (conversion-strategy 'error))
  81   "Decode the string represented by BV.  The bytes in the bytevector
  82 will be interpreted according to ENCODING, which should be a string
  83 naming a character encoding, like \"utf-8\"."
  84   (if (and (string-ci=? encoding "utf-8")
  85            (eq? conversion-strategy 'error))
  86       (utf8->string bv)
  87       (let ((p (open-bytevector-input-port bv)))
  88         (set-port-encoding! p encoding)
  89         (if conversion-strategy
  90             (set-port-conversion-strategy! p conversion-strategy))
  91         (let ((res (read-string p)))
  92           (close-port p)
  93           (if (eof-object? res)
  94               ""
  95               res)))))