src/i18n.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:          i18n.lisp
   6 ;;;; Purpose:       non-ASCII character support
   7 ;;;; Programmer:    Kevin M. Rosenberg
   8 ;;;; Date Started:  Feb 2010
   9 ;;;;
  10 ;;;; This file, part of UFFI, is Copyright (c) 2002-2010 by Kevin M. Rosenberg
  11 ;;;;
  12 ;;;; *************************************************************************
  13
  14 (in-package #:uffi)
  15
  16 #-(or (and lispworks unicode) (and sbcl sb-unicode)
  17       (and allegro ics) (and clisp i18n)
  18       (and openmcl openmcl-unicode-strings))
  19 (pushnew 'no-i18n cl:*features*)
  20
  21 (defvar *default-foreign-encoding*
  22   nil
  23   "Normalized name of default external character format to use
  24 for foreign string conversions. nil means use implementation default
  25 encoding.")
  26
  27 (defvar *foreign-encoding-mapping*
  28     #+(and lispworks unicode)
  29     '((:ascii . :ascii) (:latin-1 . :latin-1) (:ucs-2 . :unicode)
  30       (:utf-8 . :utf-8) (:jis . :jis) (:sjis . :sjis) (:gbk . :gbk))
  31     #+(and sbcl sb-unicode)
  32     '((:ascii . :ascii) (:latin-1 . :latin-1) (:utf-8 . :utf-8)
  33       (:ucs-2 . :ucs-2) (:sjis . :sjis) (:gbk . :gbk))
  34     #+(and allegro ics)
  35     '((:ascii . :ascii) (:latin-1 . :latin1) (:utf-8 . :utf-8)
  36       (:sjis . :shift-jis) (:euc-jp . :euc) (:gbk . :gb2313)
  37       (:ucs-2 . :unicode))
  38     #+(and clisp unicode)
  39     '((:ascii . charset:ascii) (:ucs-2 . charset:ucs-2)
  40       (:utf-8 . charset:utf-8) (:latin-1 . charset:iso-8859-1)
  41       (:jis . charset:jis_x0201) (:jis . charset:shift-jis)
  42       (:gbk . charset:gbk) (:euc-jp . charset:euc-jp))
  43     #+(and openmcl openmcl-unicode-strings)
  44     '((:ascii . :ascii) (:latin-1 . :iso-8859-1) (:utf-8 . :utf-8)
  45       (:ucs-2 . :ucs-2)
  46       #+nil (:euc-jp . :euc-jp)
  47       )
  48     #-(or (and lispworks unicode) (and sbcl sb-unicode)
  49           (and allegro ics) (and clisp unicode)
  50           (and openmcl openmcl-unicode-strings))
  51     nil
  52   "Mapping between normalized external format name and implementation name.")
  53
  54 (defvar *foreign-encodings*
  55   (mapcar 'car *foreign-encoding-mapping*)
  56   "List of normalized names of external formats support by underlying implementation.")
  57
  58 (defun lookup-foreign-encoding (normalized)
  59   (cdr (assoc normalized *foreign-encoding-mapping* :test 'eql)))
  60
  61 (defmacro string-to-octets (str &key (encoding *default-foreign-encoding*))
  62   "Converts a Lisp string to a vector of octets."
  63   (declare (ignorable encoding))
  64   #-(or allegro lispworks openmcl sbcl)
  65   (map-into (make-array (length str) :element-type '(unsigned-byte 8))
  66             #'char-code str)
  67
  68   #+allegro
  69   (let ((fe (gensym "FE-"))
  70         (ife (gensym "IFE-"))
  71         (s (gensym "STR-")))
  72     `(let* ((,fe ,encoding)
  73             (,ife (when ,fe (lookup-foreign-encoding ,fe)))
  74             (,s ,str))
  75        (values
  76         (if ,ife
  77             (excl:string-to-octets ,s :external-format ,ife :null-terminate nil)
  78             (excl:string-to-octets ,s :null-terminate nil)))))
  79
  80   #+(or lispworks openmcl)
  81   ;; simply reading each char-code from the LENGTH of string handles multibyte characters
  82   ;; just fine in testing LW 6.0 and CCL 1.4
  83   (map-into (make-array (length str) :element-type '(unsigned-byte 8))
  84             #'char-code str)
  85
  86   #+sbcl
  87   (let ((fe (gensym "FE-"))
  88         (ife (gensym "IFE-"))
  89         (s (gensym "STR-")))
  90     `(let* ((,fe ,encoding)
  91             (,ife (when ,fe (lookup-foreign-encoding ,fe)))
  92             (,s ,str))
  93        (if ,ife
  94            (sb-ext:string-to-octets ,s :external-format ,ife)
  95            (sb-ext:string-to-octets ,s))))
  96
  97 )
  98
  99 (defmacro octets-to-string (octets &key (encoding *default-foreign-encoding*))
 100   "Converts a vector of octets to a Lisp string."
 101   (declare (ignorable encoding))
 102   #-(or allegro lispworks openmcl sbcl)
 103   (let ((out (gensym "OUT-"))
 104         (code (gensym "CODE-")))
 105     `(with-output-to-string (,out)
 106        (loop for ,code across ,octets
 107           do (write-char (code-char ,code) ,out))))
 108
 109   #+allegro
 110   (let ((fe (gensym "FE-"))
 111         (ife (gensym "IFE-"))
 112         (oct (gensym "OCTETS-")))
 113     `(let* ((,fe ,encoding)
 114             (,ife (when ,fe (lookup-foreign-encoding ,fe)))
 115             (,oct ,octets))
 116        (values
 117         (if ,ife
 118             (excl:octets-to-string ,oct :external-format ,ife)
 119             (excl:octets-to-string ,oct)))))
 120
 121   #+(or lispworks openmcl)
 122   ;; With LW 6.0 and CCL 1.4, writing multibyte character just one octet at a time tests fine
 123   (let ((out (gensym "OUT-"))
 124         (code (gensym "CODE-")))
 125     `(with-output-to-string (,out)
 126        (loop for ,code across ,octets
 127           do (write-char (code-char ,code) ,out))))
 128
 129   #+sbcl
 130   (let ((fe (gensym "FE-"))
 131         (ife (gensym "IFE-"))
 132         (oct (gensym "OCTETS-")))
 133     `(let* ((,fe ,encoding)
 134             (,ife (when ,fe (lookup-foreign-encoding ,fe)))
 135             (,oct ,octets))
 136        (if ,ife
 137            (sb-ext:octets-to-string ,oct :external-format ,ife)
 138            (sb-ext:octets-to-string ,oct))))
 139
 140 )
 141
 142 (defun foreign-encoded-octet-count (str &key (encoding *default-foreign-encoding*))
 143   "Returns the octets required to represent the string when passed to a ~
 144 foreign function."
 145   (declare (ignorable encoding))
 146   ;; AllegroCL 8-bit, CCL, and Lispworks give correct value without converting
 147   ;; to external-format. AllegroCL 16-bit, SBCL, and CLISP requires conversion
 148   ;; with external-format
 149
 150   #+(or (and allegro ics) (and sbcl sb-unicode) (and clisp i18n))
 151   (length (string-to-octets str :encoding encoding))
 152
 153   #-(or (and allegro ics) (and sbcl sb-unicode) (and clisp i18n))
 154   (length str)
 155
 156 )