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 (setq *rt-ooddl*
  24       '(
  25
  26 ;; Ensure slots inherited from standard-classes are :virtual
  27 (deftest :ooddl/metaclass/1
  28     (values
  29      (clsql-sys::view-class-slot-db-kind
  30       (clsql-sys::slotdef-for-slot-with-class 'extraterrestrial
  31                                              (find-class 'person)))
  32      (clsql-sys::view-class-slot-db-kind
  33       (clsql-sys::slotdef-for-slot-with-class 'hobby (find-class 'person))))
  34   :virtual :virtual)
  35
  36 ;; Ensure all slots in view-class are view-class-effective-slot-definition
  37 (deftest :ooddl/metaclass/2
  38     (values
  39      (every #'(lambda (slotd)
  40                 (typep slotd 'clsql-sys::view-class-effective-slot-definition))
  41             (clsql-sys::class-slots (find-class 'person)))
  42      (every #'(lambda (slotd)
  43                 (typep slotd 'clsql-sys::view-class-effective-slot-definition))
  44             (clsql-sys::class-slots (find-class 'employee)))
  45      (every #'(lambda (slotd)
  46                 (typep slotd 'clsql-sys::view-class-effective-slot-definition))
  47             (clsql-sys::class-slots (find-class 'setting)))
  48      (every #'(lambda (slotd)
  49                 (typep slotd 'clsql-sys::view-class-effective-slot-definition))
  50             (clsql-sys::class-slots (find-class 'theme)))
  51      (every #'(lambda (slotd)
  52                 (typep slotd 'clsql-sys::view-class-effective-slot-definition))
  53             (clsql-sys::class-slots (find-class 'node)))
  54      (every #'(lambda (slotd)
  55                 (typep slotd 'clsql-sys::view-class-effective-slot-definition))
  56             (clsql-sys::class-slots (find-class 'company))))
  57   t t t t t t)
  58
  59 ;; Ensure classes are correctly marked normalised or not, default not
  60 ;(deftest :ooddl/metaclass/3
  61 ;    (values
  62 ;     (clsql-sys::normalisedp derivednode1)
  63 ;    (clsql-sys::normalisedp basenode)
  64 ;    (clsql-sys::normalisedp company1)
  65 ;    (clsql-sys::normalisedp employee3)
  66 ;    (clsql-sys::normalisedp derivednode-sc-2))
  67 ;  t nil nil nil t)
  68
  69 ;(deftest :ooddl/metaclass/3
  70 ; (values
  71 ;  (normalisedp (find-class 'baseclass))
  72 ;  (normalisedp (find-class 'normderivedclass)))
  73 ; nil t)
  74
  75 (deftest :ooddl/join/1
  76     (mapcar #'(lambda (e) (slot-value e 'ecompanyid))
  77      (company-employees company1))
  78   (1 1 1 1 1 1 1 1 1 1))
  79
  80 (deftest :ooddl/join/2
  81     (slot-value (president company1) 'last-name)
  82   "Lenin")
  83
  84 (deftest :ooddl/join/3
  85     (slot-value (employee-manager employee2) 'last-name)
  86   "Lenin")
  87
  88 (deftest :ooddl/big/1
  89     (let ((rows (clsql:select [*] :from [big] :order-by [i] :field-names nil)))
  90       (values
  91        (length rows)
  92        (do ((i 0 (1+ i))
  93             (max (expt 2 60))
  94             (rest rows (cdr rest)))
  95            ((= i (length rows)) t)
  96          (let ((index (1+ i))
  97                (int (first (car rest)))
  98                (bigint (second (car rest))))
  99            (when (and (or (eq *test-database-type* :oracle)
 100                           (and (eq *test-database-type* :odbc)
 101                                (eq *test-database-underlying-type* :postgresql)))
 102                       (stringp bigint))
 103              (setf bigint (parse-integer bigint)))
 104            (unless (and (eql int index)
 105                         (eql bigint (truncate max index)))
 106              (return nil))))))
 107   555 t)
 108
 109 (deftest :ooddl/time/1
 110     (let* ((now (clsql:get-time)))
 111       (when (member *test-database-underlying-type* '(:postgresql :postgresql-socket))
 112         (clsql:execute-command "set datestyle to 'iso'"))
 113       (clsql:update-records [employee] :av-pairs `((birthday ,now))
 114                            :where [= [emplid] 1])
 115       (let ((dbobj (car (clsql:select 'employee :where [= [birthday] now]
 116                                       :flatp t))))
 117         (values
 118          (slot-value dbobj 'last-name)
 119          (clsql:time= (slot-value dbobj 'birthday) now))))
 120   "Lenin" t)
 121
 122 (deftest :ooddl/time/2
 123     (let* ((now (clsql:get-time))
 124            (fail-index -1))
 125       (when (member *test-database-underlying-type* '(:postgresql :postgresql-socket))
 126         (clsql:execute-command "set datestyle to 'iso'"))
 127       (dotimes (x 40)
 128         (clsql:update-records [employee] :av-pairs `((birthday ,now))
 129                              :where [= [emplid] 1])
 130         (let ((dbobj (car (clsql:select 'employee :where [= [birthday] now]
 131                                         :flatp t))))
 132           (unless (clsql:time= (slot-value dbobj 'birthday) now)
 133             (setf fail-index x))
 134           (setf now (clsql:roll now :day (* 10 x)))))
 135       fail-index)
 136   -1)
 137
 138 (deftest :ooddl/time/3
 139     (progn
 140       (when (member *test-database-underlying-type* '(:postgresql :postgresql-socket))
 141         (clsql:execute-command "set datestyle to 'iso'"))
 142       (let ((dbobj (car (clsql:select 'employee :where [= [emplid] 10]
 143                                       :flatp t))))
 144         (list
 145          (eql *test-start-utime* (slot-value dbobj 'bd-utime))
 146          (clsql:time= (slot-value dbobj 'birthday)
 147                       (clsql:utime->time (slot-value dbobj 'bd-utime))))))
 148   (t t))
 149
 150 ))
 151
 152 #.(clsql:restore-sql-reader-syntax-state)
 153