public
Last active

iconv library for newLISP

  • Download Gist
iconv.lsp
Common Lisp
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185
;;; -*- mode:newlisp; coding:utf-8 -*-
 
;; @module iconv.lsp
;; @description Yet Another Iconv Library
;; @version 0.5 初版
;; @version 0.6 Windows(DLL)でも使えるように
;; @version 0.7 関数を増やした
;; @version 0.8 変換後のNULL文字に対応したつもり
;; @version 0.8b newlisp_sjisでのバッファあふれ修正
;; @version 0.8c Rename iconv-handler -> call-with-iconv-descriptor
;; @version 0.8d a few modified.
;; @version 0.9 SunOS 5.10 sparc にて動作テスト。
;; ロード時にIconv:initを呼び出すように変更
;; @version 0.9b Tested FreeBSD 8.1
;; @version 0.9c Tested CYGWIN_NT-5.1
;; @author KOBAYASHI Shigeru <shigeru.kb[at]gmail.com>, 2009-2011
;; @location https://raw.github.com/gist/242697
 
;; @example
;; (load "iconv.lsp")
;; ;(Iconv:init)
;;
;; $ echo -n 'おはよう、朝だよ!' | iconv -t EUC-JP > euc.txt
;; (write-file "euc.txt" (Iconv:encode "おはよう、朝だよ!" "EUC-JP"))
;;
;; $ cat euc.txt | iconv -f EUC-JP
;; (Iconv:decode (read-file "euc.txt") "EUC-JP")
;; => "おはよう、朝だよ!"
;;
;; (let ((str "\xa3\xb1\xa1\xdc\xa3\xb1\xa1\xe1\xa3\xb2"))
;; (Iconv:decode str "EUC-JP"))
;; => "1+1=2"
;;
;; (define (my-unicode str)
;; (Iconv:convert str "UTF-8" "UTF-32LE"))
;; (my-unicode "new") => "n\000\000\000e\000\000\000w\000\000\000"
;;
;; (define (my-utf8 str)
;; (Iconv:convert str "UTF-32LE" "UTF-8"))
;; (my-utf8 (unicode "new")) => "new\000"
;; (my-utf8 (my-unicode "new")) => "new"
 
;; @KnownBugs
;; 端末以外から利用すると正しく表示されないかもしれない
 
;; @TODO
;; (! "iconv --list") list all known coded character sets
;; メモリ不足を避けるために分割して変換する関数も欲しい
;; 変換用に用意するバッファのサイズが適当過ぎる
;; ポインタ変数の分かりやすい表記方法があれば取り込みたい (p_str, *str)
;; iconv/libiconv を区別する方法
;; エラーを投げるよりも無理矢理変換する方が良い?
 
;;; Code:
 
(context 'Iconv)
 
; See man 3 iconv.
;
; size_t iconv(iconv_t cd, char **inbuf, size_t *inbytesleft, char **outbuf, size_t *outbytesleft);
; iconv_t iconv_open(const char *tocode, const char *fromcode);
; int iconv_close(iconv_t cd);
 
;; NOTE:
;; - KaoriYa.net provides "iconv.dll"
;; - GnuWin32 provides "libiconv2.dll"
(define libiconv-lib
(case ostype
("Win32" "iconv.dll") ; or "libiconv.dll" "libiconv2.dll"
("Cygwin" "cygiconv-2.dll")
("Linux" "libc.so.6") ; Ubuntu 9.04
("SunOS" "libc.so.1") ; SunOS 5.10
("BSD" "libiconv.so") ; FreeBSD 8.1
(true "libc.so.6")))
 
;; @syntax (Iconv:init [<library-name>])
;; @return true (but not meaningful)
;; Loadup iconv library functions.
;;
;; @example
;; (Iconv:init)
;; (Iconv:init "C:/usr/lib/libiconv.dll") ; specifies library pathname
(define (init (libname nil))
(when libname
(setq libiconv-lib libname))
(cond
((member ostype '("Win32" "Cygwin"))
(define iconv (import libiconv-lib "libiconv"))
(define iconv_open (import libiconv-lib "libiconv_open"))
(define iconv_close (import libiconv-lib "libiconv_close")))
(true
(define iconv (import libiconv-lib "iconv"))
(define iconv_open (import libiconv-lib "iconv_open"))
(define iconv_close (import libiconv-lib "iconv_close"))))
true)
 
(define newlisp-encoding
(if (primitive? unicode) "UTF-8" "Shift_JIS"))
 
(define (error)
(throw-error (apply format (args))))
 
;; @syntax (unwind-protect <protected-form> <cleanup-form*>)
;; @return the value of <protected-form>.
;; @location http://www.lispworks.com/documentation/HyperSpec/Body/s_unwind.htm
;; evaluates protected-form and guarantees that cleanup-forms are executed
;; before unwind-protect exits, whether it terminates normally or is
;; aborted by a control transfer of some kind.
(letex ((result (sym (uuid))))
(define-macro (unwind-protect )
(local (result)
(if (catch (eval (args 0)) 'result)
(begin (map eval (1 (args))) result)
(begin (map eval (1 (args))) (throw-error (5 result))))))
)
 
(define (call-with-iconv-descriptor proc fromcode tocode)
(let ((cd (iconv_open tocode fromcode)))
(if (= cd -1)
(error "iconv_open: %s" (last (sys-error))))
(unwind-protect
(proc cd)
(if (= (iconv_close cd) -1)
(error "iconv_close: %s" (last (sys-error)))))))
 
(if (= (& (sys-info -1) 0x100) 0x100) ; 64-bit?
(define void* "Lu")
(define void* "lu"))
 
(define (convert-1 cd inbuf)
(iconv cd 0 0 0 0)
(letn (;; source buffer
(src inbuf)
(**src (pack void* (address src)))
(src_len (length src))
(*src_len (pack void* src_len))
;; distribute buffer
;; FIXME: もうちょっと使い勝手の良いメモリ領域の確保ができるはず
(dst (dup "\000\000\000\000" (+ (* 2 src_len) 4)))
(**dst (pack void* (address dst)))
(dst_len (- (length dst) 1))
(*dst_len (pack void* dst_len))
result)
;; Do iconv convert
(setf result (iconv cd **src *src_len **dst *dst_len))
(if (= result -1)
(error "iconv: %s" (last (sys-error))))
;; NOTE: The converted string may contain null characters.
(slice dst 0 (- dst_len (first (unpack void* *dst_len))))))
 
;; @syntax (Iconv:convert <string> <fromcode> <tocode>)
;; @return Returns the converted string <fromcode> to <tocode>.
(define (convert str fromcode tocode)
"Convert string FROMCODE to TOCODE."
(call-with-iconv-descriptor (lambda (cd)
(convert-1 cd str))
(or fromcode newlisp-encoding)
(or tocode newlisp-encoding)))
 
;; @syntax (Iconv:encode <string> <tocode>)
;; @return Returns the converted string internal to <tocode>.
(define (encode str tocode)
"Convert string internal to TOCODE."
(convert str newlisp-encoding tocode))
 
;; @syntax (Iconv:decode <string> <fromcode>)
;; @return Returns the converted string <fromcode> to internal.
(define (decode str fromcode)
"Convert string FROMCODE to internal."
(convert str fromcode newlisp-encoding))
 
;; Shift_JIS
;; EUC-JP
;; ISO-2022-JP
;; UTF-8
;; ISO-8859-1
;; ISO-8859-15
;; WINDOWS-1252
 
(or (catch (Iconv:init) 'init-result)
(write 2 "WARNING: iconv.lsp initialize error\n"))
 
(context MAIN)
 
;;; EOF

Please sign in to comment on this gist.

Something went wrong with that request. Please try again.