From a223800f208347e8a07f597648fcdb6c05ec5afe Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Thu, 22 Apr 2004 05:16:20 +0000 Subject: [PATCH] r9126: finish port test-basic to rt --- ChangeLog | 7 +- clsql-tests.asd | 2 +- tests/package.lisp | 28 +++--- tests/test-basic.lisp | 208 +++++++++++++++++++++++------------------- tests/test-init.lisp | 51 ++++++++--- 5 files changed, 174 insertions(+), 122 deletions(-) diff --git a/ChangeLog b/ChangeLog index 5520368..62b02e4 100644 --- a/ChangeLog +++ b/ChangeLog @@ -5,10 +5,13 @@ * sql/objects.lisp: Change database-type to database-underlying-type so that actual database engine is properly identified * db-odbc/odbc-api.lisp: Have default *time-conversion-function* - return an ISO timestring for compatibility with other drivers + return an ISO timestring for compatibility with other drivers. + Workaround bug in MyODBC for LIST-TABLE-INDEXES * test/test-fdml.lisp: Accomodate that odbc-postgresql driver returns floating-point values for floor and truncate operations - * db-aodbc/aodbc-sql: Implement DATABASE-LIST-VIEWS + * db-aodbc/aodbc-sql.lisp: Implement DATABASE-LIST-VIEWS + * tests/test-basic.lisp: Port to regression tester + * test/test-init.lisp: Output to *report-stream* 21 Apr 2004 Kevin Rosenberg (kevin@rosenberg.net) * Version 2.9.2: Improvments in database capability introspection diff --git a/clsql-tests.asd b/clsql-tests.asd index 4fc94cf..f42b7f1 100644 --- a/clsql-tests.asd +++ b/clsql-tests.asd @@ -25,7 +25,7 @@ :version "" :licence "" :description "A regression test suite for CLSQL." - :depends-on (clsql ptester rt) + :depends-on (clsql rt) :components ((:module tests :serial t diff --git a/tests/package.lisp b/tests/package.lisp index df38db1..d00ada9 100644 --- a/tests/package.lisp +++ b/tests/package.lisp @@ -1,22 +1,28 @@ ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;;; ====================================================================== -;;;; File: package.lisp -;;;; Author: Marcus Pearce -;;;; Created: 30/03/2004 -;;;; Updated: $Id$ -;;;; ====================================================================== -;;;; -;;;; Description ========================================================== -;;;; ====================================================================== +;;;; File: package.lisp +;;;; Authors: Marcus Pearce and Kevin Rosenberg +;;;; Created: 30/03/2004 +;;;; Updated: $Id$ ;;;; ;;;; Package definition for CLSQL test suite. ;;;; +;;;; This file is part of CLSQL. +;;;; +;;;; CLSQL users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;;;; ====================================================================== - (in-package #:cl-user) (defpackage #:clsql-tests - (:use #:clsql #:common-lisp #:rtest #:ptester) - (:export #:run-tests #:test-initialise-database #:test-connect-to-database) + (:use #:clsql #:common-lisp #:rtest) + (:export + #:run-tests + #:run-tests-append-report-file + #:test-initialise-database + #:test-connect-to-database + ) (:documentation "Regression tests for CLSQL.")) + diff --git a/tests/test-basic.lisp b/tests/test-basic.lisp index d6fcfa1..34b3f25 100644 --- a/tests/test-basic.lisp +++ b/tests/test-basic.lisp @@ -35,51 +35,122 @@ ))))) (defun test-basic-forms () - nil) + (append + (test-basic-forms-untyped) + '( + (deftest BASIC/TYPE/1 + (let ((results '())) + (dolist (row (query "select * from TYPE_TABLE" :result-types :auto) + results) + (destructuring-bind (int float bigint str) row + (push (list (integerp int) + (typep float 'double-float) + (if (member *test-database-type* '(:odbc :aodbc)) + t + (integerp bigint)) + (stringp str)) + results)))) + ((t t t t) (t t t t) (t t t t) (t t t t) (t t t t) (t t t t) (t t t t) (t t t t) (t t t t) (t t t t) (t t t t))) + + + (deftest BASIC/TYPE/2 + (let ((results '())) + (dolist (row (query "select * from TYPE_TABLE" :result-types :auto) + results) + (destructuring-bind (int float bigint str) row + (push (list (double-float-equal + (transform-float-1 int) + float) + (double-float-equal + (parse-double str) + float)) + results)))) + ((t t) (t t) (t t) (t t) (t t) (t t) (t t) (t t) (t t) (t t) (t t))) + ))) (defun test-basic-forms-untyped () - nil) - - -(defun %test-basic-forms () - (dolist (row (query "select * from TYPE_TABLE" :result-types :auto)) - (test-table-row row :auto)) - (dolist (row (query "select * from TYPE_TABLE" :result-types nil)) - (test-table-row row nil)) - (loop for row across (map-query 'vector #'list "select * from TYPE_TABLE" - :result-types :auto) - do (test-table-row row :auto)) - (loop for row across (map-query 'vector #'list "select * from TYPE_TABLE" - :result-types nil) - do (test-table-row row nil)) - (loop for row in (map-query 'list #'list "select * from TYPE_TABLE" - :result-types nil) - do (test-table-row row nil)) - (loop for row in (map-query 'list #'list "select * from TYPE_TABLE" - :result-types :auto) - do (test-table-row row :auto)) - (test (map-query nil #'list "select * from TYPE_TABLE" - :result-types :auto) - nil - :fail-info "Expected NIL result from map-query nil") - (do-query ((int float bigint str) "select * from TYPE_TABLE") - (test-table-row (list int float bigint str) nil)) - (do-query ((int float bigint str) "select * from TYPE_TABLE" :result-types :auto) - (test-table-row (list int float bigint str) :auto))) - - -(defun %test-basic-forms-untyped () - (dolist (row (query "select * from TYPE_TABLE" :result-types nil)) - (test-table-row row nil)) - (loop for row across (map-query 'vector #'list "select * from TYPE_TABLE" - :result-types nil) - do (test-table-row row nil)) - (loop for row in (map-query 'list #'list "select * from TYPE_TABLE" - :result-types nil) - do (test-table-row row nil)) - - (do-query ((int float bigint str) "select * from TYPE_TABLE") - (test-table-row (list int float bigint str) nil))) + '((deftest BASIC/SELECT/1 + (let ((rows (query "select * from TYPE_TABLE" :result-types :auto))) + (values + (length rows) + (length (car rows)))) + 11 4) + + (deftest BASIC/SELECT/2 + (let ((results '())) + (dolist (row (query "select * from TYPE_TABLE" :result-types nil) + results) + (destructuring-bind (int float bigint str) row + (push (list (stringp int) + (stringp float) + (stringp bigint) + (stringp str)) + results)))) + ((t t t t) (t t t t) (t t t t) (t t t t) (t t t t) (t t t t) (t t t t) (t t t t) (t t t t) (t t t t) (t t t t))) + + (deftest BASIC/SELECT/3 + (let ((results '())) + (dolist (row (query "select * from TYPE_TABLE" :result-types nil) + results) + (destructuring-bind (int float bigint str) row + (push (list (double-float-equal + (transform-float-1 (parse-integer int)) + (parse-double float)) + (double-float-equal + (parse-double str) + (parse-double float))) + results)))) + ((t t) (t t) (t t) (t t) (t t) (t t) (t t) (t t) (t t) (t t) (t t))) + + (deftest BASIC/MAP/1 + (let ((results '()) + (rows (map-query 'vector #'list "select * from TYPE_TABLE" + :result-types nil))) + (dotimes (i (length rows) results) + (push + (list + (listp (aref rows i)) + (length (aref rows i)) + (eql (- i 5) + (parse-integer (first (aref rows i)) + :junk-allowed nil)) + (double-float-equal + (transform-float-1 (parse-integer (first (aref rows i)))) + (parse-double (second (aref rows i))))) + results))) + ((t 4 t t) (t 4 t t) (t 4 t t) (t 4 t t) (t 4 t t) (t 4 t t) (t 4 t t) (t 4 t t) (t 4 t t) (t 4 t t) (t 4 t t))) + + (deftest BASIC/MAP/2 + (let ((results '()) + (rows (map-query 'list #'list "select * from TYPE_TABLE" + :result-types nil))) + (dotimes (i (length rows) results) + (push + (list + (listp (nth i rows)) + (length (nth i rows)) + (eql (- i 5) + (parse-integer (first (nth i rows)) + :junk-allowed nil)) + (double-float-equal + (transform-float-1 (parse-integer (first (nth i rows)))) + (parse-double (second (nth i rows))))) + results))) + ((t 4 t t) (t 4 t t) (t 4 t t) (t 4 t t) (t 4 t t) (t 4 t t) (t 4 t t) (t 4 t t) (t 4 t t) (t 4 t t) (t 4 t t))) + + (deftest BASIC/DO/1 + (let ((results '())) + (do-query ((int float bigint str) "select * from TYPE_TABLE") + (push (list (double-float-equal + (transform-float-1 (parse-integer int)) + (parse-double float)) + (double-float-equal + (parse-double str) + (parse-double float))) + results)) + results) + ((t t) (t t) (t t) (t t) (t t) (t t) (t t) (t t) (t t) (t t) (t t))) + )) ;;;; Testing functions @@ -90,61 +161,12 @@ (defun transform-bigint-1 (i) (* i (expt 10 (* 3 (abs i))))) - - (defun parse-double (num-str) (let ((*read-default-float-format* 'double-float)) (coerce (read-from-string num-str) 'double-float))) (defun test-table-row (row types) - (test (and (listp row) - (= 4 (length row))) - t - :fail-info - (format nil "Row ~S is incorrect format" row)) - (destructuring-bind (int float bigint str) row - (cond - ((eq types :auto) - (test (and (integerp int) - (typep float 'double-float) - (or (member *test-database-type* - '(:odbc :aodbc)) ;; aodbc considers bigints as strings - (integerp bigint)) - (stringp str)) - t - :fail-info - (format nil "Incorrect field type for row ~S (types :auto)" row))) - ((null types) - (test (and (stringp int) - (stringp float) - (stringp bigint) - (stringp str)) - t - :fail-info - (format nil "Incorrect field type for row ~S (types nil)" row)) - (when (stringp int) - (setq int (parse-integer int))) - (setq bigint (parse-integer bigint)) - (when (stringp float) - (setq float (parse-double float)))) - ((listp types) - (error "NYI") - ) - (t - (test t nil - :fail-info - (format nil "Invalid types field (~S) passed to test-table-row" types)))) - (unless (eq *test-database-type* :sqlite) ; SQLite is typeless. - (test (transform-float-1 int) - float - :test #'double-float-equal - :fail-info - (format nil "Wrong float value ~A for int ~A (row ~S)" float int row))) - (test float - (parse-double str) - :test #'double-float-equal - :fail-info (format nil "Wrong string value ~A for double ~A~%Row: ~S" - str float row)))) +) (defun double-float-equal (a b) diff --git a/tests/test-init.lisp b/tests/test-init.lisp index ba69ba0..461f0f8 100644 --- a/tests/test-init.lisp +++ b/tests/test-init.lisp @@ -16,6 +16,7 @@ (in-package #:clsql-tests) +(defvar *report-stream*) (defvar *rt-connection*) (defvar *rt-fddl*) (defvar *rt-fdml*) @@ -299,7 +300,13 @@ (defvar *error-count* 0) -(defun run-tests () +(defun run-tests-append-report-file (report-file) + (with-open-file (out report-file :direction :output + :if-exists :append + :if-does-not-exist :create) + (run-tests out))) + +(defun run-tests (&optional (*report-stream* *standard-output*)) (let ((specs (read-specs)) (*error-count* 0)) (unless specs @@ -307,8 +314,10 @@ (return-from run-tests :skipped)) (load-necessary-systems specs) (dolist (db-type +all-db-types+) - (when (db-type-spec db-type specs) - (do-tests-for-backend db-type))) + (unless (and (eq db-type :aodbc) + (not (member :allegro cl:*features*))) + (when (db-type-spec db-type specs) + (do-tests-for-backend db-type)))) (zerop *error-count*))) (defun load-necessary-systems (specs) @@ -317,38 +326,50 @@ (db-type-ensure-system db-type)))) (defun do-tests-for-backend (db-type) - (format t - "~& -******************************************************************* -*** Running CLSQL tests with ~A backend. -******************************************************************* -" db-type) - (test-connect-to-database db-type) + (unwind-protect (multiple-value-bind (test-forms skip-tests) (compute-tests-for-backend db-type *test-database-underlying-type*) + (format *report-stream* + "~& +****************************************************************************** +*** CLSQL Test Suite begun at ~A +*** ~A +*** ~A +*** Database ~A backend~A. +****************************************************************************** +" +(clsql-base:format-time nil (clsql-base:utime->time (get-universal-time))) +(lisp-implementation-type) +(lisp-implementation-version) +db-type +(if (not (eq db-type *test-database-underlying-type*)) + (format nil " with underlying type ~A" *test-database-underlying-type*) + "") +) + (test-initialise-database) (regression-test:rem-all-tests) (dolist (test-form test-forms) (eval test-form)) - (let ((remaining (rtest:do-tests))) + (let ((remaining (rtest:do-tests *report-stream*))) (when (consp remaining) (incf *error-count* (length remaining)))) - (format t "~&Tests skipped for ~A:" db-type) + (format *report-stream* "~&Tests skipped:") (if skip-tests (dolist (skipped skip-tests) - (format t "~& ~20A ~A~%" (car skipped) (cdr skipped))) - (format t " None~%"))) + (format *report-stream* + "~& ~20A ~A~%" (car skipped) (cdr skipped))) + (format *report-stream* " None~%"))) (disconnect))) (defun compute-tests-for-backend (db-type db-underlying-type) - (declare (ignore db-type)) (let ((test-forms '()) (skip-tests '())) (dolist (test-form (append -- 2.34.1