tests/ucs-4be.pure.lisp

   1 ;;;; This file is for testing external-format functionality for
   2 ;;;; big-endian UCS-4, using test machinery which does not have
   3 ;;;; side effects.  Note that the tests here reach into unexported
   4 ;;;; functionality, and should not be used as a guide for users.
   5
   6 ;;;; This software is part of the SBCL system. See the README file for
   7 ;;;; more information.
   8 ;;;;
   9 ;;;; While most of SBCL is derived from the CMU CL system, the test
  10 ;;;; files (like this one) were written from scratch after the fork
  11 ;;;; from CMU CL.
  12 ;;;;
  13 ;;;; This software is in the public domain and is provided with
  14 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
  15 ;;;; more information.
  16
  17 #-sb-unicode (invoke-restart 'run-tests::skip-file)
  18
  19 (defvar *test-path* (scratch-file-name))
  20
  21 (macrolet ((input-test (inxf expected &environment env)
  22              `(progn
  23                 (with-test (:name (,(macroexpand 'name env) :file ,inxf))
  24                   (with-open-file (s *test-path* :external-format ',inxf)
  25                     (handler-bind ((sb-int:character-decoding-error
  26                                     (lambda (c) (use-value "" c))))
  27                       (let* ((string (make-string 20))
  28                              (count (read-sequence string s)))
  29                         (assert (equal (map 'list 'identity (subseq string 0 count)) ,expected))))))
  30                 (with-test (:name (,(macroexpand 'name env) :octets ,inxf))
  31                   (handler-bind ((sb-int:character-decoding-error
  32                                   (lambda (c) (use-value "" c))))
  33                     (let ((octets (coerce bytes '(simple-array (unsigned-byte 8) 1))))
  34                       (assert (equal (sb-ext:octets-to-string octets :external-format ',inxf)
  35                                      (coerce ,expected 'string))))))))
  36            (with-input-bytes ((id bytes) &body body)
  37              `(let ((bytes ,bytes))
  38                 (with-open-file (s *test-path* :element-type '(unsigned-byte 8)
  39                                    :direction :output :if-exists :supersede)
  40                   (dolist (byte bytes)
  41                     (write-byte byte s)))
  42                 (symbol-macrolet ((name ,id))
  43                   (macrolet ((test (inxf expected)
  44                                `(input-test ,inxf ,expected)))
  45                     ,@body)))))
  46   (with-input-bytes ((:input :invalid) (list #x00 #x00 #x00 #x35
  47                                              #xff #xff #xff #xff
  48                                              #x00 #x00 #x00 #x37))
  49     (test :ucs-4be '(#\5 #\7))
  50     (test (:ucs-4be :replacement #\?) '(#\5 #\? #\7)))
  51   (with-input-bytes ((:input :multiple-invalid) (list #x00 #x00 #x00 #x35
  52                                                       #xff #xff #xff #xff
  53                                                       #xff #xff #xff #xff
  54                                                       #x00 #x00 #x00 #x37))
  55     (test :ucs-4be '(#\5 #\7))
  56     (test (:ucs-4be :replacement #\?) '(#\5 #\? #\? #\7)))
  57   (with-input-bytes ((:input :invalid-units1) (list #x00 #x00 #x00 #x35
  58                                                     #x00))
  59     (test :ucs-4be '(#\5))
  60     (test (:ucs-4be :replacement #\?) '(#\5 #\?)))
  61   (with-input-bytes ((:input :invalid-units2) (list #x00 #x00 #x00 #x35
  62                                                     #x00 #x00))
  63     (test :ucs-4be '(#\5))
  64     (test (:ucs-4be :replacement #\?) '(#\5 #\?)))
  65   (with-input-bytes ((:input :invalid-units3) (list #x00 #x00 #x00 #x35
  66                                                     #x00 #x00 #x00))
  67     (test :ucs-4be '(#\5))
  68     (test (:ucs-4be :replacement #\?) '(#\5 #\?)))
  69   (with-input-bytes ((:input :invalid-then-invalid-units1) (list #xff #xff #xff #xff
  70                                                                  #x00))
  71     (test :ucs-4be '())
  72     (test (:ucs-4be :replacement #\?) '(#\? #\?))))