tests/test-init.lisp

   1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; ======================================================================
   3 ;;;; File:    test-init.lisp
   4 ;;;; Author:  Marcus Pearce <m.t.pearce@city.ac.uk>
   5 ;;;; Created: 30/03/2004
   6 ;;;; Updated: <04/04/2004 12:14:38 marcusp>
   7 ;;;; ======================================================================
   8 ;;;;
   9 ;;;; Description ==========================================================
  10 ;;;; ======================================================================
  11 ;;;;
  12 ;;;; Initialisation utilities for running regression tests on CLSQL-USQL.
  13 ;;;;
  14 ;;;; ======================================================================
  15
  16 (in-package #:clsql-usql-tests)
  17
  18 (defvar *test-database-type* nil)
  19 (defvar *test-database-server* "")
  20 (defvar *test-database-name* "")
  21 (defvar *test-database-user* "")
  22 (defvar *test-database-password* "")
  23
  24 (defclass thing ()
  25   ((extraterrestrial :initform nil :initarg :extraterrestrial)))
  26
  27 (def-view-class person (thing)
  28   ((height :db-kind :base :accessor height :type float :nulls-ok t
  29            :initarg :height)
  30    (married :db-kind :base :accessor married :type boolean :nulls-ok t
  31             :initarg :married)
  32    (birthday :nulls-ok t :type clsql-base:wall-time :initarg :birthday)
  33    (hobby :db-kind :virtual :initarg :hobby :initform nil)))
  34
  35 (def-view-class employee (person)
  36   ((emplid
  37     :db-kind :key
  38     :db-constraints :not-null
  39     :nulls-ok nil
  40     :type integer
  41     :initarg :emplid)
  42    (groupid
  43     :db-kind :key
  44     :db-constraints :not-null
  45     :nulls-ok nil
  46     :type integer
  47     :initarg :groupid)
  48    (first-name
  49     :accessor first-name
  50     :type (string 30)
  51     :initarg :first-name)
  52    (last-name
  53     :accessor last-name
  54     :type (string 30)
  55     :initarg :last-name)
  56    (email
  57     :accessor employee-email
  58     :type (string 100)
  59     :nulls-ok t
  60     :initarg :email)
  61    (companyid
  62     :type integer)
  63    (company
  64     :accessor employee-company
  65     :db-kind :join
  66     :db-info (:join-class company
  67                           :home-key companyid
  68                           :foreign-key companyid
  69                           :set nil))
  70    (managerid
  71     :type integer
  72     :nulls-ok t)
  73    (manager
  74     :accessor employee-manager
  75     :db-kind :join
  76     :db-info (:join-class employee
  77                           :home-key managerid
  78                           :foreign-key emplid
  79                           :set nil)))
  80   (:base-table employee))
  81
  82 (def-view-class company ()
  83   ((companyid
  84     :db-type :key
  85     :db-constraints :not-null
  86     :type integer
  87     :initarg :companyid)
  88    (groupid
  89     :db-type :key
  90     :db-constraints :not-null
  91     :type integer
  92     :initarg :groupid)
  93    (name
  94     :type (string 100)
  95     :initarg :name)
  96    (presidentid
  97     :type integer)
  98    (president
  99     :reader president
 100     :db-kind :join
 101     :db-info (:join-class employee
 102                           :home-key presidentid
 103                           :foreign-key emplid
 104                           :set nil))
 105    (employees
 106     :reader company-employees
 107     :db-kind :join
 108     :db-info (:join-class employee
 109                           :home-key (companyid groupid)
 110                           :foreign-key (companyid groupid)
 111                           :set t)))
 112   (:base-table company))
 113
 114 (defparameter company1 (make-instance 'company
 115                                       :companyid 1
 116                                       :groupid 1
 117                                       :name "Widgets Inc."))
 118
 119 (defparameter employee1 (make-instance 'employee
 120                                        :emplid 1
 121                                        :groupid 1
 122                                        :married t
 123                                        :height (1+ (random 1.00))
 124                                        :birthday (clsql-base:get-time)
 125                                        :first-name "Vladamir"
 126                                        :last-name "Lenin"
 127                                        :email "lenin@soviet.org"))
 128
 129 (defparameter employee2 (make-instance 'employee
 130                                :emplid 2
 131                                :groupid 1
 132                                :height (1+ (random 1.00))
 133                                :married t
 134                                :birthday (clsql-base:get-time)
 135                                :first-name "Josef"
 136                                :last-name "Stalin"
 137                                :email "stalin@soviet.org"))
 138
 139 (defparameter employee3 (make-instance 'employee
 140                                :emplid 3
 141                                :groupid 1
 142                                :height (1+ (random 1.00))
 143                                :married t
 144                                :birthday (clsql-base:get-time)
 145                                :first-name "Leon"
 146                                :last-name "Trotsky"
 147                                :email "trotsky@soviet.org"))
 148
 149 (defparameter employee4 (make-instance 'employee
 150                                :emplid 4
 151                                :groupid 1
 152                                :height (1+ (random 1.00))
 153                                :married nil
 154                                :birthday (clsql-base:get-time)
 155                                :first-name "Nikita"
 156                                :last-name "Kruschev"
 157                                :email "kruschev@soviet.org"))
 158
 159 (defparameter employee5 (make-instance 'employee
 160                                :emplid 5
 161                                :groupid 1
 162                                :married nil
 163                                :height (1+ (random 1.00))
 164                                :birthday (clsql-base:get-time)
 165                                :first-name "Leonid"
 166                                :last-name "Brezhnev"
 167                                :email "brezhnev@soviet.org"))
 168
 169 (defparameter employee6 (make-instance 'employee
 170                                :emplid 6
 171                                :groupid 1
 172                                :married nil
 173                                :height (1+ (random 1.00))
 174                                :birthday (clsql-base:get-time)
 175                                :first-name "Yuri"
 176                                :last-name "Andropov"
 177                                :email "andropov@soviet.org"))
 178
 179 (defparameter employee7 (make-instance 'employee
 180                                  :emplid 7
 181                                  :groupid 1
 182                                  :height (1+ (random 1.00))
 183                                  :married nil
 184                                  :birthday (clsql-base:get-time)
 185                                  :first-name "Konstantin"
 186                                  :last-name "Chernenko"
 187                                  :email "chernenko@soviet.org"))
 188
 189 (defparameter employee8 (make-instance 'employee
 190                                  :emplid 8
 191                                  :groupid 1
 192                                  :height (1+ (random 1.00))
 193                                  :married nil
 194                                  :birthday (clsql-base:get-time)
 195                                  :first-name "Mikhail"
 196                                  :last-name "Gorbachev"
 197                                  :email "gorbachev@soviet.org"))
 198
 199 (defparameter employee9 (make-instance 'employee
 200                                  :emplid 9
 201                                  :groupid 1
 202                                  :married nil
 203                                  :height (1+ (random 1.00))
 204                                  :birthday (clsql-base:get-time)
 205                                  :first-name "Boris"
 206                                  :last-name "Yeltsin"
 207                                  :email "yeltsin@soviet.org"))
 208
 209 (defparameter employee10 (make-instance 'employee
 210                                   :emplid 10
 211                                   :groupid 1
 212                                   :married nil
 213                                   :height (1+ (random 1.00))
 214                                   :birthday (clsql-base:get-time)
 215                                   :first-name "Vladamir"
 216                                   :last-name "Putin"
 217                                   :email "putin@soviet.org"))
 218
 219 (defun test-database-connection-spec ()
 220   (let ((dbserver *test-database-server*)
 221         (dbname *test-database-name*)
 222         (dbpassword *test-database-password*)
 223         (dbtype *test-database-type*)
 224         (username *test-database-user*))
 225     (case dbtype
 226       (:postgresql
 227        `("" ,dbname ,username ,dbpassword))
 228       (:postgresql-socket
 229        `(,dbserver ,dbname ,username ,dbpassword))
 230       (:mysql
 231        `("" ,dbname ,username ,dbpassword))
 232       (:sqlite
 233        `(,dbname))
 234       (:oracle
 235        `(,username ,dbpassword ,dbname))
 236       (t
 237        (error "Unrecognized database type: ~A" dbtype)))))
 238
 239 (defun test-connect-to-database (database-type)
 240   (setf *test-database-type* database-type)
 241   ;; Connect to the database
 242   (usql:connect (test-database-connection-spec)
 243                 :database-type database-type
 244                 :make-default t
 245                 :if-exists :old))
 246
 247 (defmacro with-ignore-errors (&rest forms)
 248   `(progn
 249      ,@(mapcar
 250         (lambda (x) (list 'ignore-errors x))
 251         forms)))
 252
 253 (defun test-initialise-database ()
 254     ;; Delete the instance records
 255   (with-ignore-errors
 256     (usql:delete-instance-records company1)
 257     (usql:delete-instance-records employee1)
 258     (usql:delete-instance-records employee2)
 259     (usql:delete-instance-records employee3)
 260     (usql:delete-instance-records employee4)
 261     (usql:delete-instance-records employee5)
 262     (usql:delete-instance-records employee6)
 263     (usql:delete-instance-records employee7)
 264     (usql:delete-instance-records employee8)
 265     (usql:delete-instance-records employee9)
 266     (usql:delete-instance-records employee10)
 267     ;; Drop the required tables if they exist
 268     (usql:drop-view-from-class 'employee)
 269     (usql:drop-view-from-class 'company))
 270   ;; Create the tables for our view classes
 271   (usql:create-view-from-class 'employee)
 272   (usql:create-view-from-class 'company)
 273   ;; Lenin manages everyone
 274   (usql:add-to-relation employee2 'manager employee1)
 275   (usql:add-to-relation employee3 'manager employee1)
 276   (usql:add-to-relation employee4 'manager employee1)
 277   (usql:add-to-relation employee5 'manager employee1)
 278   (usql:add-to-relation employee6 'manager employee1)
 279   (usql:add-to-relation employee7 'manager employee1)
 280   (usql:add-to-relation employee8 'manager employee1)
 281   (usql:add-to-relation employee9 'manager employee1)
 282   (usql:add-to-relation employee10 'manager employee1)
 283   ;; Everyone works for Widgets Inc.
 284   (usql:add-to-relation company1 'employees employee1)
 285   (usql:add-to-relation company1 'employees employee2)
 286   (usql:add-to-relation company1 'employees employee3)
 287   (usql:add-to-relation company1 'employees employee4)
 288   (usql:add-to-relation company1 'employees employee5)
 289   (usql:add-to-relation company1 'employees employee6)
 290   (usql:add-to-relation company1 'employees employee7)
 291   (usql:add-to-relation company1 'employees employee8)
 292   (usql:add-to-relation company1 'employees employee9)
 293   (usql:add-to-relation company1 'employees employee10)
 294   ;; Lenin is president of Widgets Inc.
 295   (usql:add-to-relation company1 'president employee1)
 296   ;; store these instances
 297   (usql:update-records-from-instance employee1)
 298   (usql:update-records-from-instance employee2)
 299   (usql:update-records-from-instance employee3)
 300   (usql:update-records-from-instance employee4)
 301   (usql:update-records-from-instance employee5)
 302   (usql:update-records-from-instance employee6)
 303   (usql:update-records-from-instance employee7)
 304   (usql:update-records-from-instance employee8)
 305   (usql:update-records-from-instance employee9)
 306   (usql:update-records-from-instance employee10)
 307   (usql:update-records-from-instance company1))
 308
 309 (defun test-usql (backend)
 310   (format t "~&Running CLSQL-USQL tests with ~A backend.~%" backend)
 311   (test-connect-to-database backend)
 312   (test-initialise-database)
 313   (rtest:do-tests))
 314
 315
 316