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   #-(or allegro lispworks openmcl sbcl)
  64   (declare (ignore encoding))
  65   #-(or allegro lispworks openmcl sbcl)
  66   (map-into (make-array (length str) :element-type '(unsigned-byte 8))
  67             #'char-code str)
  68
  69   #+allegro
  70   (let ((fe (gensym "FE-"))
  71         (ife (gensym "IFE-"))
  72         (s (gensym "STR-")))
  73     `(let* ((,fe ,encoding)
  74             (,ife (when ,fe (lookup-foreign-encoding ,fe)))
  75             (,s ,str))
  76        (values
  77         (if ,ife
  78             (excl:string-to-octets ,s :external-format ,ife :null-terminate nil)
  79             (excl:string-to-octets ,s :null-terminate nil)))))
  80
  81   #+(or lispworks openmcl)
  82   ;; simply reading each char-code from the LENGTH of string handles multibyte characters
  83   ;; just fine in testing LW 6.0 and CCL 1.4
  84   (map-into (make-array (length str) :element-type '(unsigned-byte 8))
  85             #'char-code str)
  86
  87   #+sbcl
  88   (let ((fe (gensym "FE-"))
  89         (ife (gensym "IFE-"))
  90         (s (gensym "STR-")))
  91     `(let* ((,fe ,encoding)
  92             (,ife (when ,fe (lookup-foreign-encoding ,fe)))
  93             (,s ,str))
  94        (if ,ife
  95            (sb-ext:string-to-octets ,s :external-format ,ife)
  96            (sb-ext:string-to-octets ,s))))
  97
  98 )
  99
 100 (defmacro octets-to-string (octets &key (encoding *default-foreign-encoding*))
 101   "Converts a vector of octets to a Lisp string."
 102   #-(or allegro lispworks openmcl sbcl)
 103   (declare (ignore encoding))
 104   #-(or allegro lispworks openmcl sbcl)
 105   (let ((out (gensym "OUT-"))
 106         (code (gensym "CODE-")))
 107     `(with-output-to-string (,out)
 108        (loop for ,code across ,octets
 109           do (write-char (code-char ,code) ,out))))
 110
 111   #+allegro
 112   (let ((fe (gensym "FE-"))
 113         (ife (gensym "IFE-"))
 114         (oct (gensym "OCTETS-")))
 115     `(let* ((,fe ,encoding)
 116             (,ife (when ,fe (lookup-foreign-encoding ,fe)))
 117             (,oct ,octets))
 118        (values
 119         (if ,ife
 120             (excl:octets-to-string ,oct :external-format ,ife)
 121             (excl:octets-to-string ,oct)))))
 122
 123   #+(or lispworks openmcl)
 124   ;; With LW 6.0 and CCL 1.4, writing multibyte character just one octet at a time tests fine
 125   (let ((out (gensym "OUT-"))
 126         (code (gensym "CODE-")))
 127     `(with-output-to-string (,out)
 128        (loop for ,code across ,octets
 129           do (write-char (code-char ,code) ,out))))
 130
 131   #+sbcl
 132   (let ((fe (gensym "FE-"))
 133         (ife (gensym "IFE-"))
 134         (oct (gensym "OCTETS-")))
 135     `(let* ((,fe ,encoding)
 136             (,ife (when ,fe (lookup-foreign-encoding ,fe)))
 137             (,oct ,octets))
 138        (if ,ife
 139            (sb-ext:octets-to-string ,oct :external-format ,ife)
 140            (sb-ext:octets-to-string ,oct))))
 141
 142 )
 143
 144 (defun foreign-encoded-octet-count (str &key (encoding *default-foreign-encoding*))
 145   "Returns the octets required to represent the string when passed to a ~
 146 foreign function."
 147   ;; AllegroCL 8-bit, CCL, and Lispworks give correct value without converting
 148   ;; to external-format. AllegroCL 16-bit, SBCL, and CLISP requires conversion
 149   ;; with external-format
 150
 151   #+(or (and allegro ics) (and sbcl sb-unicode) (and clisp i18n))
 152   (length (string-to-octets str :encoding encoding))
 153
 154   #-(or (and allegro ics) (and sbcl sb-unicode) (and clisp i18n))
 155   (declare (ignore encoding))
 156   #-(or (and allegro ics) (and sbcl sb-unicode) (and clisp i18n))
 157   (length str)
 158
 159 )