tests/streams.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; indent-tabs-mode: nil -*-
   2 ;;;
   3 ;;; --- IO.STREAMS test suite.
   4 ;;;
   5 ;;; Copyright (c) 2006-2007, Dr. Edmund Weitz.  All rights reserved.
   6 ;;; Copyright (c) 2007, Luis Oliveira  <loliveira@common-lisp.net>
   7 ;;;
   8 ;;; Redistribution and use in source and binary forms, with or without
   9 ;;; modification, are permitted provided that the following conditions
  10 ;;; are met:
  11 ;;;
  12 ;;;   * Redistributions of source code must retain the above copyright
  13 ;;;     notice, this list of conditions and the following disclaimer.
  14 ;;;
  15 ;;;   * Redistributions in binary form must reproduce the above
  16 ;;;     copyright notice, this list of conditions and the following
  17 ;;;     disclaimer in the documentation and/or other materials
  18 ;;;     provided with the distribution.
  19 ;;;
  20 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
  21 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
  22 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  23 ;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
  24 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
  25 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
  26 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
  27 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
  28 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
  29 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
  30 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  31
  32 (in-package :iolib-tests)
  33
  34 (in-suite* :io.streams :in :iolib)
  35
  36 (defclass my-file-stream (dual-channel-single-fd-gray-stream)
  37   ((path :initarg :path :reader file-stream-path)))
  38
  39 (defmethod close :around ((file my-file-stream) &key abort)
  40   (declare (ignore abort))
  41   (call-next-method)
  42   (when (fd-of file)
  43     (nix:close (fd-of file)))
  44   (setf (fd-of file) nil))
  45
  46 ;;; Very ad-hoc: doesn't do :DIRECTION :PROBE, or handle errors,
  47 ;;; :IF-DOES-NOT-EXIST, among many other things.  This kind of thing
  48 ;;; should be moved into OSICAT, btw.
  49 ;;;
  50 ;;; FIXME: implement single-channel stream
  51 (defun make-file-stream (path &key
  52                          (direction :input)
  53                          (if-exists :error)
  54                          (if-does-not-exist (ecase direction
  55                                               (:input :error)
  56                                               ((:io :output) :create)))
  57                          (external-format :default))
  58   (declare (ignore if-does-not-exist))
  59   ;; move OPEN to INITIALIZE-INSTANCE
  60   (let ((fd (nix:open path
  61                       (logior (ecase direction
  62                                 (:input nix:o-rdonly)
  63                                 (:output (logior nix:o-creat nix:o-wronly))
  64                                 (:io (logior nix:o-creat nix:o-rdwr)))
  65                               (ecase if-exists
  66                                 (:error nix:o-excl)
  67                                 (:supersede nix:o-trunc)
  68                                 (:append nix:o-append)
  69                                 (:overwrite 0)))
  70                       (logior nix:s-irusr nix:s-iwusr))))
  71     (make-instance 'my-file-stream
  72                    :path path
  73                    :input-fd fd
  74                    :output-fd fd
  75                    :external-format external-format)))
  76
  77 (defmacro with-open-file-stream ((var path &rest options) &body body)
  78   (with-gensyms (stream)
  79     `(let ((,stream (make-file-stream ,path ,@options)))
  80        (with-open-stream (,var ,stream)
  81          ,@body))))
  82
  83 (defvar *data-dir*
  84   (let ((sys-pn (truename (asdf:system-definition-pathname
  85                            (asdf:find-system 'iolib-tests)))))
  86     (make-pathname :directory (append (pathname-directory sys-pn)
  87                                       '("tests" "data")))))
  88
  89 (defvar *test-dir*
  90   (ensure-directories-exist
  91    (merge-pathnames
  92     (make-pathname :directory '(:relative "test-dir"))
  93     (make-pathname :directory
  94                    (pathname-directory
  95                     (or *load-truename* *compile-file-truename*))))))
  96
  97 ;;; A list of test files where each entry consists of the name
  98 ;;; prefix and a list of encodings.
  99 (defvar *test-files*
 100   '(("kafka" (:utf-8 :latin-1 #|:cp1252|#))
 101     ("tilton" (:utf-8 :ascii))
 102     ("hebrew" (:utf-8 #|:latin-8|#))
 103     ("russian" (:utf-8 #|:koi8r|#))
 104     ("unicode_demo" (:utf-8 #|:utf-16 :utf-32|#))))
 105
 106 ;;; For a name suffix FILE-NAME and a symbol SYMBOL denoting an
 107 ;;; encoding returns a list of pairs where the car is a full file name
 108 ;;; and the cdr is the corresponding external format.  This list
 109 ;;; contains all possible line-end conversions.
 110 (defun create-file-variants (file-name symbol)
 111   (loop :for eol-style :in '(:lf :cr :crlf) :collect
 112         (cons (format nil "~A_~(~A~)_~(~A~).txt"
 113                       file-name symbol eol-style)
 114               (babel:make-external-format symbol :eol-style eol-style))))
 115
 116 ;;; For a name suffix FILE-NAME and a list of symbols SYMBOLS denoting
 117 ;;; different encodings of the corresponding file returns a list of
 118 ;;; lists which can be used as arglists for COMPARE-FILES.
 119 (defun create-test-combinations (file-name symbols)
 120   (let ((file-variants (loop :for symbol :in symbols
 121                              :nconc (create-file-variants file-name symbol))))
 122     (loop :for (name-in . external-format-in) :in file-variants
 123           :nconc (loop :for (name-out . external-format-out) :in file-variants
 124                        :collect (list name-in external-format-in
 125                                       name-out external-format-out)))))
 126
 127 ;;; Returns a true value iff FILE1 and FILE2 have the same contents
 128 ;;; (viewed as binary files).
 129 (defun file-equal (file1 file2)
 130   (with-open-file (stream1 file1 :element-type '(unsigned-byte 8))
 131     (with-open-file (stream2 file2 :element-type '(unsigned-byte 8))
 132       (and (= (file-length stream1) (file-length stream2))
 133            (loop :for byte1 := (read-byte stream1 nil nil)
 134                  :for byte2 := (read-byte stream2 nil nil)
 135                  :while (and byte1 byte2)
 136                  :always (= byte1 byte2))))))
 137
 138 ;;; Copies the contents of the file denoted by the pathname PATH-IN to
 139 ;;; the file denoted by the pathname PATH-OUT using flexi streams -
 140 ;;; STREAM-IN is read with the external format EXTERNAL-FORMAT-IN and
 141 ;;; STREAM-OUT is written with EXTERNAL-FORMAT-OUT.  The input file is
 142 ;;; opened with the :DIRECTION keyword argument DIRECTION-IN, the
 143 ;;; output file is opened with the :DIRECTION keyword argument
 144 ;;; DIRECTION-OUT.
 145 (defun copy-file (path-in external-format-in path-out external-format-out
 146                   direction-out direction-in)
 147   (with-open-file-stream (in path-in
 148                              :direction direction-in
 149                              :if-does-not-exist :error
 150                              :if-exists :overwrite
 151                              :external-format external-format-in)
 152     (with-open-file-stream (out path-out
 153                                 :direction direction-out
 154                                 :if-does-not-exist :create
 155                                 :if-exists :supersede
 156                                 :external-format external-format-out)
 157       (loop :for line := (read-line in nil nil)
 158             :while line :do (write-line line out)))))
 159
 160 (defun ef-name (ef)
 161   (format nil "~A ~A"
 162           (babel-encodings:enc-name (babel:external-format-encoding ef))
 163           (babel:external-format-eol-style ef)))
 164
 165 ;;; Copies the contents of the file (in the 'test') denoted by the
 166 ;;; relative pathname PATH-IN to the file (in a temporary directory)
 167 ;;; denoted by the relative pathname PATH-OUT using flexi streams -
 168 ;;; STREAM-IN is read with the external format EXTERNAL-FORMAT-IN and
 169 ;;; STREAM-OUT is written with EXTERNAL-FORMAT-OUT.  The resulting
 170 ;;; file is compared with an existing file in the 'test' directory to
 171 ;;; check if the outcome is as expected.  Uses various variants of the
 172 ;;; :DIRECTION keyword when opening the files."
 173 (defun compare-files (path-in external-format-in path-out external-format-out)
 174   (let ((full-path-in (merge-pathnames path-in *data-dir*))
 175         (full-path-out (merge-pathnames path-out *test-dir*))
 176         (full-path-orig (merge-pathnames path-out *data-dir*)))
 177     (dolist (direction-out '(:output :io) t)
 178       (dolist (direction-in '(:input :io))
 179         (let ((description (format nil "Test ~S ~A [~A] --> ~A [~A]"
 180                                    path-in (ef-name external-format-in)
 181                                    direction-in (ef-name external-format-out)
 182                                    direction-out)))
 183           (format *error-output* "~&;; ~A.~%" description)
 184           (copy-file full-path-in external-format-in
 185                      full-path-out external-format-out
 186                      direction-out direction-in)
 187           (unless (file-equal full-path-out full-path-orig)
 188             (format *error-output* "~&;;   Test failed!!!~%")
 189             (return-from compare-files nil)))))))
 190
 191 (test big-stream-comparision-test
 192   (is-false
 193    (let ((args-list (loop :for (file-name symbols) :in *test-files*
 194                           :nconc (create-test-combinations file-name symbols))))
 195      (loop :for args :in args-list
 196            :unless (apply #'compare-files args)
 197            :collect args))))