tests/test-ooddl.lisp

   1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; ======================================================================
   3 ;;;; File:    test-ooddl.lisp
   4 ;;;; Author:  Marcus Pearce <m.t.pearce@city.ac.uk>
   5 ;;;; Created: 30/03/2004
   6 ;;;; Updated: $Id$
   7 ;;;;
   8 ;;;; Tests for the CLSQL Object Oriented Data Definition Language
   9 ;;;; (OODDL).
  10 ;;;;
  11 ;;;; This file is part of CLSQL.
  12 ;;;;
  13 ;;;; CLSQL users are granted the rights to distribute and use this software
  14 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
  15 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
  16 ;;;; ======================================================================
  17
  18
  19 (in-package #:clsql-tests)
  20
  21 #.(clsql:locally-enable-sql-reader-syntax)
  22
  23
  24 (def-view-class big ()
  25   ((i :type integer :initarg :i)
  26    (bi :type bigint :initarg :bi)))
  27
  28 (def-dataset *ds-big*
  29   (:setup (lambda ()
  30             (clsql-sys:create-view-from-class 'big)
  31             (let ((max (expt 2 60)))
  32               (dotimes (i 555)
  33                 (update-records-from-instance
  34                  (make-instance 'big :i (1+ i) :bi (truncate max (1+ i))))))))
  35   (:cleanup
  36    (lambda ()  (clsql-sys:drop-view-from-class 'big))))
  37
  38 (setq *rt-ooddl*
  39       '(
  40
  41 ;; Ensure slots inherited from standard-classes are :virtual
  42 (deftest :ooddl/metaclass/1
  43     (values
  44      (clsql-sys::view-class-slot-db-kind
  45       (clsql-sys::slotdef-for-slot-with-class 'extraterrestrial
  46                                              (find-class 'person)))
  47      (clsql-sys::view-class-slot-db-kind
  48       (clsql-sys::slotdef-for-slot-with-class 'hobby (find-class 'person))))
  49   :virtual :virtual)
  50
  51 ;; Ensure all slots in view-class are view-class-effective-slot-definition
  52 (deftest :ooddl/metaclass/2
  53     (values
  54      (every #'(lambda (slotd)
  55                 (typep slotd 'clsql-sys::view-class-effective-slot-definition))
  56             (clsql-sys::class-slots (find-class 'person)))
  57      (every #'(lambda (slotd)
  58                 (typep slotd 'clsql-sys::view-class-effective-slot-definition))
  59             (clsql-sys::class-slots (find-class 'employee)))
  60      (every #'(lambda (slotd)
  61                 (typep slotd 'clsql-sys::view-class-effective-slot-definition))
  62             (clsql-sys::class-slots (find-class 'setting)))
  63      (every #'(lambda (slotd)
  64                 (typep slotd 'clsql-sys::view-class-effective-slot-definition))
  65             (clsql-sys::class-slots (find-class 'theme)))
  66      (every #'(lambda (slotd)
  67                 (typep slotd 'clsql-sys::view-class-effective-slot-definition))
  68             (clsql-sys::class-slots (find-class 'node)))
  69      (every #'(lambda (slotd)
  70                 (typep slotd 'clsql-sys::view-class-effective-slot-definition))
  71             (clsql-sys::class-slots (find-class 'company))))
  72   t t t t t t)
  73
  74 ;; Ensure classes are correctly marked normalized or not, default not
  75 ;(deftest :ooddl/metaclass/3
  76 ;    (values
  77 ;     (clsql-sys::normalizedp derivednode1)
  78 ;    (clsql-sys::normalizedp basenode)
  79 ;    (clsql-sys::normalizedp company1)
  80 ;    (clsql-sys::normalizedp employee3)
  81 ;    (clsql-sys::normalizedp derivednode-sc-2))
  82 ;  t nil nil nil t)
  83
  84 ;(deftest :ooddl/metaclass/3
  85 ; (values
  86 ;  (normalizedp (find-class 'baseclass))
  87 ;  (normalizedp (find-class 'normderivedclass)))
  88 ; nil t)
  89
  90 (deftest :ooddl/join/1
  91     (with-dataset *ds-employees*
  92       (mapcar #'(lambda (e) (slot-value e 'ecompanyid))
  93               (company-employees company1)))
  94   (1 1 1 1 1 1 1 1 1 1))
  95
  96 (deftest :ooddl/join/2
  97     (with-dataset *ds-employees*
  98       (slot-value (president company1) 'last-name))
  99   "Lenin")
 100
 101 (deftest :ooddl/join/3
 102     (with-dataset *ds-employees*
 103       (slot-value (employee-manager employee2) 'last-name))
 104   "Lenin")
 105
 106 (deftest :ooddl/big/1
 107     ;;tests that we can create-view-from-class with a bigint slot,
 108     ;; and stick a value in there.
 109     (progn (clsql-sys:create-view-from-class 'big)
 110            (values
 111              (clsql:table-exists-p [big] :owner *test-database-user*)
 112              (progn
 113                (clsql:drop-table [big] :if-does-not-exist :ignore)
 114                (clsql:table-exists-p [big] :owner *test-database-user*)))
 115            )
 116   t nil)
 117
 118 (deftest :ooddl/big/2
 119     (with-dataset *ds-big*
 120       (let ((rows (clsql:select [*] :from [big] :order-by [i] :field-names nil)))
 121         (values
 122           (length rows)
 123           (do ((i 0 (1+ i))
 124                (max (expt 2 60))
 125                (rest rows (cdr rest)))
 126               ((= i (length rows)) t)
 127             (let ((index (1+ i))
 128                   (int (first (car rest)))
 129                   (bigint (second (car rest))))
 130               (when (and (or (eq *test-database-type* :oracle)
 131                              (and (eq *test-database-type* :odbc)
 132                                   (eq *test-database-underlying-type* :postgresql)))
 133                          (stringp bigint))
 134                 (setf bigint (parse-integer bigint)))
 135               (unless (and (eql int index)
 136                            (eql bigint (truncate max index)))
 137                 (return nil)))))))
 138   555 t)
 139
 140 (deftest :ooddl/time/1
 141     (with-dataset *ds-employees*
 142       (sleep 1) ;force birthdays into the past
 143       (let* ((now (clsql:get-time)))
 144         (when (member *test-database-underlying-type* '(:postgresql :postgresql-socket))
 145           (clsql:execute-command "set datestyle to 'iso'"))
 146         (clsql:update-records [employee] :av-pairs `((birthday ,now))
 147                               :where [= [emplid] 1])
 148         (let ((dbobj (car (clsql:select 'employee :where [= [birthday] now]
 149                                         :flatp t))))
 150           (values
 151             (slot-value dbobj 'last-name)
 152             (clsql:time= (slot-value dbobj 'birthday) now)))))
 153   "Lenin" t)
 154
 155 (deftest :ooddl/time/2
 156     (with-dataset *ds-employees*
 157       (sleep 1) ;force birthdays into the past
 158       (let* ((now (clsql:get-time))
 159              (fail-index -1))
 160         (when (member *test-database-underlying-type* '(:postgresql :postgresql-socket))
 161           (clsql:execute-command "set datestyle to 'iso'"))
 162         (dotimes (x 40)
 163           (clsql:update-records [employee] :av-pairs `((birthday ,now))
 164                                 :where [= [emplid] 1])
 165           (let ((dbobj (car (clsql:select 'employee :where [= [birthday] now]
 166                                           :flatp t))))
 167             (unless (clsql:time= (slot-value dbobj 'birthday) now)
 168               (setf fail-index x))
 169             (setf now (clsql:roll now :day (* 10 x)))))
 170         fail-index))
 171   -1)
 172
 173 (deftest :ooddl/time/3
 174     (with-dataset *ds-employees*
 175       (progn
 176         (when (member *test-database-underlying-type* '(:postgresql :postgresql-socket))
 177           (clsql:execute-command "set datestyle to 'iso'"))
 178         (let ((dbobj (car (clsql:select 'employee :where [= [emplid] 10]
 179                                         :flatp t))))
 180           (list
 181            (eql *test-start-utime* (slot-value dbobj 'bd-utime))
 182            (clsql:time= (slot-value dbobj 'birthday)
 183                         (clsql:utime->time (slot-value dbobj 'bd-utime)))))))
 184   (t t))
 185
 186 ))
 187
 188 #.(clsql:restore-sql-reader-syntax-state)
 189