source: project/release/4/iconv/trunk/iconv.scm @ 15881

Last change on this file since 15881 was 15881, checked in by Ivan Raikov, 11 years ago

iconv uses foreign instead of foreigners

File size: 2.9 KB
Line 
1;; This file is in the public domain and may be reproduced or copied without
2;; permission from its author.  Citation of the source is appreciated.
3;;
4;; Alejandro Forero Cuervo <bachue@bachue.com>
5;;
6;; This file implements an egg for Chicken Scheme that allows conversion of
7;; multi-byte sequences from one character set (encoding) to another by means
8;; of the iconv functionality present in glibc.
9;;
10;; Documentation is available in HTML format.
11;;
12;; Version: 1.6
13;;
14;; Newer versions might be available at:
15;;
16;;    http://anonymous:@afc.no-ip.info:8000/svn/home/src/chicken-eggs/iconv
17
18(define-external (iconv_build_result (int len)) scheme-object
19  (make-string len))
20
21(module iconv
22  (iconv-open iconv)
23
24(import scheme chicken extras foreign)
25
26(declare (foreign-declare "#include <iconv.h>\n#include <errno.h>\n"))
27
28(define iconv-open-inner
29  (foreign-lambda* c-pointer ((c-string tocode) (c-string fromcode))
30    "iconv_t result = iconv_open(tocode, fromcode);"
31    "return(result == (iconv_t) -1 ? NULL : result);"))
32
33(define (iconv-open tocode fromcode)
34  (and-let* ((value (iconv-open-inner tocode fromcode)))
35    (set-finalizer! value (foreign-lambda void "iconv_close" c-pointer))
36    value))
37
38(define iconv
39  (case-lambda
40    ((cd src) (iconv cd src "?"))
41    ((cd src invalid) (iconv cd src invalid (* (string-length src) 2)))
42    ((cd src invalid dstlen) (iconv-real cd src invalid dstlen))))
43
44(define iconv-real
45  (foreign-safe-lambda* scheme-object ((nonnull-c-pointer cd)
46                                       (scheme-object srco)
47                                       (scheme-object invalido)
48                                       (int bufsize)) #<<EOF
49  C_word result;
50  size_t srclen = C_header_size(srco), left;
51  char *src = C_c_string(srco), *buffer = NULL, *dst = buffer, *tmp;
52  int resize = 1;
53
54  do
55    {
56      if (resize)
57        {
58          bufsize *= buffer ? 2 : 1;
59          tmp = realloc(buffer, bufsize);
60          if (!tmp)
61            {
62              free(buffer);
63              return(C_SCHEME_FALSE);
64            }
65          dst = tmp + (dst - buffer);
66          buffer = tmp;
67          resize = 0;
68        }
69
70      left = buffer + bufsize - dst;
71      if (iconv((iconv_t) cd, (const char* *) &src, &srclen, &dst, &left) == -1)
72        switch (errno)
73          {
74          case E2BIG:
75            resize = 1;
76            break;
77          case EILSEQ:
78          case EINVAL:
79            if (dst + C_header_size(invalido) > buffer + bufsize)
80              resize = 1;
81            else
82              {
83                C_memcpy(dst, C_c_string(invalido), C_header_size(invalido));
84                dst += C_header_size(invalido);
85                src ++;
86                srclen --;
87              }
88            break;
89          default:
90            return(C_SCHEME_FALSE);
91          }
92    }
93  while (srclen > 0);
94
95  left = dst - buffer;
96  result = iconv_build_result(left);
97  C_memcpy(C_c_string(result), buffer, left);
98  free(buffer);
99  return(result);
100EOF
101))
102
103)
Note: See TracBrowser for help on using the repository browser.