Coverage report: /development/source/library/org/datagraph/spocq-shard/src/odbc/sql/sql-model.lisp

KindCoveredAll%
expression50223 22.4
branch216 12.5
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 ;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: clsql-sys; -*-
2
 
3
 (in-package :clsql-sys)
4
 
5
 (eval-when (:compile-toplevel :load-toplevel :execute)
6
   (export '(clsql-sys::select-selections clsql-sys::select-where clsql-sys::select-from
7
                                          clsql-sys::sql-variable
8
                                          clsql-sys::sql-equal
9
                                          clsql-sys::sql-ident-table
10
                                          clsql-sys::sql-ident-table-alias
11
                                          clsql-sys::sql-ident-expression)
12
           :clsql-sys)
13
   (import '(clsql-sys::select-selections clsql-sys::select-where clsql-sys::select-from
14
                                          clsql-sys::sql-variable
15
                                          clsql-sys::sql-ident-table
16
                                          clsql-sys::sql-ident-table-alias
17
                                          clsql-sys::sql-ident-expression)
18
           :clsql)
19
   (export '(clsql-sys::select-selections clsql-sys::select-where clsql-sys::select-from
20
                             clsql-sys::sql-variable
21
                             clsql-sys::sql-ident-table
22
                             clsql-sys::sql-ident-table-alias
23
                             clsql-sys::sql-ident-expression)
24
           :clsql)
25
   (export '(clsql::sql-name)
26
           :clsql)
27
 )
28
 
29
 (defgeneric select-selections (object)
30
   (:method ((object t))
31
     nil)
32
   (:method ((object sql-query))
33
     (with-slots (selections) object
34
       selections))
35
   (:method ((sql sql-join-exp))
36
     (remove-duplicates (with-slots (components) sql
37
                          (loop for component in components
38
                            append (select-selections component)))
39
                        :test #'sql-equal
40
                        :from-end t))
41
   (:method ((sql sql-set-exp))
42
     (remove-duplicates (with-slots (sub-expressions) sql
43
                          (loop for expression in sub-expressions
44
                            append (select-selections expression)))
45
                        :test #'sql-equal
46
                        :from-end t)))
47
 
48
 (defgeneric (setf select-selections) (selection object)
49
   (:method (selection (object sql-query))
50
     (with-slots (selections) object
51
       (push selection selections))))
52
 
53
 (defgeneric select-where (object)
54
   (:method ((object t))
55
     nil)
56
   (:method ((object sql-query))
57
     (with-slots (where) object
58
       where)))
59
 
60
 (defgeneric (setf select-where) (value object)
61
   (:method (value (object sql-query))
62
     (with-slots (where) object
63
       (setf where value))))
64
 
65
 (defgeneric select-from (object)
66
   (:method ((sql sql-query))
67
     (with-slots (from) sql
68
       from))
69
   (:method ((sql sql-join-exp))
70
     (remove-duplicates (with-slots (components) sql
71
                          (loop for component in components
72
                            for from = (select-from component)
73
                            if (listp from)
74
                            append from
75
                            else collect from))
76
                        :test #'sql-equal
77
                        :from-end t))
78
   (:method ((sql sql-set-exp))
79
     (remove-duplicates (with-slots (sub-expressions) sql
80
                          (loop for expression in sub-expressions
81
                            for from = (select-from expression)
82
                            if (listp from)
83
                            append from
84
                            else collect from ))
85
                        :test #'sql-equal
86
                        :from-end t))
87
   (:method ((sql t))
88
     nil))
89
 
90
 (defgeneric sql-equal (o1 o2)
91
   (:method ((o1 t) (o2 t))
92
     nil)
93
   (:method ((o1 CLSQL-SYS:SQL-IDENT) (o2 CLSQL-SYS:SQL-IDENT))
94
     (equal (slot-value o1 'CLSQL-SYS::NAME)
95
            (slot-value o2 'CLSQL-SYS::NAME)))
96
   (:method ((o1 CLSQL-SYS:SQL-IDENT-ATTRIBUTE) (o2 CLSQL-SYS:SQL-IDENT-ATTRIBUTE))
97
     (and (call-next-method)
98
          (equal (slot-value o1 'CLSQL-SYS::QUALIFIER)
99
            (slot-value o2 'CLSQL-SYS::QUALIFIER)))))
100
 
101
 (defgeneric clsql:sql-name (sql)
102
   (:method ((sql CLSQL-SYS:SQL-IDENT))
103
     (slot-value sql 'CLSQL-SYS::NAME)))
104
 
105
 (defclass sql-variable (sql-ident)
106
   ()
107
   (:documentation "A variable to be incorporated into an SQL expression."))
108
 
109
 (defmethod print-object ((object sql-variable) stream)
110
   (print-unreadable-object (object stream :type t :identity nil)
111
     (with-slots (name) object 
112
       (prin1 name stream))))
113
 
114
 (defmethod make-load-form ((sql sql-variable) &optional environment)
115
   (declare (ignore environment))
116
   (with-slots (name)
117
     sql
118
     `(make-instance 'sql-variable :name ',name)))
119
 
120
 (defmethod output-sql ((expr sql-variable) database)
121
   (with-slots (name) expr
122
     (etypecase name
123
       (string (output-sql name *sql-stream*))
124
       (symbol
125
        (if (boundp name)
126
            (output-sql (symbol-value name) *sql-stream*)
127
            (format *sql-stream* "?~a" (symbol-name name))))))
128
   t)
129
 
130
 (defmethod database-type ((database t)) nil)
131
 
132
 
133
 
134
 ;; For SQL Identifiers for tables : extend with schema
135
 ;; redefine just the pertinent operators
136
 ;; this extends the expression for the table itself, but not for any attributes 
137
 
138
 (defclass sql-ident-table (sql-ident)
139
   ((alias
140
     :initarg :table-alias :initform nil)
141
    (schema
142
     :initarg :table-schema :initform nil))
143
   (:documentation "An SQL identifier for a schema-qualified table."))
144
 
145
 (defmethod make-load-form ((sql sql-ident-table) &optional environment)
146
   (declare (ignore environment))
147
   (with-slots (alias name schema)
148
     sql
149
     `(make-instance 'sql-ident-table :name ',name :table-alias ',alias
150
        ,@(when schema `(:table-schema ',schema)))))
151
 
152
 (defmethod output-sql ((expr sql-ident-table) database)
153
   (with-slots (name alias schema) expr
154
     (flet ((p (s) ;; the etypecase is in sql-escape too
155
              (write-string
156
               (escaped-database-identifier s database)
157
               *sql-stream*)))
158
       (when schema
159
         (p schema)
160
         (princ #\. *sql-stream*))
161
       (p name)
162
       (when alias
163
         (princ #\space *sql-stream*)
164
         (p alias))))
165
   t)
166
 
167
 
168
 (defmethod output-sql-hash-key ((expr sql-ident-table) database)
169
   (with-slots (name alias schema)
170
       expr
171
     (list (and database (database-underlying-type database))
172
           'sql-ident-table
173
           (unescaped-database-identifier name)
174
           (unescaped-database-identifier alias)
175
           (unescaped-database-identifier schema))))
176
 
177
 
178
 (defmethod sql-ident-table-alias ((expr sql-ident-table))
179
    (with-slots (name alias schema)
180
       expr
181
      alias))
182
 
183
 (defmethod (setf sql-ident-table-alias) (alias (expr list))
184
   (dolist (expr expr) (setf (sql-ident-table-alias expr) alias))
185
   alias)
186
 
187
 (defmethod (setf sql-ident-table-alias) (new-alias (expr sql-ident-table))
188
    (with-slots (name alias schema)
189
       expr
190
      (setf alias new-alias)))
191
 
192
 ;;; select indentified expressions
193
 
194
 (defclass sql-ident-expression (sql-ident)
195
   ((ident
196
     :initarg :ident :initform (error "ident is required"))
197
    (expression
198
     :initarg :expression :initform (error "expression is required")))
199
   (:documentation "An SQL expression associated with an identifier."))
200
 
201
 (defmethod make-load-form ((sql sql-ident-expression) &optional environment)
202
   (with-slots (ident expression) sql
203
     `(make-instance 'sql-ident-expression
204
        :ident ,(make-load-form ident environment)
205
        :expression ,(make-load-form expression environment))))
206
 
207
 (defmethod output-sql ((expr sql-ident-expression) database)
208
   (with-slots (ident expression) expr
209
     (output-sql expression database)
210
     (write-string " AS " clsql-sys::*sql-stream*)
211
     (output-sql ident database))
212
   t)
213
 
214
 (defmethod output-sql-hash-key ((expr sql-ident-expression) database)
215
   (with-slots (ident expression) expr
216
     (list (and database (database-underlying-type database))
217
           'sql-ident-expression
218
           (output-sql-hash-key ident nil)
219
           (output-sql-hash-key expression nil))))
220
 
221
 
222
 ;;; relax from constraint
223
 
224
 (defun make-query (&rest args)
225
   (flet ((select-objects (target-args)
226
            (and target-args
227
                 (every #'(lambda (arg)
228
                            (and (symbolp arg)
229
                                 (find-class arg nil)))
230
                        target-args))))
231
     (multiple-value-bind (selections arglist)
232
         (query-get-selections args)
233
       (if (select-objects selections)
234
           (destructuring-bind (&key flatp refresh &allow-other-keys) arglist
235
             (make-instance 'sql-object-query :objects selections
236
                            :flatp flatp :refresh refresh
237
                            :exp arglist))
238
           (destructuring-bind (&key all flatp set-operation distinct from where
239
                                     group-by having order-by
240
                                     offset limit inner-join on &allow-other-keys)
241
               arglist
242
             (unless selections
243
               (spocq.e:request-error "No target columns supplied to select statement: ~a"
244
                                      args))
245
             #+(or)
246
             (if (null from)
247
                 (error "No source tables supplied to select statement."))
248
             (make-instance 'sql-query :selections selections
249
                            :all all :flatp flatp :set-operation set-operation
250
                            :distinct distinct :from from :where where
251
                            :limit limit :offset offset
252
                            :group-by group-by :having having :order-by order-by
253
                            :inner-join inner-join :on on))))))