2sql.lisp (7621B)
1 ;;; cl-2sql Copyright (c) 2011 Tomas Hlavaty 2 3 (defpackage 2sql 4 (:use :cl) 5 (:export :*backend* 6 :*server* 7 ;; printer 8 ;;:print-string 9 :print-symbol 10 ;;:print-qvar 11 ;;:print-form 12 ;;:pure-form-to-string 13 ;;:to-string 14 ;; run-time 15 :with-server 16 ;; compiler 17 ;;:*compiled-query-lambda-cache* 18 :with-backend 19 ;;:execute 20 :query 21 :qlambda 22 :qdefun 23 :apply-query 24 :qlet 25 ;;:qmacroexpand 26 ;;:qmap 27 ;;:quoted-query 28 )) 29 30 (in-package :2sql) 31 32 (defparameter *backend* nil) 33 (defparameter *server* nil) 34 35 ;;; printer 36 37 ;;; 1) Redefine PRINT-SYMBOL, PRINT-QVAR and PRINT-STRING if needed. 38 ;;; 39 ;;; 2) SETQ *backend* before using the compiler or LET it before 40 ;;; executing queries (e.g. inside your WITH-DATABASE macro). 41 42 (defun print-string (string stream) 43 (write-char #\' stream) 44 (princ string stream) ;; TODO escape 45 (write-char #\' stream)) 46 47 (defun split (char string) 48 (split-sequence:split-sequence char string)) 49 50 (defun print-symbol (symbol &optional stream) 51 (flet ((out (s) 52 (when symbol 53 (format s "~(~{~a_~^.~}~)" 54 (split #\. (substitute #\_ #\- (symbol-name symbol))))))) 55 (if stream 56 (out stream) 57 (with-output-to-string (s) 58 (out s))))) 59 60 (defun pure-form-to-string (form) 61 (let ((x (macroexpand form))) 62 (when x 63 (with-output-to-string (s) 64 (multiple-value-bind (qvars qchunks) (print-form x s) 65 (assert (not qvars)) 66 (assert (not qchunks))))))) 67 68 (defun print-qvar (n type stream) 69 (ecase *backend* 70 (:postgresql 71 (let ((x (pure-form-to-string (car type)))) 72 (if x 73 (format stream "$~d::~a" n x) 74 (format stream "$~d" n)))) 75 ((:sqlite :mysql) (write-char #\? stream)) 76 (:oracle (format stream ":~d" n)))) 77 78 ;;(defparameter *suppress-qvar* nil) 79 80 (defun print-form (form stream) 81 (let (qvars qchunks *suppress-qvar*) 82 (declare (special *suppress-qvar*)) 83 (labels ((rec (x) 84 (declare (special *suppress-qvar*)) 85 (if (atom x) 86 (etypecase x 87 (string (print-string x stream)) 88 (keyword (princ x stream)) 89 (symbol (print-symbol x stream)) 90 (integer (princ x stream))) 91 (ecase (car x) 92 (:suppress-qvar 93 (let ((*suppress-qvar* t)) 94 (declare (special *suppress-qvar*)) 95 (rec (cadr x)))) 96 (:qvar 97 (cond 98 (*suppress-qvar* 99 (push (list (cadr x)) qchunks) ;; TODO pass type too? 100 (princ "~a" stream)) 101 (t 102 (push (cdr x) qvars) 103 (print-qvar (length qvars) (cddr x) stream)))) 104 (:qchunk 105 (push (cdr x) qchunks) 106 (princ "~a" stream)) 107 (:lst 108 (let ((sep (cadr x)) 109 (i 0)) 110 (dolist (x (cddr x)) 111 (when (plusp i) 112 (princ (or sep " ") stream)) 113 (rec x) 114 (incf i)))))))) 115 (rec form)) 116 (values (nreverse qvars) (nreverse qchunks)))) 117 118 (defun to-string (form) 119 (let (qvars qchunks) 120 (values 121 (with-output-to-string (s) 122 (multiple-value-setq (qvars qchunks) 123 (print-form form #+nil(macroexpand form) s))) 124 qvars 125 qchunks))) 126 127 ;;; run-time 128 129 (defun make-server (backend) ;; TODO thread safety 130 (let ((cache (make-hash-table :test #'equal)) ;; q->stm 131 (n 0)) 132 (lambda (msg &rest args) 133 (ecase msg 134 ;;(:clear-cache (clrhash cache)) 135 ((:finish :query) (apply backend msg args)) 136 (:execute 137 (destructuring-bind (q &rest args2) args 138 (apply backend msg 139 (princ-to-string 140 (or (gethash q cache) 141 (let ((x (setf (gethash q cache) (incf n)))) 142 (apply backend :prepare (princ-to-string x) q args2) 143 x))) 144 args2))))))) 145 146 (defun call-with-server (server finish fn) 147 (let ((*server* server)) 148 (unwind-protect (funcall fn) 149 (when finish 150 (funcall server :finish))))) 151 152 (defmacro with-server ((server &optional (finish t)) &body body) 153 `(call-with-server ,server ,finish (lambda () ,@body))) 154 155 ;;; compiler 156 157 (defparameter *compiled-query-lambda-cache* nil) ;; equal form->fn 158 159 (defun call-with-backend (backend compiled-query-lambda-cache fn) 160 (let ((*backend* backend) 161 (*compiled-query-lambda-cache* (or compiled-query-lambda-cache 162 (make-hash-table :test #'equal)))) 163 (funcall fn))) 164 165 (defmacro with-backend ((backend &optional compiled-query-lambda-cache) &body body) 166 `(call-with-backend ,backend ,compiled-query-lambda-cache (lambda () ,@body))) 167 168 ;; good for development, let *backend* in with-database, leave 169 ;; *compiled-query-lambda-cache* nil, then queries dont get cached; 170 ;; then you can recompile queries inside with-database, e.g. during an 171 ;; error without closing a transaction for example 172 173 ;; (setq 2sql:*backend* :postgresql) 174 ;; (setq 2sql:*backend* :sqlite) 175 ;; (setq 2sql:*backend* :oracle) 176 ;; (setq 2sql:*backend* nil) 177 178 (defun execute (q &rest qvars) 179 (apply *server* :execute q qvars)) 180 181 (defmacro qmacroexpand (form) 182 `(funcall (lambda () (macroexpand ',form)))) 183 184 (defun process-qchunk (x) 185 `(pure-form-to-string (macroexpand (funcall (lambda () ,@x))))) 186 187 (defun make-query-lambda (args form) 188 `(lambda ,args 189 , (multiple-value-bind (str qvars qchunks) (to-string (macroexpand form)) 190 `(execute 191 ,(if qchunks 192 `(format nil ,str ,@(mapcar 'process-qchunk qchunks)) 193 str) 194 ,@(mapcar #'car qvars) 195 #+nil(list ,@(mapcar #'car qvars)))))) 196 197 ;;(make-query-lambda '(a b) '(q:+ (q:qvar a) (q:qvar b))) 198 199 (defun compiled-query-lambda (args form) 200 (or (when *compiled-query-lambda-cache* 201 (or (gethash form *compiled-query-lambda-cache*) 202 (setf (gethash form *compiled-query-lambda-cache*) 203 (compile nil (make-query-lambda args form))))) 204 (compile nil (make-query-lambda args form)))) 205 206 ;;(compiled-query-lambda '(a b) '(q:+ (q:qvar a) (q:qvar b))) 207 208 (defmacro query (args &body form) 209 (assert (not (cdr form))) 210 `(funcall (compiled-query-lambda ',args ,(car form)) ,@args)) 211 212 ;;(let ((a 1) (b 2)) (query (a b) '(q:+ (q:qvar a) (q:qvar b)))) 213 214 (defun queries (args forms) 215 (mapcar (lambda (form) `(query ,args ',form)) forms)) 216 217 (defmacro qlambda (args &body body) 218 `(lambda ,args ,@(queries args body))) 219 220 (defmacro qdefun (name args &body body) 221 `(defun ,name ,args ,@(queries args body))) 222 223 (defun apply-query (args vals form) 224 (apply (compiled-query-lambda args form) vals)) 225 226 #+nil 227 (defmacro qlet (bindings &body body) 228 `(flet ,(mapcar (lambda (x) 229 (print `(,(car x) ,(cadr x) ,@(queries (cadr x) (cddr x)))) 230 `(,(car x) ,(cadr x) ,@(queries (cadr x) (cddr x)))) 231 bindings) 232 ,@body)) 233 234 #+nil 235 (defun qmap (fn q) ;; TODO optimize properly using cl-postgres, move to backend? 236 (mapcar (lambda (x) (apply fn x)) q))