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@gmail.com" :licence "MIT License" :depends-on (cffi #+sbcl sb-posix) :components ((:file "src")) )