tests/utils.lisp

   1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:    utils.lisp
   6 ;;;; Purpose: Classes and utilities for testing
   7 ;;;; Author:  Kevin M. Rosenberg
   8 ;;;; Created: Mar 2002
   9 ;;;;
  10 ;;;; $Id: tests.lisp 8926 2004-04-10 21:12:52Z kevin $
  11 ;;;;
  12 ;;;; This file, part of CLSQL, is Copyright (c) 2002-2004 by Kevin M. Rosenberg
  13 ;;;;
  14 ;;;; CLSQL users are granted the rights to distribute and use this software
  15 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
  16 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
  17 ;;;; *************************************************************************
  18
  19 (in-package #:clsql-tests)
  20
  21 (defvar *config-pathname*
  22   (make-pathname :defaults (user-homedir-pathname)
  23                  :name ".clsql-test"
  24                  :type "config"))
  25
  26 (defvar +all-db-types+
  27   #-clisp '(:postgresql :postgresql-socket :mysql :sqlite :odbc
  28             #+allegro :aodbc)
  29   #+clisp '(:sqlite))
  30
  31 (defclass conn-specs ()
  32   ((aodbc :accessor aodbc-spec :initform nil)
  33    (odbc :accessor odbc-spec :initform nil)
  34    (mysql :accessor mysql-spec :initform nil)
  35    (postgresql :accessor postgresql-spec :initform nil)
  36    (postgresql-socket :accessor postgresql-socket-spec :initform nil)
  37    (sqlite :accessor sqlite-spec :initform nil))
  38   (:documentation "Connection specs for CLSQL testing"))
  39
  40
  41 (defun read-specs (&optional (path *config-pathname*))
  42   (if (probe-file path)
  43       (with-open-file (stream path :direction :input)
  44         (let ((specs (make-instance 'conn-specs)))
  45           (dolist (spec (read stream) specs)
  46             (push (second spec)
  47                   (slot-value specs (intern (symbol-name (first spec))
  48                                             (find-package '#:clsql-tests)))))))
  49       (progn
  50         (warn "CLSQL test config file ~S not found" path)
  51         nil)))
  52
  53 (defun spec-fn (db-type)
  54   (intern (concatenate 'string (symbol-name db-type)
  55                        (symbol-name '#:-spec))
  56           (find-package '#:clsql-tests)))
  57
  58 (defun db-type-spec (db-type specs)
  59   (funcall (spec-fn db-type) specs))
  60
  61 (defun db-type-ensure-system (db-type)
  62   (unless (find-package (symbol-name db-type))
  63     (asdf:operate 'asdf:load-op
  64                   (intern (concatenate 'string
  65                                        (symbol-name '#:clsql-)
  66                                        (symbol-name db-type))))))
  67
  68
  69
  70 (defun summarize-test-report (sexp &optional (output *standard-output*))
  71   (flet ((db-title (db-type underlying-db-type)
  72            (format nil "~A~A"
  73                    db-type
  74                    (if (eq db-type underlying-db-type)
  75                        ""
  76                        (format nil "/~A" underlying-db-type)))))
  77     (with-open-file (in sexp :direction :input)
  78       (let ((eof (cons nil nil)))
  79         (do ((form (read in nil eof) (read in nil eof)))
  80             ((eq form eof))
  81           (destructuring-bind (db-type
  82                                underlying-db-type
  83                                utime
  84                                total-tests
  85                                failed-tests
  86                                impl-type
  87                                impl-version
  88                                machine-type)
  89               form
  90             (if failed-tests
  91                 (format output "~&~A: ~D of ~D tests failed (~A, ~A).~&"
  92                         (db-title db-type underlying-db-type)
  93                         (length failed-tests)
  94                         total-tests
  95                         machine-type
  96                         impl-type)
  97                 (format output "~&~A: All ~D tests passed (~A, ~A).~%"
  98                         (db-title db-type underlying-db-type)
  99                         total-tests
 100                         machine-type
 101                         impl-type))))))))