tests/eucjp.impure.lisp

   1 (let ((p "eucjp-test.data")
   2       (eucjp "eucjp-test-eucjp.data")
   3       (utf8 "eucjp-test-utf8.data"))
   4
   5   ;; generate test data
   6   (with-open-file (in "eucjp-test.lisp-expr" :direction :input)
   7     (with-open-file (out-eucjp eucjp :direction :output
   8                                :element-type '(unsigned-byte 8)
   9                                :if-exists :supersede)
  10       (with-open-file (out-utf8 utf8 :direction :output
  11                                 :external-format :utf-8
  12                                 :if-exists :supersede)
  13         (do ((euc (read in nil) (read in nil))
  14              (ucs (read in nil) (read in nil))
  15              (i 0 (1+ i)))
  16             ((or (null euc) (null ucs)))
  17           ;; write EUC-JP data as binary
  18           (let ((out out-eucjp))
  19             (when (>= euc #x10000)
  20               (write-byte (ldb (byte 8 16) euc) out))
  21             (when (>= euc #x100)
  22               (write-byte (ldb (byte 8 8) euc) out))
  23             (write-byte (ldb (byte 8 0) euc) out)
  24             (when (= (mod i 32) 31)
  25               (write-byte #x0a out)))
  26           ;; trust UTF-8 external format
  27           (let ((out out-utf8))
  28             (write-char (code-char ucs) out)
  29             (when (= (mod i 32) 31)
  30               (write-char (code-char #x0a) out)))))))
  31
  32   ;; check if input works
  33   (with-open-file (in1 eucjp :direction :input
  34                        :external-format :euc-jp)
  35     (with-open-file (in2 utf8 :direction :input
  36                          :external-format :utf-8)
  37       (do ((c1 (read-char in1 nil) (read-char in1 nil))
  38            (c2 (read-char in2 nil) (read-char in2 nil)))
  39           ((and (null c1) (null c2)))
  40         (assert (eql c1 c2)))))
  41
  42   ;; check if output works
  43   (with-open-file (in utf8 :direction :input
  44                       :external-format :utf-8)
  45     (with-open-file (out p :direction :output
  46                          :external-format :euc-jp
  47                          :if-exists :supersede)
  48       (do ((c (read-char in nil) (read-char in nil)))
  49           ((null c))
  50         (write-char c out))))
  51   (with-open-file (in1 eucjp :direction :input
  52                        :element-type '(unsigned-byte 8))
  53     (with-open-file (in2 p :direction :input
  54                          :element-type '(unsigned-byte 8))
  55       (do ((b1 (read-byte in1 nil) (read-byte in1 nil))
  56            (b2 (read-byte in2 nil) (read-byte in2 nil)))
  57           ((and (null b1) (null b2)))
  58         (assert (eql b1 b2)))))
  59   (delete-file p)
  60   (delete-file eucjp)
  61   (delete-file utf8))
  62
  63 ;; check if string conversion works
  64 (with-open-file (in "eucjp-test.lisp-expr" :direction :input)
  65   (do ((euc (read in nil) (read in nil))
  66        (ucs (read in nil) (read in nil))
  67        (i 0 (1+ i)))
  68       ((or (null euc) (null ucs)))
  69     (let ((o (coerce (cond ((>= euc #x10000)
  70                             (list (ldb (byte 8 16) euc)
  71                                   (ldb (byte 8 8) euc)
  72                                   (ldb (byte 8 0) euc)))
  73                            ((>= euc #x100)
  74                             (list (ldb (byte 8 8) euc)
  75                                   (ldb (byte 8 0) euc)))
  76                            (t (list euc)))
  77                      '(vector (unsigned-byte 8))))
  78           (s (string (code-char ucs))))
  79       (assert (equal (octets-to-string o :external-format :euc-jp) s))
  80       (assert (equal (coerce (string-to-octets s :external-format :euc-jp)
  81                              'list)
  82                      (coerce o 'list))))))
  83 ;;; success
  84 (sb-ext:quit :unix-status 104)