tests/test-ooddl.lisp

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