query-set.lisp 40 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054
  1. ;; orizuru-orm: a simple orm for Common lisp Copyright (C) 2019
  2. ;; Universita' degli Studi di Palermo
  3. ;; This program is free software: you can redistribute it and/or
  4. ;; modify it under the terms of the GNU General Public License as
  5. ;; published by the Free Software Foundation, version 3 of the
  6. ;; License, or (at your option) any later version.
  7. ;; This program is distributed in the hope that it will be useful, but
  8. ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  9. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
  10. ;; General Public License for more details.
  11. ;; You should have received a copy of the GNU General Public License
  12. ;; along with this program. If not, see
  13. ;; <http://www.gnu.org/licenses/>.
  14. (in-package :orizuru-orm.query-set)
  15. (define-constant +allowed-logical-op+ '(:and :or :not) :test #'equalp)
  16. (eval-when (:compile-toplevel :load-toplevel :execute)
  17. (define-constant +table-splitter+ "->" :test #'string=)
  18. (define-constant +table-field-splitter+ "_" :test #'string=)
  19. (define-constant +op-scanner+ "[^.]+$" :test #'string=)
  20. (define-constant +op=+ "=" :test #'string=)
  21. (define-constant +op<+ "<" :test #'string=)
  22. (define-constant +op>+ ">" :test #'string=)
  23. (define-constant +op<=+ "<=" :test #'string=)
  24. (define-constant +op>=+ ">=" :test #'string=)
  25. (define-constant +op-like+ "LIKE" :test #'string=)
  26. (define-constant +op-ilike+ "ILIKE" :test #'string=))
  27. (define-constant +trim-op+ (strcat "(?i)[^a-z]+("
  28. "(" +op=+ ")"
  29. "|(" +op<+ ")"
  30. "|(" +op>+ ")"
  31. "|(" +op<=+ ")"
  32. "|(" +op>=+ ")"
  33. "|(" +op-like+ ")"
  34. "|(" +op-ilike+ "))$")
  35. :test #'string=)
  36. (define-constant +re-op+ (strcat "(?i)("
  37. "(" +op=+ ")"
  38. "|(" +op<+ ")"
  39. "|(" +op>+ ")"
  40. "|(" +op<=+ ")"
  41. "|(" +op>=+ ")"
  42. "|(" +op-like+ ")"
  43. "|(" +op-ilike+ ")"
  44. ")$")
  45. :test #'string=)
  46. (defgeneric ->sxql (object))
  47. (defmethod ->sxql ((object list))
  48. (mapcar #'->sxql object))
  49. (defmethod ->sxql (object)
  50. object)
  51. (defclass query-set ()
  52. ((parent
  53. :initform nil
  54. :initarg :parent
  55. :accessor parent)
  56. (children
  57. :initform '()
  58. :initarg :children
  59. :accessor children)
  60. (columns
  61. :initform :*
  62. :initarg :columns
  63. :accessor columns)))
  64. (defun set-all-parents* (parent children)
  65. (loop for child in children do
  66. (setf (parent child) parent))
  67. parent)
  68. (defun set-all-parents (parent)
  69. (set-all-parents* parent (children parent)))
  70. (defmethod initialize-instance :after ((object query-set) &key &allow-other-keys)
  71. (set-all-parents object))
  72. (defparameter *compile-sxql-tree* t)
  73. (defmethod ->sxql ((object query-set))
  74. (if *compile-sxql-tree*
  75. (funcall (compile nil
  76. `(lambda () ,(->sxql (first (children object))))))
  77. (->sxql (first (children object)))))
  78. (defgeneric all-from-set (object &key as-plist))
  79. (defmethod all-from-set ((object query-set) &key (as-plist nil))
  80. (let* ((table (first (tables-only (children object))))
  81. (symbol-table (ensure-symbol (or (class-mapped table)
  82. (table table))))
  83. (query-results (query (->sxql object))))
  84. (flet ((map-to-plist (a)
  85. (identity a))
  86. (map-to-class-instance (a)
  87. (orizuru-orm.interface:plist->object symbol-table a)))
  88. (let ((map-fn (if as-plist
  89. #'map-to-plist
  90. #'map-to-class-instance)))
  91. (mapcar map-fn query-results)))))
  92. (defgeneric query-set= (a b))
  93. (defgeneric dfs (object fn))
  94. (defmethod dfs ((object query-set) fn)
  95. (loop for child in (children object) do
  96. (funcall fn object child)
  97. (dfs child fn)))
  98. (defmethod %clone (from)
  99. (let ((cloned (make-instance (type-of from)
  100. :children (clone (children from)))))
  101. (dfs cloned
  102. (lambda (new-parent child)
  103. (setf (parent child) new-parent)))
  104. cloned))
  105. (defmethod clone ((object query-set))
  106. (%clone object))
  107. (defparameter *print-indent-spaces* "")
  108. (defun increase-indent-space ()
  109. (concatenate 'string *print-indent-spaces* " "))
  110. (defmacro with-increased-indent (&body body)
  111. `(let ((*print-indent-spaces* (increase-indent-space)))
  112. ,@body))
  113. (defun print-indent-spaces (stream)
  114. (format stream *print-indent-spaces*))
  115. (defun print-new-line (stream)
  116. (format stream "~%"))
  117. (defmacro with-print-new-line ((stream) &body body)
  118. `(progn
  119. ,@body
  120. (print-new-line ,stream)))
  121. (defun print-children (query-set print-fn)
  122. (dolist (child (children query-set))
  123. (funcall print-fn child)))
  124. (defun %print-object (object stream)
  125. (print-new-line stream)
  126. (with-print-new-line (stream)
  127. (with-increased-indent
  128. (print-children object
  129. (lambda (c)
  130. (print-object c stream))))))
  131. (defmethod print-object ((object query-set) stream)
  132. (print-unreadable-object (object stream :type t :identity nil)
  133. (%print-object object stream)))
  134. (defclass table-query-set (query-set)
  135. ((table
  136. :initform nil
  137. :initarg :table
  138. :accessor table)
  139. (class-mapped
  140. :initform nil
  141. :initarg :class-mapped
  142. :accessor class-mapped
  143. :type symbol)))
  144. (defmethod clone ((object table-query-set))
  145. (let ((cloned (%clone object)))
  146. (setf (table cloned) (table object))
  147. (setf (class-mapped cloned) (class-mapped object))
  148. cloned))
  149. (defmethod (setf class-mapped) (value (object query-set))
  150. (let ((all-tables (tables-only (children object))))
  151. (loop for table in all-tables do
  152. (setf (class-mapped table) value)))
  153. object)
  154. (defparameter *full-select-table-sxql* t)
  155. (defmethod ->sxql ((object table-query-set))
  156. (if *full-select-table-sxql*
  157. (let ((actual-table (or (class-mapped object)
  158. (table object)))
  159. (actual-columns (if (listp (columns object))
  160. (columns object)
  161. (list (columns object)))))
  162. (append `(sxql:select (,@(loop for column in actual-columns collect
  163. (make-table-column actual-table column))))
  164. `((sxql:from ,(table object)))
  165. (if (children object)
  166. (append
  167. (when-let ((joins (joins-only (children object))))
  168. `(,@(->sxql joins)))
  169. (when-let ((filters (logical-ops-only (children object))))
  170. `((sxql:where ,@(->sxql filters)))))
  171. nil)))
  172. `(,(table object))))
  173. (defmethod print-object ((object table-query-set) stream)
  174. (with-print-new-line (stream)
  175. (print-indent-spaces stream)
  176. (format stream "table: ~s~%" (table object))
  177. (with-increased-indent
  178. (print-children object
  179. (lambda (c)
  180. (print-object c stream))))))
  181. (defclass logical-assoc-query-set (query-set)
  182. ((operator
  183. :initform :and
  184. :initarg :operator
  185. :accessor operator)))
  186. (defmethod ->sxql ((object logical-assoc-query-set))
  187. (with-accessors ((operator operator)
  188. (children children)) object
  189. (append (list operator)
  190. (->sxql children))))
  191. (defmethod clone ((object logical-assoc-query-set))
  192. (let ((clone (%clone object)))
  193. (setf (operator clone)
  194. (operator object))
  195. clone))
  196. (defmethod print-object ((object logical-assoc-query-set) stream)
  197. (with-print-new-line (stream)
  198. (print-indent-spaces stream)
  199. (format stream "[~s~%" (operator object))
  200. (with-increased-indent
  201. (print-children object
  202. (lambda (c)
  203. (print-object c stream))))
  204. (print-indent-spaces stream)
  205. (format stream "]")))
  206. (defclass filtered-query-set (query-set)
  207. ((operation
  208. :initform :=
  209. :initarg :operation
  210. :accessor operation)
  211. (lhs-column
  212. :initform nil
  213. :initarg :lhs-column
  214. :accessor lhs-column)
  215. (rhs-column
  216. :initform nil
  217. :initarg :rhs-column
  218. :accessor rhs-column)))
  219. (defun remap-ilike (column val)
  220. `(:like (:upper ,column)
  221. (:upper ,val)))
  222. (defun remap-filter (operation lhs rhs)
  223. (if lhs
  224. (if rhs
  225. (case operation
  226. (:ilike
  227. (remap-ilike lhs rhs))
  228. (otherwise
  229. (list operation lhs rhs)))
  230. (list operation lhs))
  231. (list operation rhs)))
  232. (defmethod ->sxql ((object filtered-query-set))
  233. (with-accessors ((operation operation)
  234. (lhs-column lhs-column)
  235. (rhs-column rhs-column)) object
  236. (remap-filter operation lhs-column rhs-column)))
  237. (defmethod clone ((object filtered-query-set))
  238. (let ((clone (%clone object)))
  239. (setf (operation clone) (operation object)
  240. (lhs-column clone) (lhs-column object)
  241. (rhs-column clone) (rhs-column object))
  242. clone))
  243. (defmethod print-object ((object filtered-query-set) stream)
  244. (with-print-new-line (stream)
  245. (print-indent-spaces stream)
  246. (format stream "{ ~s " (operation object))
  247. (format stream "~s ~s" (lhs-column object) (rhs-column object))
  248. (format stream " }")))
  249. (defgeneric add-filter (object child &key logical-op operation lhs rhs))
  250. (defgeneric nadd-filter (object child &key logical-op operation lhs rhs)
  251. (:documentation "Impure version of add-filter"))
  252. (defgeneric add-table (object child)
  253. (:documentation "Add a table as child of this query set"))
  254. (defgeneric nadd-table (object child)
  255. (:documentation "Impure version of add-table"))
  256. (defun push-child (parent child &key (test #'query-set=) (parent-set parent))
  257. "helper function to add a child to a query set"
  258. (when child
  259. (setf (parent child) parent-set)
  260. (pushnew child (children parent) :test test)
  261. child))
  262. (defun append-children (parent &rest all-children)
  263. (let ((res '()))
  264. (loop for children in all-children do
  265. (loop for child in children do
  266. (pushnew child res :test #'query-set=)))
  267. (set-all-parents* parent res)
  268. res))
  269. (defun find-child (parent predicate)
  270. (with-accessors ((children children)) parent
  271. (loop
  272. for ct from 0 below (length children)
  273. for child in children do
  274. (when (funcall predicate ct child)
  275. (return-from find-child (values child ct))))
  276. (loop for child in children do
  277. (find-child child predicate))))
  278. (defun find-logical-relation (query-set)
  279. (find-child query-set
  280. (lambda (ct q)
  281. (declare (ignore ct))
  282. (typep q 'logical-assoc-query-set))))
  283. (defun non-recursive-collect-child (parent predicate)
  284. (with-accessors ((children children)) parent
  285. (loop
  286. for ct from 0 below (length children)
  287. for child in children
  288. when (funcall predicate ct child)
  289. collect child)))
  290. (defun make-query-set-and (parent)
  291. (make-instance 'logical-assoc-query-set
  292. :parent parent))
  293. (defun signal-error (text)
  294. (error 'query-set-error :text text))
  295. (defun signal-if-lhs-and-rhs-null (lhs rhs)
  296. (when (or (null lhs) (null rhs))
  297. (signal-error (format nil "In filtering, both lhs and rhs are empty."))))
  298. (defmacro with-clone ((cloned from) &body body)
  299. `(let ((,cloned (clone ,from)))
  300. ,@body))
  301. (defun remove-child (query-set predicate)
  302. (setf (children query-set)
  303. (remove-if predicate (children query-set))))
  304. (defmethod add-filter ((object query-set) (child table-query-set)
  305. &key
  306. (logical-op nil)
  307. (operation :=)
  308. (lhs nil)
  309. (rhs nil))
  310. (labels ((make-wrapper (operator)
  311. (make-instance 'logical-assoc-query-set :operator operator))
  312. (add-filter-not (cloned-query child lhs rhs operation)
  313. (let* ((wrapper (make-wrapper :and))
  314. (not-wrapper (push-child wrapper (make-instance 'logical-assoc-query-set
  315. :operator :not))))
  316. (push-child not-wrapper
  317. (make-instance 'filtered-query-set
  318. :lhs-column lhs
  319. :rhs-column rhs
  320. :operation operation))
  321. (setf cloned-query (add-filter cloned-query
  322. child
  323. :logical-op wrapper))
  324. cloned-query))
  325. (add-filter-keyword (cloned-query child lhs rhs operation operator)
  326. (let* ((wrapper (make-wrapper operator)))
  327. (setf wrapper (add-filter wrapper
  328. nil
  329. :lhs lhs
  330. :rhs rhs
  331. :operation operation))
  332. (setf cloned-query (add-filter cloned-query
  333. child
  334. :logical-op wrapper))
  335. cloned-query)))
  336. (with-clone (cloned-query object)
  337. (let* ((actual-child (find-table-or-join cloned-query
  338. child
  339. :test #'eq
  340. :extract-key-searching-for #'table
  341. :extract-key-child #'table))
  342. (existing-logical-op (find-logical-relation actual-child))
  343. (actual-logical-op (or logical-op existing-logical-op)))
  344. (if actual-logical-op
  345. (cond
  346. ((null existing-logical-op)
  347. (push-child actual-child
  348. (add-filter actual-logical-op
  349. nil
  350. :operation operation
  351. :lhs lhs
  352. :rhs rhs))
  353. cloned-query)
  354. ((eq existing-logical-op actual-logical-op)
  355. (let ((new-filter (add-filter actual-logical-op
  356. nil
  357. :operation operation
  358. :lhs lhs
  359. :rhs rhs)))
  360. (remove-child actual-child (lambda (a) (eq a actual-logical-op)))
  361. (push-child actual-child new-filter)
  362. cloned-query))
  363. ((typep actual-logical-op 'keyword)
  364. (if (eq actual-logical-op :not)
  365. (add-filter-not cloned-query actual-child lhs rhs operation)
  366. (add-filter-keyword cloned-query
  367. actual-child
  368. lhs rhs
  369. operation
  370. actual-logical-op)))
  371. (t
  372. (with-clone (cloned-actual-logical-op actual-logical-op)
  373. (let ((joins (joins-only (children actual-child))))
  374. (setf (children actual-child) joins)
  375. (setf (children cloned-actual-logical-op)
  376. (append-children cloned-actual-logical-op
  377. (list existing-logical-op)
  378. (children cloned-actual-logical-op)))
  379. (let ((new-filter (add-filter cloned-actual-logical-op
  380. nil
  381. :operation operation
  382. :lhs lhs
  383. :rhs rhs)))
  384. (push-child actual-child new-filter)
  385. cloned-query)))))
  386. (progn
  387. (push-child actual-child
  388. (add-filter (make-instance 'logical-assoc-query-set
  389. :operator :and)
  390. nil
  391. :operation operation
  392. :lhs lhs
  393. :rhs rhs))
  394. cloned-query))))))
  395. (defun find-table-or-join (query-set searching-for
  396. &key
  397. (extract-key-searching-for #'identity)
  398. (extract-key-child #'table)
  399. (test #'eq))
  400. (let ((res (find-child query-set
  401. (lambda (ct c)
  402. (declare (ignore ct))
  403. (and (typep c 'table-query-set)
  404. (funcall test
  405. (funcall extract-key-child c)
  406. (funcall extract-key-searching-for searching-for)))))))
  407. (if (null res)
  408. (restart-case
  409. (signal-error (format nil "in query-set~2%~a table or join~2%~s not found" res searching-for))
  410. (use-any-tables-available ()
  411. (or (first (tables-only (children query-set)))
  412. (signal-error (format nil "No table in query-set~2%~a" query-set)))))
  413. res)))
  414. (defmethod add-filter ((object query-set) (child symbol)
  415. &key
  416. (logical-op nil)
  417. (operation :=)
  418. (lhs nil)
  419. (rhs nil))
  420. (with-clone (cloned-query object)
  421. (let ((table-or-join (find-table-or-join cloned-query child)))
  422. (add-filter cloned-query
  423. table-or-join
  424. :logical-op logical-op
  425. :operation operation
  426. :lhs lhs
  427. :rhs rhs))))
  428. (defmethod add-filter ((object query-set) (child filtered-query-set)
  429. &key
  430. logical-op
  431. operation
  432. lhs
  433. rhs)
  434. (declare (ignore logical-op operation lhs rhs))
  435. (with-clone (cloned-query object)
  436. (with-clone (cloned-filter child)
  437. (setf cloned-query
  438. (add-filter cloned-query
  439. (first (tables-only (children cloned-query)))
  440. :rhs (rhs-column cloned-filter)
  441. :lhs (lhs-column cloned-filter)
  442. :operation (operation cloned-filter)
  443. :logical-op :and))
  444. cloned-query)))
  445. (defmacro make-qset (chain-join param)
  446. `(filter-set ,chain-join ,param))
  447. (defmacro filter-set (&optional qset params logical-op)
  448. (assert (or qset params))
  449. (cond
  450. (logical-op
  451. `(add-filter ,qset (list ,(first params) ,(second params)) :logical-op ,logical-op))
  452. ((listp params)
  453. (if (scan +table-splitter+ (symbol-name (first params)))
  454. `(add-join ,qset (list ,(first params) ,(second params)))
  455. `(add-filter ,qset (list ,(first params) ,(second params)))))
  456. (t
  457. `(add-join ,qset (list ,params nil)))))
  458. (defgeneric %make-query-set (child))
  459. (defmethod %make-query-set ((child symbol))
  460. (if (sym-w/joins-p child)
  461. (multiple-value-bind (op join filter-column)
  462. (sym->join-fields child)
  463. (cond
  464. (op
  465. (signal-error (format nil
  466. (strcat "Operation symbol '~a' not allowed without an operator "
  467. "in this query: '~a'~%"
  468. "Operations are allowed when both a query symbol and a value "
  469. "are submitted to this function like: "
  470. "'(make-query-set foo_bar.= 1)' (i.e. with two parameters).")
  471. op child)))
  472. ((and (null join)
  473. (null filter-column))
  474. (signal-error (format nil "cannot parse the query symbol: ~a" child)))
  475. (t
  476. (let* ((table (first join))
  477. (root (make-instance 'query-set
  478. :children (list (make-instance 'table-query-set
  479. :table table)))))
  480. (filter-set root child)))))
  481. (let* ((root (make-instance 'query-set
  482. :children (list (make-instance 'table-query-set
  483. :table child)))))
  484. root)))
  485. (defmethod %make-query-set ((child null))
  486. (make-instance 'query-set))
  487. (defmacro make-query-set (&optional (from nil) (param nil))
  488. (if (null param)
  489. `(%make-query-set ,from)
  490. `(add-filter ,from ,param)))
  491. (defmethod add-filter ((object logical-assoc-query-set)
  492. (child null)
  493. &key
  494. (logical-op nil)
  495. (operation :=)
  496. (lhs nil)
  497. (rhs nil))
  498. (with-clone (cloned-query object)
  499. (nadd-filter cloned-query
  500. child
  501. :logical-op logical-op
  502. :operation operation
  503. :lhs lhs
  504. :rhs rhs)))
  505. (defmethod nadd-filter ((object logical-assoc-query-set) (child null)
  506. &key
  507. (logical-op nil)
  508. (operation :=)
  509. (lhs nil)
  510. (rhs nil))
  511. (declare (ignore logical-op))
  512. (if (or lhs rhs)
  513. (let ((new-child (make-instance 'filtered-query-set
  514. :operation operation
  515. :lhs-column lhs
  516. :rhs-column rhs)))
  517. (push-child object new-child :test #'filtered-set=)
  518. object)
  519. object))
  520. (defmethod add-table ((object query-set) child)
  521. (with-clone (cloned-query object)
  522. (nadd-table cloned-query child)))
  523. (defmethod nadd-table ((object query-set) (child table-query-set))
  524. (push-child object child)
  525. object)
  526. (defmethod nadd-table ((object query-set) (child symbol))
  527. (nadd-table object
  528. (make-instance 'table-query-set
  529. :table child)))
  530. (defclass union-query-set (query-set) ())
  531. (defmethod print-object ((object union-query-set) stream)
  532. (with-print-new-line (stream)
  533. (print-indent-spaces stream)
  534. (format stream "( union~%")
  535. (with-increased-indent
  536. (%print-object object stream))
  537. (print-indent-spaces stream)
  538. (format stream ")")))
  539. (defmacro union-op (&body body)
  540. `(sxql::union-queries ,@body))
  541. (defmethod ->sxql ((object union-query-set))
  542. (append `(union-op ,@(->sxql (children object)))))
  543. (defgeneric add-union (object table))
  544. (defgeneric nadd-union (object table))
  545. (defmethod add-union (object (table null))
  546. (clone object))
  547. (defmacro gen-test-type (&rest types)
  548. `(progn
  549. ,@(loop for the-type in types collect
  550. (let ((fn-name (symbolicate (regex-replace "-QUERY-SET" (symbol-name the-type) "")
  551. "-P-FN")))
  552. `(defun ,fn-name (a)
  553. (typep a ',the-type))))))
  554. (gen-test-type table-query-set
  555. union-query-set
  556. join-query-set
  557. filtered-query-set
  558. logical-assoc-query-set)
  559. (defun tables-only (children)
  560. (remove-if-not #'table-p-fn children))
  561. (defun unions-only (children)
  562. (remove-if-not #'union-p-fn children))
  563. (defun joins-only (children)
  564. (remove-if-not #'join-p-fn children))
  565. (defun filters-only (children)
  566. (remove-if-not #'filtered-p-fn children))
  567. (defun logical-ops-only (children)
  568. (remove-if-not #'logical-assoc-p-fn children))
  569. (defun tables-unions-only (children)
  570. (remove-if-not (lambda (b)
  571. (or (table-p-fn b)
  572. (union-p-fn b)))
  573. children))
  574. (defmethod add-union ((object query-set) (other-query-set query-set))
  575. (with-clone (cloned-object object)
  576. (with-clone (cloned-other other-query-set)
  577. (let ((old-tables-or-unions (clone (tables-unions-only (children cloned-object))))
  578. (old-others-tables-or-unions (clone (tables-unions-only (children cloned-other))))
  579. (union-set (make-instance 'union-query-set)))
  580. (loop for i in old-tables-or-unions do
  581. (setf union-set (add-union union-set i)))
  582. (loop for i in old-others-tables-or-unions do
  583. (setf union-set (add-union union-set i)))
  584. (setf (children cloned-object) (list union-set))
  585. cloned-object))))
  586. (defmethod add-union ((object query-set) (union-set union-query-set))
  587. (with-clone (cloned-object object)
  588. (with-clone (cloned-union union-set)
  589. (let ((old-tables (clone (tables-only (children cloned-object))))
  590. (old-unions (clone (unions-only (children cloned-object))))
  591. (new-union-set (make-instance 'union-query-set)))
  592. (cond
  593. ((and (null (children object)))
  594. (make-instance 'query-set :children (list union-set)))
  595. (t
  596. (loop for table in old-tables do
  597. (setf cloned-union (add-union cloned-union table)))
  598. (loop for union in old-unions do
  599. (setf new-union-set (add-union new-union-set old-unions)))
  600. (let ((new-union (add-union new-union-set cloned-union)))
  601. (setf cloned-object (add-union (make-instance 'query-set) new-union))
  602. cloned-object)))))))
  603. (defmethod add-union ((object union-query-set) (table table-query-set))
  604. (with-clone (cloned-object object)
  605. (nadd-union cloned-object (clone table))
  606. cloned-object))
  607. (defmethod nadd-union ((object union-query-set) (table table-query-set))
  608. (push-child object (clone table))
  609. object)
  610. (defmethod add-union ((object union-query-set) (other union-query-set))
  611. (with-clone (clone object)
  612. (with-clone (other-clone other)
  613. (let ((res (make-instance 'union-query-set :children (children clone))))
  614. (loop for child in (children other-clone) do
  615. (push-child res child :test #'query-set=))
  616. res))))
  617. (defmethod add-union ((object query-set) (table table-query-set))
  618. (call-next-method (clone object)
  619. (make-instance 'union-query-set
  620. :children (list (clone table)))))
  621. (defmethod add-union ((object table-query-set) (table table-query-set))
  622. (make-instance 'union-query-set
  623. :children (list (clone object) (clone table))))
  624. (defmethod query-set= (a b)
  625. (equal a b))
  626. (defun children= (a b)
  627. (and (length= (children a) (children b))
  628. (set-equal (children a) (children b) :test #'query-set=)))
  629. (defmethod query-set= ((a query-set) (b query-set))
  630. (and (type= (type-of a) (type-of b))
  631. (children= a b)))
  632. (defmethod query-set= ((a table-query-set) (b table-query-set))
  633. (and (eq (table a) (table b))
  634. (children= a b)))
  635. (defmethod query-set= ((a logical-assoc-query-set) (b logical-assoc-query-set))
  636. (and (eq (operator a) (operator b))
  637. (children= a b)))
  638. (defun filtered-set= (a b)
  639. (and (type= (type-of a)
  640. (type-of b))
  641. (eq (operation a)
  642. (operation b))
  643. (equal (lhs-column a)
  644. (lhs-column b))
  645. (equal (rhs-column a)
  646. (rhs-column b))))
  647. (defmethod query-set= ((a filtered-query-set) (b filtered-query-set))
  648. (filtered-set= a b))
  649. (defclass join-query-set (table-query-set)
  650. ((join-type
  651. :initform 'sxql:inner-join
  652. :initarg :join-type
  653. :accessor join-type)
  654. (join-clause
  655. :initform nil
  656. :initarg :join-clause
  657. :accessor join-clause)))
  658. (defmethod clone ((object join-query-set))
  659. (let ((clone (%clone object)))
  660. (setf (table clone) (clone (table object))
  661. (join-type clone) (clone (join-type object))
  662. (join-clause clone) (clone (join-clause object)))
  663. clone))
  664. (defmethod ->sxql ((object join-query-set))
  665. `(,(->sxql (join-type object))
  666. ,@(let ((*full-select-table-sxql* nil))
  667. (->sxql (table object)))
  668. :on
  669. ,(->sxql (join-clause object))))
  670. (defmethod print-object ((object join-query-set) stream)
  671. (with-print-new-line (stream)
  672. (print-indent-spaces stream)
  673. (format stream "[~s~%" (join-type object))
  674. (with-increased-indent
  675. (print-indent-spaces stream)
  676. (format stream "~s" (table object))
  677. (print-indent-spaces stream)
  678. (format stream "on~%")
  679. (print-indent-spaces stream)
  680. (format stream "~s" (join-clause object)))
  681. (print-indent-spaces stream)
  682. (format stream "]")))
  683. (defmethod query-set= ((a join-query-set) (b join-query-set))
  684. (and (children= a b)
  685. (query-set= (table a) (table b))
  686. (query-set= (join-type a) (join-type b))
  687. (query-set= (join-clause a) (join-clause b))))
  688. (defgeneric add-join (object join &key &allow-other-keys))
  689. (defgeneric nadd-join (object join &key &allow-other-keys))
  690. (defmethod add-join ((object table-query-set) (join join-query-set) &key &allow-other-keys)
  691. (with-clone (cloned-object object)
  692. (with-clone (cloned-join join)
  693. (nadd-join cloned-object cloned-join))))
  694. (defmethod nadd-join ((object table-query-set) (join join-query-set) &key &allow-other-keys)
  695. (push-child object join)
  696. object)
  697. (defmethod add-join ((object query-set) (join join-query-set) &key &allow-other-keys)
  698. (with-clone (cloned-object object)
  699. (let ((all-tables (tables-only (children cloned-object))))
  700. (loop for table in all-tables do
  701. (nadd-join table (clone join)))
  702. cloned-object)))
  703. (defmethod add-join ((object query-set) (join list) &key &allow-other-keys)
  704. (with-clone (cloned-object object)
  705. (multiple-value-bind (tables joins filters)
  706. (sym->join (first join) (second join))
  707. (declare (ignore tables))
  708. (loop for join in joins do
  709. (setf cloned-object (add-join cloned-object join)))
  710. (loop for filter in filters do
  711. (setf cloned-object (add-filter cloned-object filter)))
  712. cloned-object)))
  713. (defgeneric split-tables-name (query))
  714. (defmethod split-tables-name ((query string))
  715. (split +table-splitter+ query))
  716. (defmethod split-tables-name ((query symbol))
  717. (split-tables-name (symbol-name query)))
  718. (defmacro sym->op-case (query-as-symbol candidate-op &rest allowed-ops)
  719. `(case (make-keyword ,candidate-op)
  720. ,@(append
  721. (loop for allowed-op in allowed-ops collect
  722. `(,(make-keyword (symbol-value (find-symbol (symbol-name allowed-op))))
  723. (make-keyword ,candidate-op)))
  724. `((otherwise
  725. (signal-error (format nil
  726. "in ~a: ~a is not a recognized operation."
  727. ,query-as-symbol
  728. ,candidate-op)))))))
  729. (defun sym->op (query-as-symbol)
  730. (let* ((op-raw (scan-to-strings +op-scanner+ (symbol-name query-as-symbol))))
  731. (if (string-equal op-raw query-as-symbol)
  732. nil
  733. (sym->op-case query-as-symbol op-raw
  734. +op=+
  735. +op<+
  736. +op<=+
  737. +op>+
  738. +op>=+
  739. +op-like+
  740. +op-ilike+))))
  741. (defun make-table-column (table column)
  742. (make-keyword (symbolicate table "." column)))
  743. ;;TODO: fix this function, works but it is incidental
  744. (defun sym-w/explicit-column-p (query-as-symbol)
  745. (scan +table-field-splitter+ (symbol-name query-as-symbol)))
  746. (defun sym-w/joins-p (query-as-symbol)
  747. (scan +table-splitter+ (symbol-name query-as-symbol)))
  748. (defun sym-join-fields-w/explicit-column (query-as-symbol)
  749. (when-let* ((query (symbol-name query-as-symbol))
  750. (op (sym->op query-as-symbol))
  751. (op-name (symbol-name op))
  752. (tables-field (split +table-field-splitter+
  753. (regex-replace (concatenate 'string
  754. "(?i)[^a-z].?"
  755. op-name
  756. "$")
  757. query
  758. "")))
  759. (tables (mapcar (lambda (a) (make-keyword (regex-replace +trim-op+ a "")))
  760. (split-tables-name (first tables-field))))
  761. (filter-column (make-keyword (second tables-field))))
  762. (values op tables filter-column)))
  763. (defun sym->join-fields (query-as-symbol)
  764. (cond
  765. ((sym-w/explicit-column-p query-as-symbol)
  766. (sym-join-fields-w/explicit-column query-as-symbol))
  767. (t
  768. (let ((op (sym->op query-as-symbol))
  769. (tables (mapcar (lambda (a) (make-keyword (regex-replace +trim-op+ a "")))
  770. (split-tables-name query-as-symbol))))
  771. (values op tables nil)))))
  772. (defun sym->join-p (query-as-symbol)
  773. (handler-case
  774. (sym->join-fields query-as-symbol)
  775. (query-set-error () nil)))
  776. (defun sym->join (query-as-symbol filter-data)
  777. (labels ((foreign-slot-name (table-from table-to)
  778. (let ((all-references (foreign-reference-between table-from table-to)))
  779. (if (> (length all-references) 1)
  780. (restart-case
  781. (error (make-instance 'query-set-foreign-reference-error
  782. :text
  783. (format nil
  784. "table ~a has more than one reference to ~a: ~a"
  785. table-from table-to all-references)))
  786. (use-value (v) v))
  787. (first all-references))))
  788. (chain-join (table-1 table-2)
  789. (let ((foreign-slot-name (foreign-slot-name table-1 table-2)))
  790. (if (null foreign-slot-name)
  791. (signal-error (format nil
  792. "table ~a has not foreign reference to table ~a"
  793. table-1
  794. table-2))
  795. (make-instance 'join-query-set
  796. :join-clause
  797. (make-instance 'filtered-query-set
  798. :operation :=
  799. :lhs-column (make-table-column table-1
  800. foreign-slot-name)
  801. :rhs-column (make-table-column table-2
  802. +id-column-name+))
  803. :table (make-instance 'table-query-set
  804. :table table-2))))))
  805. (multiple-value-bind (op tables filter-rhs)
  806. (sym->join-fields query-as-symbol)
  807. (let ((actual-filter-rhs (or filter-rhs
  808. +id-column-name+)))
  809. (cond
  810. ((null tables)
  811. (signal-error (format nil "Error parsing: ~a." query-as-symbol)))
  812. ((= (length tables) 1)
  813. (values tables
  814. nil
  815. (list (make-instance 'filtered-query-set
  816. :operation op
  817. :lhs-column (make-table-column (last-elt tables)
  818. actual-filter-rhs)
  819. :rhs-column filter-data))))
  820. (t
  821. (let* ((first-table (first tables))
  822. (second-table (second tables))
  823. (last-table (last-elt tables))
  824. (first-join (chain-join first-table second-table))
  825. (rest-join (loop for (table-1 table-2) on (rest tables) while table-2 collect
  826. (chain-join table-1 table-2)))
  827. (filter (and filter-data
  828. (make-instance 'filtered-query-set
  829. :operation op
  830. :lhs-column (make-table-column last-table
  831. actual-filter-rhs)
  832. :rhs-column filter-data))))
  833. (values tables
  834. (reverse (append (list first-join) rest-join))
  835. (and filter (list filter))))))))))
  836. (defun sym->filter-fields (query-as-symbol)
  837. (when-let* ((symb-name (symbol-name query-as-symbol))
  838. (table-rest (split +table-field-splitter+ symb-name))
  839. (field (split "[^A-Z]+$" (second table-rest)))
  840. (op (scan-to-strings +re-op+ symb-name)))
  841. (values (make-keyword (first table-rest))
  842. (make-keyword (first field))
  843. (make-keyword op))))
  844. (defun sym->filter-p (query-as-symbol)
  845. (sym->filter-fields query-as-symbol))
  846. (defun sym->filter (query-as-symbol val)
  847. (multiple-value-bind (table column op)
  848. (sym->filter-fields query-as-symbol)
  849. (if (find-slot-name table column)
  850. (list table :operation op :lhs (make-table-column table column) :rhs val)
  851. (signal-error (format nil "No slots ~a found in class ~a" column table)))))
  852. (defun use-first-table-available (c)
  853. (declare (ignore c))
  854. (when-let ((restart (find-restart 'use-any-tables-available)))
  855. (invoke-restart restart)))
  856. (defmethod add-filter ((object query-set) (child list) &key logical-op operation lhs rhs)
  857. (declare (ignore operation lhs rhs))
  858. (cond
  859. ((< (length child) 2)
  860. (signal-error (format nil "Error, list ~a is too short (minimum two elements)." child)))
  861. ((sym->filter-p (first child))
  862. (handler-bind ((query-set-error #'use-first-table-available))
  863. (apply #'add-filter (append (list object)
  864. (sym->filter (first child) (second child))
  865. (list :logical-op logical-op)))))
  866. (t
  867. (signal-error (format nil "Unrecognized list parameter ~a" child)))))
  868. (defmethod add-filter ((object query-set) (child null) &key logical-op operation lhs rhs)
  869. (declare (ignore logical-op operation lhs rhs))
  870. object)
  871. (defmethod add-filter ((object symbol) child &key logical-op operation lhs rhs)
  872. (declare (ignore logical-op))
  873. (cond
  874. ((member object +allowed-logical-op+)
  875. (add-filter (make-instance 'logical-assoc-query-set :operator object)
  876. nil
  877. :operation operation
  878. :lhs lhs
  879. :rhs rhs))
  880. (t
  881. (multiple-value-bind (tables joins filters)
  882. (sym->join object child)
  883. (let* ((pivot-table (first-elt tables))
  884. (res (make-query-set pivot-table)))
  885. (loop for join in joins do
  886. (setf res (add-join res join)))
  887. (loop for filter in filters do
  888. (setf res (add-filter res filter)))
  889. res)))))
  890. ;; utilities
  891. (defmacro with-table-package ((the-package) &body body)
  892. `(let* ((orizuru-orm.util:*foreign-slots-class-package* ,the-package))
  893. ,@body))
  894. (defmacro with-join-column ((column) &body body)
  895. `(handler-bind ((orizuru-orm.errors:query-set-foreign-reference-error
  896. (invoke-restart (find-restart 'use-value) ,column)))
  897. ,@body))
  898. (defun map-to-model (query-set class-symbol)
  899. (with-clone (cloned-object query-set)
  900. (setf (class-mapped cloned-object) class-symbol)
  901. cloned-object))