Update of /project/trivial-iconv/cvsroot/trivial-iconv
In directory clnet:/tmp/cvs-serv28668
Added Files:
src.lisp test.lisp trivial-iconv.asd
Log Message:
regist src.
--- /project/trivial-iconv/cvsroot/trivial-iconv/src.lisp 2008/06/14 07:21:39 NONE
+++ /project/trivial-iconv/cvsroot/trivial-iconv/src.lisp 2008/06/14 07:21:39 1.1
;;; Copyright (c) 2008 KOGA Kazuo
;;;
;;; Permission is hereby granted, free of charge, to any person obtaining a copy
;;; of this software and associated documentation files (the "Software"), to deal
;;; in the Software without restriction, including without limitation the rights
;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
;;; copies of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be included in
;;; all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
;;; THE SOFTWARE.
(defpackage :trivial-iconv
(:nicknames :iconv)
(:use :cl :cffi)
(:export open-iconv
close-iconv
with-iconv
iconv
convert-charset
decode-vector))
(in-package :trivial-iconv)
(define-foreign-library libiconv
(:darwin "libiconv.dylib")
(:unix (:or "libiconv.so.3" "libiconv.so"))
(t (:default "libiconv")))
(use-foreign-library libiconv)
(defcfun ("iconv" %iconv) :uint (cd :pointer) (inbuf :pointer) (inbytesleft :pointer) (outbuf :pointer) (outbytesleft :pointer))
(defcfun ("iconv_open" %iconv-open) :pointer (tocode :string) (fromcode :string))
(defcfun ("iconv_close" %iconv-close) :int (cd :pointer))
#-(or sbcl clozure)
(error "Does not implemented in this lisp implementation.")
(defun errno ()
#+sbcl (sb-alien:get-errno)
#+clozure (- (ccl::%get-errno)))
(defconstant +E2BIG+
#+sbcl sb-posix::E2BIG
#+clozure #$E2BIG)
(defconstant +EILSEQ+
#+sbcl sb-posix::EILSEQ
#+clozure #$EILSEQ)
(defconstant +EINVAL+
#+sbcl sb-posix::EINVAL
#+clozure #$EINVAL)
(defconstant +invalid-descriptor-address+
(pointer-address (inc-pointer (null-pointer) -1))
"foreign: (iconv_t)-1")
(defconstant +invalid-result+ +invalid-descriptor-address+
"foreign: (size_t)-1")
(defconstant +min-outbuf-size+ 12
"must enough length for any valid 1 character octet sequence in all available external encodings,
that includes UTF BOM or ISO-2022 escape sequence.")
(defun open-iconv (&key to from finalizer)
"allocates a conversion descriptor suitable for converting byte sequences from character encoding FROM to character encoding TO.
if FINALIZER is t, returned conversion descriptor will finalize with close-iconv.
if FINALIZER is function, returned conversion descriptor will finalize with it."
(let ((cd (%iconv-open (string to) (string from))))
(cond ((= (pointer-address cd) +invalid-descriptor-address+)
(error "open"))
((null finalizer))
((typep finalizer 'function)
(finalize cd finalizer))
(t
(finalize cd (lambda () (close-iconv cd)))))
cd))
(defun close-iconv (conversion-descriptor)
"deallocates a conversion descriptor CONVERSION-DESCRIPTOR previously allocated using open-iconv."
(if (zerop (%iconv-close conversion-descriptor))
t
(error "close")))
(defun reset-iconv (cd)
"set cd's conversion state to the initial state."
(let ((null (null-pointer)))
(if (zerop (%iconv cd null null null null))
cd
(error "reset"))))
(defmacro with-iconv ((conversion-descriptor &rest open-args) &body body)
`(let ((,conversion-descriptor (open-iconv ,@open-args)))
(declare (dynamic-extent ,conversion-descriptor))
(unwind-protect
(progn ,@body)
(close-iconv ,conversion-descriptor))))
(defun pointer-diff (x y)
(- (pointer-address x) (pointer-address y)))
(defun copy-foreign-vector-to-lisp (fptr size)
(if (zerop size)
()
(loop
with vector = (make-array size :element-type '(unsigned-byte 8))
for i from 0 below size
do (setf (aref vector i) (mem-aref fptr :uchar i))
finally (return vector))))
(defun iconv (cd vector &optional last-p &key (receive #'copy-foreign-vector-to-lisp))
(let* ((isize (length vector))
(osize (max isize +min-outbuf-size+)))
(with-foreign-string (inbuf vector)
(with-foreign-objects ((iptr :pointer)
(inbytesleft :uint)
(outbuf :char osize)
(optr :pointer)
(outbytesleft :uint))
(setf (mem-ref iptr :pointer) inbuf
(mem-ref inbytesleft :uint) isize
(mem-ref optr :pointer) outbuf
(mem-ref outbytesleft :uint) osize)
(macrolet ((copy-output ()
`(funcall receive outbuf (pointer-diff (mem-ref optr :pointer) outbuf)))
(set-output ()
`(setf (mem-ref optr :pointer) outbuf
(mem-ref outbytesleft :uint) osize))
(nconc-outputs ()
`(let ((output (copy-output)))
(if output
(nconc outputs (list output))
outputs))))
(loop with non-reversible = 0
while (< 0 (mem-ref inbytesleft :uint))
if (let ((result (%iconv cd iptr inbytesleft optr outbytesleft)))
#+nil
(format t "result ~A, in ~A:~A, out ~A:~A~%" result
(pointer-diff (mem-ref iptr :pointer) inbuf) (mem-ref inbytesleft :uint)
(pointer-diff (mem-ref optr :pointer) outbuf) (mem-ref outbytesleft :uint))
(if (= result +invalid-result+)
(let ((errno (errno)))
(cond ((= errno +E2BIG+)
(prog1 (copy-output) (set-output)))
((= errno +EILSEQ+)
(return (values (nconc-outputs) (pointer-diff (mem-ref iptr :pointer) inbuf) :invalid)))
((= errno +EINVAL+)
(return (values (nconc-outputs) (pointer-diff (mem-ref iptr :pointer) inbuf) :incomplete)))
(t (error "unexpected"))))
(prog1 (copy-output) (set-output) (incf non-reversible result))))
collect it into outputs
finally (return (values (if last-p
(progn
(set-output)
(%iconv cd (null-pointer) (null-pointer) optr outbytesleft)
(nconc-outputs))
outputs)
non-reversible :success))))))))
(defun convert-charset (vector &key to from)
"(vector (unsigned-byte 8)) => (list (vector (unsigned-byte 8))).
:to -> input character set encoding.
:from -> output character set encoding."
(with-iconv (cd :from from :to to)
(iconv cd vector t)))
(defun decode-vector (vector fromcode)
"(vector (unsigned-byte 8)) input-charset => (list string).
works only 32bit platform and only char-code returns UTF-32."
(with-iconv (cd :to
#+cffi-features:ppc32 :utf-32be
#-cffi-features:ppc32 :utf-32le
:from fromcode)
(iconv cd vector t
:receive (lambda (ptr nbytes)
(if (zerop nbytes) nil
(loop with length = (truncate (/ nbytes 4))
with string = (make-array length :element-type 'character)
for i from 0 below length
do (setf (aref string i) (code-char (mem-aref ptr :uint i)))
finally (return (coerce string 'string))))))))
--- /project/trivial-iconv/cvsroot/trivial-iconv/test.lisp 2008/06/14 07:21:39 NONE
+++ /project/trivial-iconv/cvsroot/trivial-iconv/test.lisp 2008/06/14 07:21:39 1.1
(defvar *t1* (coerce #(90 90 90 90 90 #x87 #x65 #x43 #x21) '(vector (unsigned-byte 8))))
(defvar *t2* (coerce #(90 90 90 90 #xe3 #x82) '(vector (unsigned-byte 8))))
(defvar *t3* (coerce #(97 #xe3 #x81 #x8b) '(vector (unsigned-byte 8))))
#-asdf
(require :asdf)
(asdf:operate 'asdf:load-op :trivial-iconv)
--- /project/trivial-iconv/cvsroot/trivial-iconv/trivial-iconv.asd 2008/06/14 07:21:39 NONE
+++ /project/trivial-iconv/cvsroot/trivial-iconv/trivial-iconv.asd 2008/06/14 07:21:39 1.1
;;; -*- mode: lisp; coding: utf-8 -*-
;;; Copyright (c) 2008 KOGA Kazuo
;;;
;;; Permission is hereby granted, free of charge, to any person obtaining a copy
;;; of this software and associated documentation files (the "Software"), to deal
;;; in the Software without restriction, including without limitation the rights
;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
;;; copies of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be included in
;;; all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
;;; THE SOFTWARE.
(asdf:defsystem :trivial-iconv
:description "CFFI interface for the platform's libiconv."
:version "0.1"
:author "KOGA Kazuo <kogakazuo(a)gmail.com>"
:licence "MIT License"
:depends-on (cffi #+sbcl sb-posix)
:components ((:file "src")) )
