source: project/release/4/charconv/trunk/charconv.scm @ 14774

Last change on this file since 14774 was 14774, checked in by Alex Shinn, 11 years ago

checking the result of iconv

File size: 22.4 KB
Line 
1;;;; charconv.scm -- encoding utils
2;;
3;; Copyright (c) 2004-2009 Alex Shinn
4;; All rights reserved.
5;;
6;; BSD-style license: http://www.debian.org/misc/bsd.license
7
8;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
9;; This module provides a convenience layer over top of the iconv
10;; module, as well as automatic detection of character encoding schemes.
11;; It implicitly assumes you are using UTF8 internally for your strings
12;; (you can use the 'utf8 module to change string semantics to use UTF8
13;; as well).  Given that, all you need to do is specify the external
14;; encoding you are working with.
15;;
16;; INPUT/OUTPUT PROCEDURES:
17;;
18;;   The following are direct analogs of the equivalent R5RS procedures:
19;;
20;;   - open-encoded-input-file FILE ENC
21;;   - call-with-encoded-input-file FILE ENC PROC
22;;   - with-input-from-encoded-file FILE ENC THUNK
23;;   - open-encoded-output-file FILE ENC
24;;   - call-with-encoded-output-file FILE ENC PROC
25;;   - with-output-to-encoded-file FILE ENC THUNK
26;;
27;;   Example:
28;;
29;;   (with-input-from-encoded-file "/usr/share/edict/edict" "EUC-JP"
30;;     read-line)
31;;
32;;   - read-encoded-string ENC [N [PORT]]
33;;
34;;   An anolog of read-string using byte-count (not character count).
35;;   May read additional bytes to ensure you read along a character
36;;   boundary.  If you really want exactly N bytes regardless of
37;;   character boundaries, you should combine read-string with
38;;   ces-convert below.
39;;
40;; UTILITY PROCEDURES:
41;;
42;;   The following are copied from the Gauche API.  CES stands for
43;;   Character Encoding Scheme.
44;;
45;;   - ces-equivalent? CES-A CES-B
46;;
47;;   Returns #t if CES-A and CES-B are equivalent (aliases), #f otherwise.
48;;
49;;   - ces-upper-compatible? CES-A CES-B
50;;
51;;   Returns #t if a string encoded in CES-B can be considered a string
52;;   in CES-A without conversion.
53;;
54;;   - ces-convert STR FROM [TO]
55;;
56;;   Return a new string of STR converted from encoding FROM to encoding
57;;   TO.
58;;
59;; DETECTION PROCEDURES:
60;;
61;;   - detect-file-encoding FILE [LOCALE]
62;;   - detect-encoding STRING [LOCALE]
63;;
64;;   The detection procedures can correctly identify most common 'types'
65;;   of encodings, such as UTF-8/16/32, EUC-*, ISO-2022-*, Shift_JIS or
66;;   single-byte, without any need for specifying the locale.  However,
67;;   currently it doesn't include any statistical or linguistic routines,
68;;   without which it can't distinguish between EUC-JP and EUC-KR, or
69;;   between any of the single-byte encodings (including ISO-8859-*).  In
70;;   these cases you can specify a locale, such that in the event of a
71;;   single-byte encoding a "de" locale would result in the default
72;;   German single-byte encoding, ISO-8859-1.
73;;
74;;  The detect-file-encoding procedure also recognizes the Emacs-style
75;;
76;;     -*- coding: foo -*-
77;;
78;;  signature in either of the first two lines.
79;;
80;;
81;; AUTOMATIC DETECTION:
82;;
83;;  You can also use the automatic detection implicitly in the input
84;;  procedures by specifying an encoding of "*" or "*<LOCALE>".  For
85;;  example,
86;;
87;;    (open-encoded-input-file file "*")    ; guess with no locale
88;;    (open-encoded-input-file file "*DE")  ; guess with a German locale
89;;
90;;  For compatibility with the Gauche convention, the encoding "*JP"
91;;  is equivalent to "*JA", the Japanese locale.
92;;
93;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
94
95(require-library regex iconv)
96
97(module charconv
98  (
99   make-encoded-input-port make-encoded-output-port
100   open-encoded-input-file open-encoded-output-file
101   with-input-from-encoded-file with-output-to-encoded-file
102   call-with-encoded-input-file call-with-encoded-output-file
103   detect-encoding detect-file-encoding
104   ces-equivalent? ces-upper-compatible? ces-convert
105   #;ces-converted-length
106   read-encoded-string
107   )
108
109(import scheme chicken extras regex ports posix srfi-69 iconv)
110
111;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
112;; high-level interface
113
114(define (open-encoded-input-file file enc)
115  (if (and enc (eqv? (string-ref enc 0) #\*))
116    (let* ((lang1 (and (>= (string-length enc) 3)
117                       (string (char-downcase (string-ref enc 1))
118                               (char-downcase (string-ref enc 2)))))
119           (lang (if (equal? lang1 "jp") "ja" lang1)))
120      (make-encoded-input-port (open-input-file file)
121                               (or (detect-file-encoding file lang) "UTF8")))
122    (make-encoded-input-port (open-input-file file) enc)))
123
124(define (with-input-from-encoded-file file enc thunk)
125  (let* ((in (open-encoded-input-file file enc))
126         (res (with-input-from-port in thunk)))
127    (close-input-port in)
128    res))
129
130(define (call-with-encoded-input-file file enc proc)
131  (let* ((in (open-encoded-input-file file enc))
132         (res (proc in)))
133    (close-input-port in)
134    res))
135
136(define (open-encoded-output-file file enc)
137  (make-encoded-output-port (open-output-file file) enc))
138
139(define (with-output-to-encoded-file file enc thunk)
140  (call-with-output-file file
141    (lambda (out)
142      (with-output-to-port (make-encoded-output-port out enc) thunk))))
143
144(define (call-with-encoded-output-file file enc proc)
145  (call-with-output-file file
146    (lambda (out)
147      (proc (make-encoded-output-port out enc)))))
148
149
150;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
151;; low-level encoding ports
152
153;; Padding
154;;   We read a block of text at a time and feed it to iconv, but for
155;;   variable-byte encodings such as sjis and euc the block isn't
156;;   guaranteed to be on a character boundary, so we check and read
157;;   extra characters until we're sure we're on a valid boundary.  This
158;;   is potentially very slow in pathological cases (in practice we'll
159;;   usually hit a newline if nothing else) so it should be replaced by
160;;   internal state buffering in the iconv routines.
161
162(define (pad-sjis-input str in)
163  (define (starter? ch)
164    (or (<= #x80 (char->integer ch) #x9F)
165        (<= #xE0 (char->integer ch) #xFC)))
166  (let ((len (string-length str)))
167    (if (or (zero? len) (not (starter? (string-ref str (- len 1)))))
168      str
169      (let ((rest
170             (let lp ((acc '()))
171               (let ((ch (read-char in)))
172                 (cond
173                   ((eof-object? ch) acc)
174                   ((not (starter? ch)) (cons ch acc))
175                   (else (lp (cons ch acc))))))))
176        (if (pair? rest)
177          (string-append str (list->string (reverse)))
178          str)))))
179
180(define (pad-euc-input str in)
181  (define (multi? ch)
182    (<= #xA0 (char->integer ch) #xFE))
183  (let ((len (string-length str)))
184    (if (or (zero? len) (<= (char->integer (string-ref str (- len 1))) #x7F))
185      str
186      (let ((rest
187             (let lp ((acc '()))
188               (let ((ch (read-char in)))
189                 (cond
190                   ((eof-object? ch) acc)
191                   ((<= #x8E (char->integer ch) #x8F)
192                    (let* ((ch2 (read-char in)) (ch3 (read-char in)))
193                      (if (eof-object? ch3)
194                        (cons ch acc)
195                        (cons ch3 (cons ch2 (cons ch acc))))))
196                   ((<= (char->integer ch) #x7F) (cons ch acc))
197                   (else (lp (cons ch acc))))))))
198        (if (pair? rest)
199          (string-append str (list->string (reverse rest)))
200          str)))))
201
202(define (encoded-input-port-padder enc)
203  (cond
204    ((string-ci=? enc "SHIFT_JIS") pad-sjis-input)
205    ((string-ci=? enc "EUC-JP") pad-euc-input)
206    (else #f)))
207
208(define (make-encoded-input-port in enc)
209  (if (or (not enc) (string-ci=? enc "UTF8") (string-ci=? enc "ASCII"))
210    in
211    (let ((cd (iconv-open "UTF8" enc))
212          (buf "")
213          (pad (or (encoded-input-port-padder enc) (lambda (str in) str)))
214          (size 0)
215          (off 0))
216      (if (not cd)
217          (error "unknown encoding" enc)
218          (make-input-port
219           (lambda ()
220             (if (>= off size)
221                 (let ((str (pad (read-string 1024 in) in)))
222                   (set! buf (iconv cd str))
223                   (set! size (string-length buf))
224                   (set! off 0)))
225             (if (>= off size)
226                 #!eof
227                 (let ((ch (string-ref buf off)))
228                   (set! off (+ off 1))
229                   ch)))
230           (lambda () (or (< off size) (char-ready? in)))
231           (lambda () (close-input-port in)))))))
232
233(define (make-encoded-output-port out enc)
234  (if (or (not enc) (string-ci=? enc "UTF8"))
235    out
236    (let ((cd (iconv-open enc "UTF8")))
237      (if (not cd)
238          (error "unknown encoding" enc)
239          (make-output-port
240           (lambda (str) (display (iconv cd str) out))
241           (lambda () (close-output-port out))
242           (lambda () (flush-output out)))))))
243
244
245;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
246;; utilities
247
248(define (string-upcase str)
249  (let* ((len (string-length str))
250         (str2 (make-string len)))
251    (do ((i 0 (+ i 1)))
252        ((= i len) str2)
253      (string-set! str2 i (char-upcase (string-ref str i))))))
254
255;; this should match iconv (or whatever the backend converter is) as
256;; closely as possible
257(define ces-normalize-name
258  (let ((aliases (make-hash-table string=?)))
259    (for-each
260     (lambda (ls)
261       (for-each
262        (cute hash-table-set! aliases <> (car ls))
263        (cdr ls)))
264     '(("UTF8" "UTF-8")
265       ("ISO-8859-1" "LATIN-1")
266       ("SHIFT_JIS" "SJIS" "SHIFTJIS" "SHIFT-JIS")
267       ("EUC-JP" "EUCJP" "EUC_JP")
268       ))
269    (lambda (str)
270      (let ((str2 (string-upcase str)))
271        (hash-table-ref/default aliases str2 str2)))))
272
273(define (%ces-upper-compatible? a b)
274  (cond
275    ((not b) #t)
276    ((string=? b "UTF8") (string=? a "UTF8"))
277    ((string=? b "ASCII") (not (member a '("UTF16" "UTF32"))))
278    (else #f)))
279
280(define (ces-upper-compatible? a b)
281  (%ces-upper-compatible? (ces-normalize-name a) (ces-normalize-name b)))
282
283(define (ces-equivalent? a b)
284  (string=? (ces-normalize-name a) (ces-normalize-name b)))
285
286(define (ces-convert str from . o)
287  (let ((to (or (and (pair? o) (car o)) "UTF8")))
288    (if (ces-upper-compatible? to from)
289      str
290      (let ((cd (iconv-open to from)))
291        (if (not cd)
292            (error "ces-convert: unsupported conversion" to from)
293            (iconv cd str))))))
294
295(define (read-encoded-string enc1 . o)
296  (let-optionals* o ((n #f) (port (current-input-port)))
297    (let ((enc (ces-normalize-name enc1)))
298      (if n
299        (let* ((padder (encoded-input-port-padder enc))
300               (str1 (read-string n port))
301               (str (if padder (padder str1 port) str1)))
302          (if enc
303            (ces-convert str enc "UTF8")
304            str))
305        (ces-convert (read-string #f port) enc1 "UTF8")))))
306
307
308;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
309;; automatic encoding detection
310
311;; When should we use ISO-8859-15?
312(define *8-bit-encodings*
313  '(("af" . "ISO-8859-1")  ; Afrikans
314    ("ca" . "ISO-8859-1")  ; Catalan
315    ("da" . "ISO-8859-1")  ; Danish
316    ("de" . "ISO-8859-1")  ; German
317    ("en" . "ISO-8859-1")  ; English
318    ("eu" . "ISO-8859-1")  ; Basque
319    ("fi" . "ISO-8859-1")  ; Finish
320    ("fr" . "ISO-8859-1")  ; French
321    ("fo" . "ISO-8859-1")  ; Faroese
322    ("ga" . "ISO-8859-1")  ; Irish
323    ("gd" . "ISO-8859-1")  ; Scottish
324    ("it" . "ISO-8859-1")  ; Italian
325    ("is" . "ISO-8859-1")  ; Icelandic
326    ("nl" . "ISO-8859-1")  ; Dutch
327    ("no" . "ISO-8859-1")  ; Norwegian
328    ("pt" . "ISO-8859-1")  ; Portugese
329    ("rm" . "ISO-8859-1")  ; Rhaeto-Romanic
330    ("sq" . "ISO-8859-1")  ; Albanian
331    ("sw" . "ISO-8859-1")  ; Swahili
332    ("cs" . "ISO-8859-2")  ; Czech
333    ("hu" . "ISO-8859-2")  ; Hungarian
334    ("pl" . "ISO-8859-2")  ; Polish
335    ("ro" . "ISO-8859-2")  ; Romanian
336    ("hr" . "ISO-8859-2")  ; Hungarian
337    ("sk" . "ISO-8859-2")  ; Slovak
338    ("sl" . "ISO-8859-2")  ; Slovenian
339    ("eo" . "ISO-8859-3")  ; Esperanto
340    ("mt" . "ISO-8859-3")  ; Maltese
341    ("et" . "ISO-8859-4")  ; Estonian
342    ("lv" . "ISO-8859-4")  ; Latvian
343    ("lt" . "ISO-8859-4")  ; Lithuanian
344    ("kl" . "ISO-8859-4")  ; Greenlandic
345    ("bg" . "ISO-8859-5")  ; Bulgarian
346    ("be" . "ISO-8859-5")  ; Byelorussian
347    ("mk" . "ISO-8859-5")  ; Macedonian
348    ("ru" . "ISO-8859-5")  ; Russian
349    ("sr" . "ISO-8859-5")  ; Serbian
350    ("uk" . "ISO-8859-5")  ; Ukranian
351    ("ar" . "ISO-8859-6")  ; Arabic
352    ("fa" . "ISO-8859-6")  ; Persian
353    ("ur" . "ISO-8859-6")  ; Urdu
354    ("el" . "ISO-8859-7")  ; Greek
355    ("iw" . "ISO-8859-8")  ; Hebrew
356    ("ji" . "ISO-8859-8")  ; Yiddish
357    ("tr" . "ISO-8859-9")  ; Turkish
358    ("th" . "TIS620")      ; Thai
359    ("vi" . "VISCII")      ; Vietnamese
360    ("cy" . "ISO-8859-14") ; Welsh
361    ))
362
363(define *euc-encodings*
364  '(("zh" . "GB2312")      ; Chinese
365    ("ja" . "EUC-JP")      ; Japanese
366    ("kr" . "EUC-KR")      ; Korean
367    ))
368
369(define *shift-encodings*
370  '(("ja" . "SHIFT_JIS")   ; Japanese
371    ))
372
373(define *iso-encodings*
374  '(("ja" . "ISO-2022-JP") ; Japanese
375    ("kr" . "ISO-2022-KR") ; Korean
376    ))
377
378(define (detect-8-bit-encoding str)
379  "ISO-8859-1")
380
381(define (detect-euc-encoding str)
382  "EUC-JP")
383
384(define (detect-shift-encoding str)
385  "SHIFT_JIS")
386
387(define (detect-iso-encoding str)
388  "ISO-2022-JP")
389
390(define (detect-locale-encoding str enc-type lang)
391  (define (string-downcase! s)
392    (do ((i (- (string-length s) 1) (- i 1)))
393        ((< i 0) s)
394      (let ((c (char->integer (string-ref s i))))
395        (if (<= 65 c 90)
396          (string-set! s i (integer->char (+ c 32)))))))
397  (define (string-index s c)
398    (let ((limit (string-length s)))
399      (let lp ((i 0))
400        (cond ((= i limit) #f)
401              ((eqv? (string-ref s i) c) i)
402              (else (lp (+ i 1)))))))
403  (define (normalize1 lang)
404    (and lang
405         (cond ((string-index lang #\.) => (lambda (i) (substring lang 0 i)))
406               (else lang))))
407  (define (normalize2 lang)
408    (and lang
409         (cond ((string-index lang #\_) => (lambda (i) (substring lang 0 i)))
410               (else lang))))
411  (let ((lang (and lang (string-downcase! lang))))
412    (case enc-type
413      ((BINARY) #f)
414      ((7-BIT) "ASCII")
415      ((8-BIT)
416       (cond ((assoc lang *8-bit-encodings*) => cdr)
417             ((assoc (normalize1 lang) *8-bit-encodings*) => cdr)
418             ((assoc (normalize2 lang) *8-bit-encodings*) => cdr)
419             (else (detect-8-bit-encoding str))))
420      ((EUC)
421       (cond ((assoc lang *euc-encodings*) => cdr)
422             ((assoc (normalize1 lang) *euc-encodings*) => cdr)
423             ((assoc (normalize2 lang) *euc-encodings*) => cdr)
424             (else (detect-euc-encoding str))))
425      ((SHIFT)
426       (cond ((assoc lang *shift-encodings*) => cdr)
427             ((assoc (normalize1 lang) *shift-encodings*) => cdr)
428             ((assoc (normalize2 lang) *shift-encodings*) => cdr)
429             (else (detect-shift-encoding str))))
430      ((ISO-2022)
431       (cond ((assoc lang *iso-encodings*) => cdr)
432             ((assoc (normalize1 lang) *iso-encodings*) => cdr)
433             ((assoc (normalize2 lang) *iso-encodings*) => cdr)
434             (else (detect-iso-encoding str))))
435      ((UTF-8 UTF-16LE UTF-16BE UTF-32LE UTF-32BE)
436       (symbol->string enc-type))
437      ((UTF-16 UTF-32)
438       (string-append (symbol->string enc-type)
439                      (if (memv (machine-type) '(x86 x86-64)) "LE" "BE")))
440      (else (error "unknown encoding type" enc-type)))))
441
442;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
443;; encoding types (<ESC> == 0x1B)
444;;
445;; ASCII: absence of zeros or high-bit characters, no locale
446;; UTF-7: can only be distinguished from ASCII statistically
447;; UTF-8: absence of malformed UTF-8 (common in other encodings), no locale
448;; UTF-16/32-le/be: easily determined by presence of zeros, no locale
449;; ISO-2022: use of escape sequences, locale-dependent
450;;         -KR: stream starts w/ <Esc>$)C then 0x0E ...escaped 7-bit... 0x0F
451;;         -JP: <Esc>$B ...escaped 7-bit... <Esc>(J
452;; ISO-8859/TIS-620: not ASCII, no byte pattern
453;; EUC-CN/KR: ASCII + [A1-FE][A1-FE]
454;; EUC-JP: ASCII + 8E[A1-DF] + [A1-FE][A1-FE] + 8F[A1-FE][A1-FE], locale-dependent (CJK)
455;; SJIS: ASCII + [A1-DF] + [81-9F,E0-FC][40-7E,80-FC], Japanese
456;; BIG5: ASCII + [A1-FE][40-7E,A1-FE], Chinese
457;; GB2312 (== EUC-CN?) : ASCII + [A0-F7][A0-FE], Chinese
458;; GBK: ASCII + [81-FE][40-7E,80-FE], Chinese
459;; HZ (han4zi4) : ASCII + ~{(GB|[B0-F7][A0-FE])...~} ???, Chinese
460;; UHC (Unified Hangul Code): ASCII + [81-FE][41-5A,61-7A,81-FE], Korean
461
462;; There is very little overlap in different encoding types, so rather
463;; than a data-driven state-machine or statistical methods we just
464;; code the states directly, which is fast and uses very little
465;; memory, but doesn't help distinguish between the single-byte 8-bit
466;; encodings.  To address this we'll need to use statistical analysis
467;; to detect between languages.  Hopefully, though, UTF-8 is replacing
468;; most uses of the old 8-bit encodings.
469
470(define-syntax make-detect-state-machine
471  (lambda (expr rename compare)
472    (apply
473     (lambda (next limit i c . states)
474       (define (expand-clauses ls)
475         (let lp ((ls ls) (res '()))
476           (if (null? ls)
477               (reverse res)
478               (let ((check (car ls))
479                     (state (caddr ls)))
480                 (case (cadr ls)
481                   ((-->)
482                    (lp (cdddr ls) (cons `(,check ,state) res)))
483                   ((->)
484                    (if (and (pair? (cdddr ls)) (number? (cadddr ls)))
485                        (lp (cddddr ls)
486                            (cons `(,check
487                                    (,state (,(rename '+) ,i ,(cadddr ls))))
488                                  res))
489                        (lp (cdddr ls)
490                            (cons `(,check (,state (,(rename '+) ,i 1))) res))))
491                   (else (error "invalid state machine: " ls)))))))
492       (define (make-state ls)
493         (let ((name (car ls))
494               (final (cadr ls)))
495           `(,(rename 'define) (,name ,i)
496             (,(rename 'if) (,(rename '>=) ,i ,limit)
497              ,final
498              (,(rename 'let) ((,c (,next i)))
499               (,(rename 'cond)
500                ,@(expand-clauses (cddr ls))))))))
501       `(,(rename 'begin) ,@(map make-state states)))
502     (cdr expr))))
503
504(define (detect-encoding-type str)
505  (let ((limit (string-length str))
506        (maybe-iso? #f))
507    (define (next i)
508      (char->integer (string-ref str i)))
509    (define (bom-FE i)
510      (if (and (even? i)
511               (or (= (+ i 1) limit) (= (next (+ i 1)) #xFF)))
512        (if (and (< (+ i 3) limit)
513                 (zero? (next (+ i 2)))
514                 (zero? (next (+ i 3))))
515          'UTF-32BE
516          'UTF-16BE)
517        (euc-2 (+ i 1))))
518    (define (bom-FF i)
519      (if (and (even? i) (or (>= (+ i 1) limit) (= (next (+ i 1)) #xFE)))
520        (if (and (< (+ i 3) limit)
521                 (zero? (next (+ i 2)))
522                 (zero? (next (+ i 3))))
523          'UTF-32LE
524          'UTF-16LE)
525        (wide-or-8bit (+ i 1))))
526    ;; expand the states
527    (make-detect-state-machine
528     next limit i c
529     ;; syntax:
530     ;;   state final-result
531     ;;     test -> next-state [offset]
532     ;;     test --> expr
533     (escape '7-BIT
534       (memv c '(36 40)) --> (begin (set! maybe-iso? #t) (any (+ i 1)))
535       else -> any)
536     (any (if maybe-iso? 'ISO-2022 '7-BIT)
537       (zero? c)  -> null
538       (= c #x1B) -> escape
539       (< c #x80) -> any
540       (< c #x8E) -> shift-2
541       (= c #x8E) -> euc-8E
542       (= c #x8F) -> euc-8F
543       (< c #xA0) -> shift-2
544       (< c #xC0) -> euc/shift-2
545       (< c #xD0) -> utf8-2-2nd
546       (< c #xF0) -> utf8-3-2nd
547       (< c #xFD) -> euc/shift-2
548       (= c #xFD) -> euc-2
549       (= c #xFE) -> bom-FE 0
550       else       -> bom-FF 0)
551     (shift-2 'SHIFT
552       (or (<= #x40 c #x7E) (<= #x80 c #xFC)) -> shift
553       else -> wide-or-8bit 0)
554     (shift 'SHIFT
555       (zero? c) -> null
556       (or (< c #x80) (<= #xA0 c #xDF)) -> shift
557       (<= #x80 c #xFC) -> shift-2
558       else -> wide-or-8bit 0)
559     (euc-8E 'EUC
560       (<= #xA1 c #xDF) -> euc/shift
561       else -> shift-2 0)
562     (euc-8F 'EUC
563       (and (<= #xA1 c #xFE) (<= #xA1 (next (+ i 1)) #xFE)) -> euc/shift
564       else -> shift-2 0)
565     (euc/shift 'EUC
566       (zero? c)  -> null
567       (< c #x80) -> euc/shift
568       (< c #x8E) -> shift-2
569       (= c #x8E) -> euc-8E
570       (= c #x8F) -> euc-8F
571       (< c #xA0) -> shift-2
572       (< c #xC0) -> euc/shift-2
573       (< c #xFD) -> euc/shift-2
574       (= c #xFD) -> euc-2
575       else       -> wide-or-8bit 0)
576     (euc/shift-2 'EUC
577       (<= #xA1 c #xFC) -> euc/shift
578       (<= #xFD c #xFE) -> euc
579       (or (<= #x40 c #x7E) (<= #x80 c #xA0)) -> shift
580       else -> wide-or-8bit 0)
581     (euc 'EUC
582       (zero? c)  -> null
583       (< c #x80) -> euc
584       (= c #x8E) -> euc-8E
585       (= c #x8F) -> euc-8F
586       (<= #xA0 c #xFE) -> euc-2
587       else -> wide-or-8bit 0)
588     (euc-2 'EUC
589       (<= #xA1 c #xFE) -> euc
590       else -> wide-or-8bit 0)
591     (utf8 'UTF-8
592       (zero? c)  -> null
593       (< c #x80) -> utf8
594       (< c #xC0) -> euc/shift 0
595       (< c #xE0) -> utf8-2-2nd
596       (< c #xF0) -> utf8-3-2nd
597       else       -> euc/shift 0)
598     (utf8-2-2nd 'UTF-8
599       (>= c #x80) -> utf8
600       else -> euc/shift 0)
601     (wide-or-8bit '8-BIT
602       (zero? c) -> null
603       else      -> wide-or-8bit)
604     (wide 'UTF-16
605       (zero? c) -> null
606       else      -> wide)
607     (null 'UTF-16
608       (zero? c) -> null2
609       else      -> wide)
610     (null2 (if (even? i) 'UTF-32 'UTF-16)
611       (zero? c) -> null3
612       (and (even? i) (< (+ i 1) limit) (= #xFE c) (= #xFF (next (+ i 1))))
613            --> 'UTF32BE
614       else -> wide)
615     (utf8-3-2nd 'UTF-8
616       (>= c #x80) -> utf8-3-3rd
617       else -> euc/shift 0)
618     (utf8-3-3rd 'UTF-8
619       (>= c #x80) -> utf8
620       else -> euc/shift -1)
621     (null3 'UTF-32
622       (zero? c) --> 'BINARY
623       else -> utf32)
624     (utf32 'UTF-32
625       else --> 'UTF-32)
626     )
627    ;; could be any to start
628    (any 0)))
629
630(define (detect-encoding str . o)
631  (let ((type (detect-encoding-type str)))
632    (detect-locale-encoding str type (if (pair? o) (car o) "*"))))
633
634(define detect-file-encoding
635  (let ((rx (regexp "^(?:[^\n]*\n)?[^\n]*-\\*-[^\n]*\\bcoding:\\s*\\b(\\S+)\\b[^\n]*-\\*-" #t))
636        (cache (make-hash-table string=?)))
637    (lambda (file . o)
638      (let* ((fullname file)
639             (last (hash-table-ref/default cache fullname #f)))
640        (if (and last (>= (cdr last) (file-modification-time fullname)))
641          (car last)
642          (let ((str (with-input-from-file file (cut read-string 1024))))
643            (let ((res
644                   (cond
645                    ((string-match rx str) => cadr)
646                    (else (apply detect-encoding str o)))))
647              (hash-table-set! cache fullname (cons res (current-seconds)))
648              res)))))))
649
650)
Note: See TracBrowser for help on using the repository browser.