Coverage report: /home/ati/workspace/perec/persistence/table.lisp

KindCoveredAll%
expression5361 86.9
branch44100.0
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 (in-package :cl-perec)
2
 
3
 ;;;;;;;;;;;;;;;;;;;;;;;
4
 ;;; RDBMS model classes
5
 
6
 ;; TODO: use sql-table when available
7
 (defcclass* table (exportable)
8
   ((name
9
     :type symbol
10
     :documentation "The name of the RDBMS table.")
11
    (columns
12
     (compute-as nil)
13
     :type (list sql-column)
14
     :documentation "The list of RDBMS columns of this table. This list uses the sql column type of cl-rdbms."))
15
   (:documentation "An RDBMS table with some related RDBMS definitions. The actual table will be created in the database when export-to-rdbms is called on it."))
16
 
17
 (defcclass* column (sql-column)
18
   ((index
19
     (compute-as nil)
20
     :type (or null sql-index)
21
     :documentation "An RDBMS index on this column."))
22
   (:documentation "An RDBMS column with some related RDBMS specific definitions."))
23
 
24
 (defprint-object (self table)
25
   (princ (name-of self)))
26
 
27
 (defprint-object (self column)
28
   (princ (rdbms::name-of self)))
29
 
30
 ;;;;;;;;;;;;;
31
 ;;; Constants
32
 
33
 (defconstant +oid-id-bit-size+ 64
34
   "Length of the life time unique identifier numbers in bits.")
35
 
36
 (defvar +oid-id-sql-type+
37
   (sql-integer-type :bit-size +oid-id-bit-size+)
38
   "The RDBMS type for the oid's id slot.")
39
 
40
 (defconstant +oid-class-name-maximum-length+ 128
41
   "Maximum length of class names.")
42
 
43
 (defvar +oid-class-name-sql-type+
44
   (sql-character-varying-type :size +oid-class-name-maximum-length+)
45
   "The RDBMS type for the oid's class-name slot")
46
 
47
 ;;;;;;;;;;
48
 ;;; Export
49
 
50
 (defmethod export-to-rdbms ((table table))
51
   "Updates the RDBMS table definition according to the current state of the given table. This might add, alter or drop existing columns, but all destructive changes are required to signal a continuable condition."
52
   (update-table (name-of table) (columns-of table))
53
   (mapc #L(awhen (index-of !1)
54
             (update-index (rdbms::name-of it) (name-of table) (list !1)))
55
         (columns-of table)))
56
 
57
 ;;;;;;;;;;;
58
 ;;; Utility
59
 
60
 (defun rdbms-name-for (name)
61
   "Returns a name which does not conflict with RDBMS keywords and fits in the maximum size."
62
   ;; TODO: this name mapping is not injective (different lisp names are mapped to the same rdbms name)
63
   (let ((name-as-string (strcat "_" (regex-replace-all "\\*|-|/" (symbol-name name) "_"))))
64
     (when (> (length name-as-string) 64)
65
       (setf name-as-string
66
             (strcat (subseq name-as-string 0 60)
67
                     (write-to-string (mod (sxhash name-as-string) 1000)))))
68
     (if (symbol-package name)
69
         (intern name-as-string (symbol-package name))
70
         (make-symbol name-as-string))))