Coverage report: /home/ati/workspace/perec/query/runtime.lisp

KindCoveredAll%
expression161192 83.9
branch3342 78.6
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 ;; -*- mode: Lisp; Syntax: Common-Lisp; -*-
2
 ;;;
3
 ;;; Copyright (c) 2006 by the authors.
4
 ;;;
5
 ;;; See LICENCE for details.
6
 
7
 (in-package :cl-perec)
8
 
9
 ;;;; Functions called from compiled queries.
10
 
11
 ;;;
12
 ;;; Lisp implementation of some SQL funtion
13
 ;;;
14
 (defun like (str pattern)
15
   "Matches STR with PATTERN. In the pattern _ and % wildcards can be used"
16
   (flet ((like-pattern->regex (pattern)
17
            (setf pattern (regex-replace-all "([.*+?(){}|^$])" pattern "\\\\\\1"))
18
            (setf pattern (regex-replace-all "(?<!\\\\)_" pattern "."))
19
            (setf pattern (regex-replace-all "(?<!\\\\)%" pattern ".*"))))
20
     (if (scan (like-pattern->regex pattern) str) #t #f)))
21
 
22
 (defun sum (seq)
23
   "Returns the sum of non NIL elements of SEQ."
24
   (iter (for val in-sequence seq)
25
         (sum (or val 0))))
26
 
27
 (defun avg (seq)
28
   "Returns the average of non NIL elements of SEQ."
29
   (iter (for val in-sequence seq)
30
         (sum (or val 0) into sum)
31
         (counting val into count)
32
         (finally (return (if (> count 0) (/ sum count) 0)))))
33
 
34
 ;;;
35
 ;;; Caching
36
 ;;;
37
 (defun cache-object-with-prefetched-slots (row start prefetched-slots)
38
   "Caches the objects whose oid and slots are contained by ROW starting at START."
39
   (bind ((oid-width (length +oid-column-names+))
40
          (oid (subseq row start (+ start oid-width)))
41
          (rdbms-values
42
           (iter (for slot in prefetched-slots)
43
                 (for width = (column-count-of slot))
44
                 (for index initially (+ start oid-width) then (+ index width))
45
                 (collect (subseq row index (+ index width))))))
46
     (cache-object* oid prefetched-slots rdbms-values)))
47
 
48
 (defun cache-object* (oid slots rdbms-values)
49
   "Caches the objects whose oid and slots are contained by ROW starting at START."
50
   (bind ((object (cache-object oid)))
51
     (mapc (lambda (slot rdbms-value)
52
             ;; we use the slot-name here because we can't guarantee that the effective slot will match with the class of the object
53
             (setf (cached-slot-boundp-or-value object (slot-definition-name slot))
54
                   (restore-slot-value slot rdbms-value)))
55
           slots rdbms-values)
56
     object))
57
 
58
 (defun column-count-of (slot)
59
   (length (columns-of slot)))
60
 
61
 (defun invalidate-persistent-flag-of-cached-objects (class)
62
   "Sets the persistent slot to unbound for instances of class in the transaction cache."
63
   (maphash
64
    (lambda (oid object)
65
      (declare (ignore oid))
66
      (when (typep object class)
67
        (slot-makunbound object 'persistent)))
68
    (objects-of (current-object-cache))))
69
 
70
 ;;;
71
 ;;; Conversion between lisp and sql values
72
 ;;;
73
 (defgeneric value->sql-literal (value type &optional args)
74
 
75
   ;; Runtime cast error
76
   
77
   (:method (value type &optional args)
78
            (error "Can not cast ~A to ~A" value (compose-type type args)))
79
 
80
   ;; Supported types
81
   
82
   (:method (value (type symbol) &optional args)
83
            (sql-literal :value (value->sql-value value (compose-type type args))))
84
 
85
   (:method (value (type persistent-class) &optional args)
86
            (assert (null args))
87
            (assert (typep value type))
88
            (value->sql-literal value (class-name type)))
89
 
90
   (:method (value (type cons) &optional args)
91
            (assert (null args))
92
            (value->sql-literal value (first type) (rest type)))
93
 
94
   ;; Infer type from value
95
 
96
   (:method ((value persistent-object) (type (eql +unknown-type+)) &optional args)
97
            (assert (null args))
98
            (value->sql-literal value (type-of value)))
99
  
100
   (:method ((value string) (type (eql +unknown-type+)) &optional args) ; TODO
101
            (assert (null args))
102
            (value->sql-literal value 'string))
103
 
104
   (:method ((value number) (type (eql +unknown-type+)) &optional args) ; TODO BIT
105
            (assert (null args))
106
            (value->sql-literal value 'number))
107
 
108
   ;; Iterate on lists
109
 
110
   (:method ((value list) (type (eql 'set)) &optional args)
111
            (assert (not (null args)))
112
            (assert (every #L(typep !1 (first args)) value))
113
            (sql-literal :value (mapcar #L(value->sql-literal !1 (first args)) value)))
114
 
115
   (:method ((value list) (type (eql +unknown-type+)) &optional args) ; FIXME hopefully not a form
116
            (assert (null args))
117
            (sql-literal :value (mapcar #L(value->sql-literal !1 type) value))))
118
 
119
 (defun value->sql-value (value type)
120
   (assert (not (eq type +unknown-type+)))
121
   (bind ((sql-values (value->sql-values value type)))
122
     (case (length sql-values)
123
       (1 (first sql-values))
124
       (2 (cond
125
            ((persistent-class-type-p (normalized-type-for type)) ; only id column used
126
             (first sql-values))
127
            ((and (null-subtype-p type) (unbound-subtype-p type))
128
             (assert (first sql-values))     ; check if BOUND
129
             (second sql-values))            ; omit BOUND column
130
            (t
131
             (error "unsupported multi-column type: ~A" type))))
132
       (t (error "unsupported multi-column type: ~A" type)))))
133
 
134
 (defun value->sql-values (value type)
135
   (assert (not (eq type +unknown-type+)))
136
   (funcall
137
    (compute-writer nil type)
138
     value))
139
 
140
 (defun compose-type (type args)
141
   (if args (cons type args) type))
142
 
143
   
144