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