commit aa3ade3e5295a4464e080d5fcfaaad5a8be824b2
parent 9e15c9aa894103468b616d573394a5a2042f9142
Author: Tomas Hlavaty <tom@logand.com>
Date: Sun, 7 Aug 2011 20:49:14 +0200
2sql-backend and 2sql-orm added
Diffstat:
| M | README | | | 21 | ++++++++++++++++++++- |
| A | backend.lisp | | | 73 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| M | cl-2sql.asd | | | 16 | +++++++++++++--- |
| A | compiler.lisp | | | 136 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| D | core.lisp | | | 86 | ------------------------------------------------------------------------------- |
| M | macros.lisp | | | 722 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++-------------- |
| A | orm.lisp | | | 141 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| M | packages.lisp | | | 38 | +++++++++++++++++++++++++++++--------- |
| A | printer.lisp | | | 85 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| M | test.lisp | | | 215 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
10 files changed, 1309 insertions(+), 224 deletions(-)
diff --git a/README b/README
@@ -11,11 +11,30 @@
- http://marijnhaverbeke.nl/postmodern/s-sql.html
- completion, M-.
- not class based
+ - classes are for state, not syntax
- bloat (rdbms)
+ - sins: oo for syntax, format, custom readers
- the above => arbitrary magic
- we are defining syntax, right?
- make use of lisp then (macros)
-- join proper prefix
+- join proper prefix (tree of tables/selects)
- minimal core meta-syntax and user macro layer
+
+- write obscure sql rules once in one place (macro)
+- ease sql portability
+
+
+
+
+- qvar: query parameter
+
+- qchunk: code evaluated when the query is executed, pasted into the
+ query string directly
+
+ - to suppress-qvar, e.g. when qvar cant be used as a sql function
+ parameter
+
+ - for "unanticipated" delayed calculations, like portable full text
+ search
diff --git a/backend.lisp b/backend.lisp
@@ -0,0 +1,73 @@
+;;; cl-2sql Copyright (c) 2011 Tomas Hlavaty
+
+(in-package :2sql-backend)
+
+(defparameter *database* nil)
+(defparameter *query-to-name* nil)
+(defparameter *name-seq* nil)
+
+#+postgresql
+(defun call-with-postgresql-connection (database user password host port
+ use-ssl fn)
+ (let ((*database* (cl-postgres:open-database database user password host
+ port use-ssl))
+ (*query-to-name* (make-hash-table :test #'equal))
+ (*name-seq* 0)
+ (2sql:*backend* :postgresql)
+ (2sql:*delayed-query-cache* (make-hash-table :test #'eq)))
+ (unwind-protect (funcall fn)
+ (cl-postgres:close-database *database*))))
+
+#+postgresql
+(defmacro with-postgresql-connection ((database user password host
+ &optional (port 5432)
+ (use-ssl :no))
+ &body body)
+ `(call-with-postgresql-connection
+ ,database ,user ,password ,host ,port ,use-ssl (lambda () ,@body)))
+
+#+sqlite
+(defun call-with-sqlite-connection (database-path busy-timeout fn)
+ (let ((*database* (sqlite:connect database-path :busy-timeout busy-timeout))
+ (*query-to-name* (make-hash-table :test #'equal))
+ (*name-seq* 0)
+ (2sql:*backend* :sqlite)
+ (2sql:*delayed-query-cache* (make-hash-table :test #'eq)))
+ (unwind-protect (funcall fn)
+ (sqlite:disconnect *database*))))
+
+#+sqlite
+(defmacro with-sqlite-connection ((database-path &optional busy-timeout) &body body)
+ `(call-with-sqlite-connection ,database-path ,busy-timeout (lambda () ,@body)))
+
+(defun 2sql:execute (q qvars)
+ (assert *database*)
+ (ecase 2sql:*backend*
+ #+postgresql
+ (:postgresql
+ (let ((row-reader 'cl-postgres:list-row-reader))
+ (if qvars
+ (cl-postgres:exec-prepared
+ *database*
+ (princ-to-string
+ (or (gethash q *query-to-name*)
+ (let ((x (setf (gethash q *query-to-name*) (incf *name-seq*))))
+ (cl-postgres:prepare-query *database* (princ-to-string x) q)
+ x)))
+ qvars row-reader)
+ (cl-postgres:exec-query *database* q row-reader))))
+ #+sqlite
+ (:sqlite
+ (if qvars
+ (apply 'sqlite:execute-to-list *database* q qvars) ;; TODO via prep stm http://common-lisp.net/project/cl-sqlite/
+ (sqlite:execute-to-list *database* q)))))
+
+;; good for development, let *backend* in with-database, leave
+;; *delayed-query-cache* nil, then queries dont get cached; then you
+;; can recompile queries inside with-database, e.g. during an error
+;; without closing a transaction for example
+
+;; (setq 2sql:*backend* :postgresql)
+;; (setq 2sql:*backend* :sqlite)
+;; (setq 2sql:*backend* :oracle)
+;; (setq 2sql:*backend* nil)
diff --git a/cl-2sql.asd b/cl-2sql.asd
@@ -1,4 +1,8 @@
;; -*- lisp; -*-
+;;; cl-2sql Copyright (c) 2011 Tomas Hlavaty
+
+;;(push :postgresql *features*)
+;;(push :sqlite *features*)
(asdf:defsystem :cl-2sql
:description "cl-2sql -- Lisp to SQL compiler for Common Lisp."
@@ -6,8 +10,14 @@
:author "Tomas Hlavaty"
:maintainer "Tomas Hlavaty"
:licence "MIT"
- :depends-on (:split-sequence)
+ :depends-on (:split-sequence
+ :ironclad
+ :babel
+ #+postgresql :cl-postgres
+ #+sqlite :sqlite)
:serial t
:components ((:file "packages")
- (:file "core")
- (:file "macros")))
+ (:file "printer")
+ (:file "compiler")
+ (:file "macros")
+ #+(or postgresql sqlite) (:file "backend")))
diff --git a/compiler.lisp b/compiler.lisp
@@ -0,0 +1,136 @@
+;;; cl-2sql Copyright (c) 2011 Tomas Hlavaty
+
+;;; Redefine EXECUTE.
+
+(in-package :2sql)
+
+(defparameter *delayed-query-cache* nil)
+
+(defun process-qchunk (x)
+ `(pure-form-to-string (macroexpand (funcall (lambda () ,@x)))))
+
+(defun execute (q qvars)
+ (values q qvars))
+
+;; manual or automatic qvars?
+#+nil
+(defmacro query (form &rest qvars &environment env) ;; qvars for delayed compilation
+ (declare (ignorable env))
+ (if *backend*
+ (multiple-value-bind (str qvars qchunks) (to-string (macroexpand form))
+ (flet ((paste (x)
+ (when x
+ `(list ,@x))))
+ `(execute
+ ,(if qchunks
+ `(format nil ,str ,@(mapcar 'process-qchunk qchunks))
+ str)
+ (list ,@(mapcar #'car qvars)))))
+ ;; delay compilation until backend is known
+ (progn
+ #+sbcl ;; TODO conditional
+ (unless qvars
+ (setq qvars (remove-duplicates (lexical-variables env))))
+ `(funcall
+ (lambda ,qvars
+ (assert *backend*)
+ ;; TODO eq cache compiled query?
+ (funcall (let ((fn '(lambda ,qvars (query ,form))))
+ (print (list :@@@ fn))
+ (or (when *delayed-query-cache*
+ (or (when (gethash fn *delayed-query-cache*)
+ (print (list :@@@-reusing (gethash fn *delayed-query-cache*)))
+ (gethash fn *delayed-query-cache*))
+ (setf (gethash fn *delayed-query-cache*)
+ (compile nil fn))))
+ (compile nil fn)))
+ ,@qvars)
+ #+nil(funcall (compile nil `(lambda ,',qvars (query ,',form))) ,@qvars))
+ ,@qvars))))
+
+#+nil
+(defmacro query1 (form &rest qvars)
+ `(caar (query ,form ,@qvars)))
+
+#+nil
+(let ((fn '(lambda ,qvars (query ,form))))
+ (print (list :@@@ fn))
+ (or (when *delayed-query-cache*
+ (or (when (gethash fn *delayed-query-cache*)
+ (print (list :@@@-reusing (gethash fn *delayed-query-cache*)))
+ (gethash fn *delayed-query-cache*))
+ (setf (gethash fn *delayed-query-cache*)
+ (compile nil fn))))
+ (compile nil fn)))
+
+(defun when-backend-known (form qvars action env)
+ (cond
+ (*backend* `(,action ,form))
+ (t ;; delay compilation until backend is known
+ #+sbcl ;; TODO conditional
+ (unless qvars
+ (setq qvars (remove-duplicates (lexical-variables env))))
+ `(funcall
+ (lambda ,qvars
+ (assert *backend*)
+ ;; TODO caching?
+ (funcall (compile nil '(lambda ,qvars
+ (declare (ignorable ,@qvars))
+ (,action ,form)))
+ ,@qvars))
+ ,@qvars))))
+
+(defmacro execute-action (form)
+ (multiple-value-bind (str qvars qchunks) (to-string (macroexpand form))
+ (flet ((paste (x)
+ (when x
+ `(list ,@x))))
+ `(execute
+ ,(if qchunks
+ `(format nil ,str ,@(mapcar 'process-qchunk qchunks))
+ str)
+ (list ,@(mapcar #'car qvars))))))
+
+(defmacro query (form &rest qvars &environment env)
+ (when-backend-known form qvars 'execute-action env))
+
+(defmacro qmacroexpand (form &rest qvars &environment env)
+ (when-backend-known form qvars 'macroexpand env))
+
+;;(qmacroexpand (q:true-value))
+
+(defun quoted-query (q &rest qvars) ;; TODO defmacro?
+ (funcall (compile nil `(lambda () (query ,q ,@qvars))))) ;; TODO cache
+
+(defmacro qlambda (args &body body)
+ `(lambda ,args
+ ,@(mapcar (lambda (q) `(query ,q ,@args)) body)))
+
+(defmacro qdefun (name args &body body) ;; rename to defqfun?
+ `(defun ,name ,args
+ ,@(mapcar (lambda (q) `(query ,q ,@args)) body)))
+
+(defmacro qlet (args &body body) ;; rename to query-let?
+ `(flet ,(mapcar (lambda (x) `(,(car x) ,(cadr x) (query ,@(cddr x)))) args)
+ ,@body))
+
+;;; TODO lexical-variables for many lisps? what symbol-macrolet etc?
+
+#+sbcl ;; http://common-lisp.net/project/bese/repos/arnesi_dev/src/lexenv.lisp
+(defmethod lexical-variables ((environment sb-kernel:lexenv))
+ (loop
+ for var-spec in (sb-c::lexenv-vars environment)
+ when (and (atom (cdr var-spec))
+ (not (and (typep (cdr var-spec) 'sb-c::lambda-var)
+ (sb-c::lambda-var-ignorep (cdr var-spec)))))
+ collect (car var-spec)))
+
+#+nil
+(defmacro xxx (&environment env)
+ `(print ',(lexical-variables env)))
+
+;;(xxx)
+;;(let (a) (let (a b) (xxx)))
+
+(defun qmap (fn q) ;; TODO optimize properly using cl-postgres
+ (mapcar (lambda (x) (apply fn x)) q))
diff --git a/core.lisp b/core.lisp
@@ -1,86 +0,0 @@
-;;; cl-2sql Copyright (c) 2011 Tomas Hlavaty
-
-;;; Redefine EXECUTE, PRINT-SYMBOL and PRINT-STRING if needed.
-
-(in-package :2sql)
-
-(defun print-string (string stream)
- (write-char #\' stream)
- (princ string stream) ;; TODO escape
- (write-char #\' stream))
-
-(defun split (char string)
- (split-sequence:split-sequence char string))
-
-(defun print-symbol (symbol stream)
- (format stream "~(~{~a_~^.~}~)" (split #\. (symbol-name symbol))))
-
-(defun print-form (form stream)
- (let (qvars qchunks)
- (labels ((rec (x)
- (if (atom x)
- (etypecase x
- (string (print-string x stream))
- (keyword (princ x stream))
- (symbol (print-symbol x stream))
- (integer (princ x stream)))
- (ecase (car x)
- (:qvar
- (push (cdr x) qvars)
- (format stream ":~d" (length qvars)))
- (:qchunk
- (push (cdr x) qchunks)
- (princ "~a" stream))
- (:par
- (write-char #\( stream)
- (rec (cons :lst (cons nil (cdr x))))
- (write-char #\) stream))
- (:lst
- (let ((sep (cadr x))
- (i 0))
- (dolist (x (cddr x))
- (when (plusp i)
- (princ (or sep " ") stream))
- (rec x)
- (incf i))))))))
- (rec form))
- (values (nreverse qvars) (nreverse qchunks))))
-
-(defun to-string (form)
- (let (qvars qchunks)
- (values
- (with-output-to-string (s)
- (multiple-value-setq (qvars qchunks)
- (print-form (macroexpand form) s)))
- qvars
- qchunks)))
-
-(defun execute (q qvars)
- (values q qvars))
-
-(defun process-qchunk (x)
- (let ((s (gensym)))
- `(with-output-to-string (,s)
- (multiple-value-bind (qvars qchunks)
- (print-form (macroexpand (funcall (lambda () ,@x))) ,s)
- (assert (not qvars))
- (assert (not qchunks))))))
-
-(defmacro query (form)
- (multiple-value-bind (str qvars qchunks) (to-string form)
- (flet ((paste (x)
- (when x
- `(list ,@x))))
- `(execute
- ,(if qchunks
- `(format nil ,str ,@(mapcar 'process-qchunk qchunks))
- str)
- ',qvars))))
-
-(defmacro qlambda (args &body body)
- `(lambda ,args
- ,@(mapcar (lambda (q) `(query ,q)) body)))
-
-(defmacro define-function (name args &body body)
- `(defun ,name ,args
- ,@(mapcar (lambda (q) `(query ,q)) body)))
diff --git a/macros.lisp b/macros.lisp
@@ -12,104 +12,154 @@
(cl:lambda (x) (cl:if (cl:atom x) x (cl:macroexpand x)))
body)))
+(defsyntax clist (&body body)
+ `(lst ", " ,@body))
+
(defsyntax prefix (name &body args)
`(lst nil ,name ,@args))
(defsyntax infix (name &body args)
`(lst ,name ,@args))
-(defsyntax clause (name &body body)
- `(lst nil ,name ,@body))
-
-(defsyntax not (exp)
- `(prefix :not ,exp))
-
-(defsyntax between (what left right)
- `(lst nil ,what :between ,left :and ,right))
-
-(defsyntax + (&body args)
- `(infix " + " ,@args))
-
-(defsyntax - (&body args)
- `(infix " - " ,@args))
-
-(defsyntax = (lexp rexp)
- `(infix " = " ,lexp ,rexp))
-
-(defsyntax and (&body args)
- `(infix " AND " ,@args))
-
-(defsyntax or (&body args)
- `(infix " OR " ,@args))
-
-(defsyntax like (text pattern)
- `(infix " LIKE " ,text ,pattern))
-
-(defsyntax ilike (text pattern)
- `(infix " ILIKE " ,text ,pattern))
-
-;; (defsyntax relike (text pattern) ;;regexp like
-;; `(infix " ILIKE " ,text ,pattern))
-
-(defsyntax where (exp)
- `(clause :where ,exp))
-
-(defsyntax from (&body exp)
- `(clause :from ,@exp))
-
-(defsyntax cols (cols)
- `(lst ", " ,@cols))
+(defsyntax postfix (name &body args)
+ `(prefix ,@args ,name))
+
+(cl:macrolet
+ ((defop (name ecase)
+ `(defsyntax ,name (&rest form)
+ (cl:block here
+ (cl:dolist (x form)
+ (cl:when (cl:let ((backend (cl:car x)))
+ (cl:or (cl:eq t backend) (cl:eq backend 2sql:*backend*)))
+ (cl:return-from here (cl:cadr x)))) ;; cadr or cdr?
+ (cl:when ,ecase
+ (cl:error "Backend ~s fell through BACKEND-CASE ~s"
+ 2sql:*backend* form))))))
+ (defop backend-case nil)
+ (defop backend-ecase t))
+
+(cl:macrolet ;; prefix unary operators
+ ((defop (name &rest rest)
+ `(defsyntax ,name (exp)
+ `(prefix ,,@rest ,exp))))
+ ;;(defop not :not)
+ (defop @ :@)
+ (defop \|/ :\|/)
+ (defop ~ :~)
+ (defop ~* :~*)
+ (defop exists :exists)
+ (defop distinct :distinct))
+
+(cl:macrolet ;; postfix unary operators
+ ((defop (name &rest rest)
+ `(defsyntax ,name (exp)
+ `(prefix ,exp ,,@rest))))
+ (defop is-null :is :null)
+ (defop is-not-null :is :not :null))
+
+(cl:macrolet ;; binary operators
+ ((defop (name sep)
+ `(defsyntax ,name (lexp rexp)
+ `(infix ,,sep ,lexp ,rexp))))
+ (defop = " = ")
+ (defop < " < ")
+ (defop > " > ")
+ (defop <= " <= ")
+ (defop >= " >= ")
+ (defop <> " <> ")
+ (defop in " IN ")
+ (defop / " / ")
+ (defop % " % ")
+ (defop ^ " ^ ")
+ (defop ** " ** ")
+ (defop & " & ")
+ (defop \| " | ")
+ (defop \# " # ")
+ (defop << " << ")
+ (defop >> " >> ")
+ (defop like " LIKE ")
+ (defop ilike " ILIKE "))
+
+(cl:macrolet ;; polyadic operators
+ ((defop (name sep)
+ `(defsyntax ,name (&body args)
+ `(infix ,,sep ,@args))))
+ (defop + " + ")
+ (defop - " - ")
+ (defop * " * ")
+ (defop and " AND ")
+ (defop or " OR ")
+ (defop \|\| " || "))
+
+(defsyntax like* (lexp rexp)
+ `(like (upper ,lexp) (upper ,rexp)))
+
+(defsyntax between (what lexp rexp)
+ `(prefix ,what :between ,lexp :and ,rexp))
(defsyntax select (cols &body body)
- `(clause :select (cols ,cols) ,@body))
+ `(prefix :select ,(cl:if (cl:atom cols) cols `(clist ,@cols)) ,@body))
+
+(defsyntax from (&body body) `(prefix :from ,@body))
+(defsyntax where (exp) `(prefix :where ,exp))
+(defsyntax order-by (&body clist) `(prefix :order :by (clist ,@clist)))
+(defsyntax group-by (&body clist) `(prefix :group :by (clist ,@clist)))
+(defsyntax having (exp) `(prefix :having ,exp))
+(defsyntax limit (exp) `(prefix :limit ,exp))
+(defsyntax offset (exp) `(prefix :offset ,exp))
+
+(defsyntax for (what &optional wait)
+ `(prefix :for ,@ (cl:ecase what
+ (:update '(:update))
+ (:share '(:share)))
+ ,@(cl:unless wait '(:nowait))))
(defsyntax delete-from (tab &optional where)
- `(clause :delete :from ,tab ,@(cl:when where (cl:list where))))
-
-(defsyntax distinct (col)
- `(lst nil :distinct ,col))
-
-(defsyntax join (kind left right on)
- `(lst nil ,left ,kind :join ,right :on ,on))
-
-(defsyntax inner-join (left right on)
- `(join :inner ,left ,right ,on))
-
-(defsyntax natural-join (left right on)
- `(join :natural ,left ,right ,on))
-
-(defsyntax cross-join (left right on)
- `(join :cross ,left ,right ,on))
-
-(defsyntax left-join (left right on)
- `(join :left ,left ,right ,on))
-
-(defsyntax right-join (left right on)
- `(join :right ,left ,right ,on))
-
-(defsyntax full-join (left right on)
- `(join (lst nil :full :outer) ,left ,right ,on))
-
-(defsyntax union (&body select-forms)
- `(lst " UNION " ,@select-forms))
-
-(defsyntax union-all (&body select-forms)
- `(lst " UNION ALL " ,@select-forms))
-
-(defsyntax intersect (&body select-forms)
- `(lst " INTERSECT " ,@select-forms))
-
-(defsyntax intersect-all (&body select-forms)
- `(lst " INTERSECT ALL " ,@select-forms))
-
-(defsyntax except (&body select-forms)
- `(lst " EXCEPT " ,@select-forms))
-
-(defsyntax except-all (&body select-forms)
- `(lst " EXCEPT " ,@select-forms))
+ `(prefix :delete :from ,tab ,@(cl:when where (cl:list where))))
+
+(cl:macrolet ;; join
+ ((defop (name &rest rest)
+ `(defsyntax ,name (left right on &optional using)
+ `(prefix ,left ,,@rest :join ,right
+ ,@(cl:when on `(:on ,on))
+ ,@(cl:when using `(:using (par ,using)))))))
+ (defop inner-join :inner)
+ (defop natural-join :natural)
+ (defop cross-join :cross)
+ (defop left-join :left)
+ (defop right-join :right)
+ (defop full-join :full :outer))
+
+(cl:macrolet ;; set operations
+ ((defop (name sep)
+ `(defsyntax ,name (order-by limit offset &body subqueries)
+ `(prefix (lst ,,sep ,@subqueries)
+ ,@(cl:when order-by `(,@order-by))
+ ,@(cl:when limit `(,@limit))
+ ,@(cl:when offset `(,@offset))))))
+ (defop union " UNION ")
+ (defop union-all " UNION ALL ")
+ (defop intersect " INTERSECT ")
+ (defop intersect-all " INTERSECT ALL ")
+ (defop except " EXCEPT ")
+ (defop except-all " EXCEPT ALL "))
(defsyntax drop-if-exists (name kind if-exists &body body)
- `(clause :drop ,kind ,@(cl:when if-exists '(:if :exists)) ,name ,@body))
+ `(backend-ecase
+ (:oracle
+ ,(cl:if if-exists
+ `(prefix :declare :begin :execute :immediate
+ (\|\| "DROP "
+ , (cl:ecase kind
+ (:table " TABLE ")
+ (:view " VIEW ")
+ (:index " INDEX ")
+ (:sequence "SEQUENCE "))
+ ,name #+nil(2sql:pure-form-to-string name))
+ :\; :exception :when :others :then :null :\; :end :\;)
+ `(prefix :drop ,kind)))
+ (:postgresql
+ (prefix :drop ,kind ,@(cl:when if-exists '(:if :exists)) ,name ,@body))))
(defsyntax drop-table (name &optional if-exists cascade)
`(drop-if-exists ,name :table ,if-exists ,@(cl:when cascade '(:cascade))))
@@ -121,66 +171,488 @@
`(drop-if-exists ,name :index ,if-exists))
(defsyntax drop-sequence (name &optional if-exists)
- `(drop-if-exists ,name :view ,if-exists))
-
-(defsyntax create-index (name unique tab &body cols)
- `(clause :create ,@(cl:when unique '(:unique)) :index ,name
- :on ,tab (par ,@cols)))
-
-(defsyntax insert-into (tab cols vals)
- `(clause :insert :into ,tab (par ,@cols) :values (par ,@vals)))
+ `(drop-if-exists ,name :sequence ,if-exists))
+
+;;(2sql:query (drop-sequence seq t))
+
+(defsyntax create-index (name unique tab using cols properties triggers &body where)
+ #+nil ;; -> cols
+ (lambda (node db)
+ (typecase node
+ (sql-column (funcall 'format-sql-identifier node db))
+ (t (funcall 'format-sql-syntax-node (%shorten-columns node) db))))
+ ;; Oracle doesn't permit table_name.column_name in index expressions,
+ ;; and the table_name is redundant anyway, so let's strip it
+ ;; unconditionally:
+ #+nil
+ (defun %shorten-columns (node)
+ (etypecase node
+ (sql-literal)
+ (sql-fragment) ;; allow sexp2sql
+ (sql-unary-operator
+ (setf (expression-of node)
+ (%shorten-columns (expression-of node))))
+ (sql-function-call
+ (setf (arguments-of node)
+ (mapcar #'%shorten-columns (arguments-of node))))
+ (sql-index-operation
+ (setf (value-of node) (%shorten-columns (value-of node))))
+ (sql-column-alias
+ (setf (table-of node) nil)))
+ node)
+ ;; where e.g. http://www.postgresql.org/docs/8.4/static/indexes-partial.html
+ ;; e.g. [USING method] for postgresql
+ ;; http://www.postgresql.org/docs/8.2/static/sql-createindex.html
+ ;; index properties for oracle
+ ;; http://download.oracle.com/docs/cd/B13789_01/server.101/b10759/statements_5010.htm#i2138869
+ ;; triggers list of strings
+ `(prefix :create ,@(cl:when unique '(:unique)) :index ,name
+ :on ,tab ,@(cl:when using `(:using ,@using)) (par ,@cols)
+ ,@(cl:when where `(:where ,@where))
+ ,@(cl:when properties properties)))
+
+;; http://developer.postgresql.org/pgdocs/postgres/indexes-opclass.html
+(defsyntax operator-class (value operation)
+ `(prefix ,value ,operation))
+
+(defsyntax values (&body values)
+ `(prefix :values (par (clist ,@values))))
+
+(defsyntax insert-into (tab cols &body body)
+ ;; body (values...) | (select...)
+ `(prefix :insert :into ,tab (par (clist ,@cols)) ,@body))
+
+(defsyntax returning (cols &optional vars) ;; oracle; better (k1 v1) (k2 v2)...
+ `(backend-ecase
+ (:oracle (prefix :returning (clist ,@cols) :into (clist ,@vars)))
+ (:postgresql (prefix :returning (clist ,@cols)))))
(defsyntax create-sequence (name &optional temp)
- `(clause :create ,@(cl:when temp '(:temporary)) :sequence ,name))
+ `(prefix :create ,@(cl:when temp '(:temporary)) :sequence ,name))
(defsyntax curval (seq)
`(function :curval ,seq))
(defsyntax nextval (seq)
- `(function :nextval ,seq))
+ `(backend-case
+ (:oracle ,(cl:intern (cl:format nil "~:@(~a.nextval~)" seq))) ;; TODO dont intern, polutes this package
+ (:postgresql (function :nextval ,seq))))
(defsyntax setval (seq val &optional current)
`(function :curval ,seq ,val ,@(cl:unless current '(:false))))
-(defsyntax cond (&body cases)
- `(lst nil :case
- ,@(cl:loop
- :for (c b) :in cases
- :appending (cl:if (cl:eq cl:t c)
- `(:else ,b)
- `(:when ,c :then ,b)))
- :end))
+;; Need to distinguish between boolean type, value and expression.
+;; Oracle does not have a boolean type and value. Expressions
+;; evaluate to true|false but these are not first class values so
+;; manual conversion to the chosen boolean value of the chosen boolean
+;; type is always necessary.
+
+(defsyntax boolean ()
+ `(backend-ecase
+ (:oracle (function :char 1))
+ (:postgresql :boolean)
+ (:sqlite :boolean)))
+
+(defsyntax true-value ()
+ `(backend-ecase
+ (:oracle "Y")
+ (:postgresql :true)
+ (:sqlite 1)))
+
+(defsyntax false-value ()
+ `(backend-ecase
+ (:oracle "N")
+ (:postgresql :false)
+ (:sqlite 0)))
+
+(defsyntax true-exp ()
+ `(backend-case
+ (:oracle (= 1 1))
+ (t (true-value))))
+
+(defsyntax false-exp ()
+ `(backend-case
+ (:oracle (= 1 2))
+ (t (false-value))))
+
+(defsyntax to-boolean (exp)
+ `(backend-case
+ (:oracle ,(cl:cond
+ ((cl:not exp) `(false-value))
+ ((cl:eq t exp) `(true-value))
+ ((cl:atom exp) (cl:error "not a boolean value ~s" exp))
+ (t `(prefix :case :when ,exp (true-value) :else (false-value)))))
+ (t (= (true-value) ,exp))))
+
+;;(cl:macroexpand '(to-boolean (= 1 2)))
-(defsyntax zerop (number)
- `(= 0 ,number))
+(defsyntax cond (&body cases)
+ `(backend-case
+ (:oracle
+ (= (true-value)
+ (par
+ (prefix :case
+ ,@(cl:loop
+ :for (c b) :in cases
+ :appending (cl:if (cl:eq cl:t c) `(:else ,b) `(:when ,c :then ,b)))
+ :end))))
+ (t (prefix :case
+ ,@(cl:loop
+ :for (c b) :in cases
+ :appending (cl:if (cl:eq cl:t c) `(:else ,b) `(:when ,c :then ,b)))
+ :end))))
+
+(defsyntax if (test then else)
+ `(cond (,test ,then) (t ,else)))
+
+;;(cl:macroexpand '(if 1 (false-value) (true-value))) ;; TODO forbid cl:nil and cl:t?
+;;(cl:macroexpand '(if 1 2 3))
+;;(cl:macroexpand '(cond (1 1) (2 2) (t 3)))
+
+#+nil ;; when and unless dont make sense for sql because of return value type clash
+(defsyntax when (test &body body)
+ `(if ,test ,body (false-value)))
+
+#+nil
+(defsyntax unless (test &body body)
+ `(if ,test (false-value) ,body))
+
+(defsyntax zerop (exp) `(= 0 ,exp))
+(defsyntax plusp (exp) `(< 0 ,exp))
+(defsyntax minusp (exp) `(< ,exp 0))
+
+;;(plusp (+ 1 2 3))
(defsyntax par (&body body)
- `(:par ,@(cl:mapcar
- (cl:lambda (x) (cl:if (cl:atom x) x (cl:macroexpand x))) body)))
-
-(defsyntax function (name &body args)
- `(lst nil ,name (par (lst ", " ,@args))))
+ `(prefix :|(| ,@body :|)|))
-(defsyntax count (x)
- `(function :count ,x))
+(defsyntax function (name &body clist)
+ `(prefix ,name (par (clist ,@clist))))
-(defsyntax asc (exp)
- `(prefix :asc ,exp))
+(defsyntax count (x) `(function :count ,x))
+;;(defsyntax distinct (x) `(function :distinct ,x))
+(defsyntax upper (x) `(function :upper ,x))
-(defsyntax desc (exp)
- `(prefix :desc ,exp))
+(cl:macrolet
+ ((defop (name &rest rest)
+ `(defsyntax ,name (exp)
+ `(function ,,@rest ,exp))))
+ (defop min :min)
+ (defop max :max)
+ (defop avg :avg)
+ (defop sum :sum))
-(defsyntax as (tab alias)
- `(lst nil ,tab ,alias))
+(defsyntax asc (exp) `(prefix :asc ,exp))
+(defsyntax desc (exp) `(prefix :desc ,exp))
-;; order-by group-by having
-;; min max avg sum
+(defsyntax as (tab alias) `(prefix ,tab ,alias))
(defsyntax qvar (name &optional type)
- `(:qvar ,name ,@(cl:when type (cl:list type))))
-
-;; (defsyntax type (&body body)
-;; `(:type ,@body))
+ `(:qvar ,name ,type))
(defsyntax qchunk (qchunk)
`(:qchunk ,qchunk))
+
+(defsyntax alter-table (tab &body clist)
+ `(prefix :alter :table ,tab (clist ,@clist)))
+
+(defsyntax nullable (nullable)
+ (cl:if nullable '(prefix :null) '(prefix :not :null)))
+
+;;; We need to distinguish between constraints which can be set up
+;;; during CREATE TABLE and those which require a second ALTER TABLE
+;;; step:
+;;;
+;;; While foreign key constraints are nominally part of the column
+;;; definition, it is not possible to define both together in the case
+;;; where the target table has not been defined yet, meaning that
+;;; ordering matterns and circular references need to be dealt with.
+;;;
+;;; An similar issue would arise for table contents: We need to be able
+;;; to separate out table and constraint definition for data import files,
+;;; where the order must be:
+;;; 1. create table
+;;; 2. insert into / copy
+;;; 3. alter table add foreign key
+(defsyntax add-column (name type nullable default &body constraints)
+ `(prefix :add ,name ,type
+ (nullable ,nullable)
+ ,@(cl:when default `(:default ,default))
+ #+nil
+ (mapc (lambda (constraint)
+ (unless (delay-constraint-until-alter-table-p constraint)
+ (format-sql-syntax-node constraint)))
+ constraints)))
+
+(defsyntax drop-column (name cascade)
+ `(prefix :drop :column ,name
+ ,@(cl:when cascade `(:cascade
+ ,@(backend-case (:oracle '(:constraints)))))))
+
+(defsyntax alter-column-type (name type nullable) ;; TODO nullable
+ `(backend-ecase
+ (:oracle (prefix :modify ,name ,type))
+ (:postgresql (prefix :alter :column ,name :type ,type))))
+
+(defsyntax add-unique-constraint (name &body columns)
+ `(prefix :add :constraint ,name :unique (par (clist ,@columns))))
+
+(defsyntax add-primary-key-constraint (name &body columns)
+ `(prefix :add :constraint ,name :primary :key (par (clist ,@columns))))
+
+(cl:defmacro foreign-key-action (action)
+ (cl:ecase action
+ (:no-action '(:no :action))
+ (:restrict '(:restrict))
+ (:set-null '(:set :null))
+ (:set-default '(:set :default))
+ (:cascade '(:cascade))))
+
+(defsyntax on-delete (action)
+ `(prefix :on :delete (foreign-key-action ,action)))
+
+(defsyntax on-update (action)
+ `(prefix :on :update (foreign-key-action ,action)))
+
+(defsyntax add-foreign-key-constraint (name source-columns target-columns
+ target-table
+ on-delete on-update)
+ `(prefix :add :constraint ,name
+ :foreign :key (par (clist ,@source-columns))
+ :references ,target-table (par (clist ,@target-columns))
+ ,on-delete ,on-update
+ :deferrable :initially :immediate))
+
+(defsyntax drop-constraint (name tab)
+ `(alter-table ,tab :drop :constraint ,name))
+
+(defsyntax update (tab alist &optional where)
+ `(prefix :update ,tab :set
+ (clist ,@(cl:loop :for (k v) :in alist :collect `(lst " = " ,k ,v)))
+ ,@where))
+
+(defsyntax column (name type &optional nullable default)
+ `(prefix ,name ,type
+ (nullable ,nullable)
+ ,@(cl:when default `(:default ,default))))
+
+(defsyntax columns (&body cols)
+ `(clist ,@cols))
+
+(defsyntax create-table (name cols &optional temp as using)
+ `(prefix :create
+ ,@(cl:when temp '(:global :temporary))
+ ,@(cl:when using '(:virtual))
+ :table ,name
+ ,@(cl:when using `(:using ,using))
+ (par ,cols)
+ ,@ (cl:when (cl:and temp (cl:not (cl:eq t temp)) (cl:not as))
+ `((:on :commit ,@ (cl:ecase temp
+ (:drop '(:drop))
+ (:preserve-rows '(:preserve :rows))
+ (:delete-rows '(:delete-rows))))))
+ ,@(cl:when as `(,@as))))
+
+(defsyntax create-view (replace name temp cols &optional as)
+ `(prefix :create ,@(cl:when replace '(:or :replace))
+ ,@(cl:when temp '(:temporary)) :view ,name
+ (par ,@cols) ,@(cl:when as `(,@as))))
+
+(defsyntax lock-table (tab mode wait)
+ `(prefix :lock :table ,tab
+ :in ,@ (cl:ecase mode
+ (:row-share '(:row :share))
+ (:row-exclusive '(:row :exclusive))
+ (:share-update '(:share :update))
+ (:share '(:share))
+ (:share-row-exclusive '(:share :row :exclusive))
+ (:exclusive '(:exclusive)))
+ :mode
+ ,@(cl:unless wait '(:nowait))))
+
+(defsyntax regexp-like (string pattern case-sensitive)
+ `(backend-ecase
+ (:oracle (function :regexp_like ,string ,pattern ,(cl:if case-sensitive "c" "i")))
+ (:postgresql ??)))
+
+(defsyntax not (exp)
+ `(backend-ecase
+ (:oracle (function :not ,(cl:if (cl:atom exp) `(= (true-value) ,exp) exp)))
+ (:postgresql (prefix :not ,exp))))
+
+(defsyntax abs (exp)
+ `(backend-ecase
+ (:oracle (function :abs ,exp))
+ (:postgresql (@ ,exp))))
+
+(defsyntax sqrt (exp)
+ `(backend-ecase
+ (:oracle (function :sqrt ,exp))
+ (:postgresql (\|/ ,exp))))
+
+(defsyntax bitand(lexp rexp)
+ `(backend-ecase
+ (:oracle (function :bitand ,lexp ,rexp))
+ (:postgresql (& ,lexp ,rexp))))
+
+(defsyntax suppress-qvar (exp) ;; make qchunk from qvar
+ `(:suppress-qvar ,(cl:macroexpand exp)))
+
+(defsyntax postgresql/to-tsvector (what &optional regconfig)
+ `(function :to_tsvector
+ ,@(cl:when regconfig `((suppress-qvar ,regconfig)))
+ ,what))
+
+(defsyntax postgresql/to-tsquery (query &optional regconfig)
+ `(function :to_tsquery
+ ,@(cl:when regconfig `((suppress-qvar ,regconfig)))
+ ,query))
+
+(defsyntax postgresql/@@ (tsvector tsquery)
+ `(infix " @@ " ,tsvector ,tsquery))
+
+(defsyntax oracle/contains (what query &optional number)
+ `(function :contains ,what (suppress-qvar ,query)
+ ,@(cl:when number `((suppress-qvar ,number)))))
+
+#+nil
+(define-query-macro full-text-search (class what query &optional regconfig)
+ `(backend-ecase
+ (:postgresql (full-text-search-query-outer-function
+ (postgresql/@@
+ ,(or (let ((x (related-tsvector-accessor class (car what))))
+ (when x
+ (cons x (cdr what))))
+ `(postgresql/to-tsvector ,what ,regconfig))
+ (postgresql/to-tsquery
+ (full-text-search-query-inner-function ,query)
+ ,regconfig))
+ ,what
+ ,query))
+ (:oracle (plusp (oracle/contains ,what ,query)))))
+
+(defsyntax empty-clob ()
+ `(function :empty_clob))
+
+(defsyntax empty-blob ()
+ `(function :empty_blob))
+
+(defsyntax boolean-type ()
+ `(backend-ecase
+ (:oracle (function :char 1))
+ (:postgresql :bool)
+ (:sqlite :boolean)))
+
+(defsyntax numeric-type ()
+ `(backend-ecase
+ ;; NUMBER => oracle assumes NUMBER(*.0) :-{
+ (:oracle ,(cl:error "use more specific type with oracle backend"))
+ (t (:numeric))))
+
+(defsyntax tsvector-type ()
+ '(:tsvector))
+
+(defsyntax clob-type ()
+ `(backend-ecase
+ (:oracle :clob)
+ (:postgresql (prefix :character :large :object))))
+
+(defsyntax blob-type ()
+ `(backend-ecase
+ (:oracle :blob)
+ (:postgresql (prefix :binary :large :object))))
+
+(defsyntax date-type ()
+ '(:date))
+
+(defsyntax time-type ()
+ '(:time))
+
+(defsyntax timestamp-type ()
+ '(:timestamp))
+
+(defsyntax timestamp-with-timezone-type ()
+ '(:timestamp :with :time :zone))
+
+(defsyntax interval-type ()
+ `(backend-ecase
+ (:oracle ,(cl:error "sql-interval-type not yet supported"))
+ (:postgresql '(:interval))))
+
+(defsyntax char-sized-type (type &optional size)
+ `(backend-ecase
+ (:oracle (prefix ,type ,@(cl:when size `(par (prefix ,size :char)))))
+ (:postgresql (prefix ,type ,@(cl:when size `(#+nil :size (par ,size)))))))
+
+(defsyntax char-type (&optional size)
+ `(backend-ecase
+ (:oracle ,(cl:if (cl:eql 1 size)
+ (cl:error "CHAR(1) is reserved for booleans")
+ `(char-sized-type :char ,size)))
+ (:postgresql (char-sized-type :char ,size))))
+
+(defsyntax varchar-type (&optional size)
+ `(backend-ecase
+ (:oracle (char-sized-type :varchar2 ,size))
+ (t ,(cl:if size `(char-sized-type :varchar ,size) :text))))
+
+(defsyntax varchar-without-size-if-possible ()
+ `(varchar-type (backend-case
+ ;; max 4000 bytes?
+ (:oracle (varchar-type 256)))))
+
+(defsyntax float-type (bit-size)
+ (cl:progn
+ (cl:assert (cl:and bit-size (cl:<= 32 bit-size 64)))
+ (cl:cond
+ ((cl:<= bit-size 32)
+ `(backend-ecase
+ (:oracle :binary_float)
+ (:postgresql :real)))
+ ((cl:<= bit-size 64)
+ `(backend-ecase
+ (:oracle :binary_double)
+ (:postgresql '(prefix :double :precision)))))))
+
+(defsyntax integer-type (&optional bit-size)
+ (cl:cond
+ ((cl:null bit-size)
+ `(backend-ecase
+ (:oracle '(function :number :* 0))
+ (:postgresql :numeric)
+ (:sqlite :numeric)))
+ ((cl:<= bit-size 16)
+ `(backend-ecase
+ (:oracle '(function :number 5 0))
+ (:postgresql :smallint)
+ (:sqlite :numeric)))
+ ((cl:<= bit-size 32)
+ `(backend-ecase
+ (:oracle '(function :number 10 0))
+ (:postgresql :int)
+ (:sqlite :numeric)))
+ ((cl:<= bit-size 64)
+ `(backend-ecase
+ (:oracle '(function :number 19 0))
+ (:postgresql :bigint)
+ (:sqlite :numeric)))
+ (cl:t
+ `(backend-ecase
+ (:oracle '(function :number :* 0))
+ (:postgresql :numeric)
+ (:sqlite :numeric)))))
+
+(defsyntax bit-sized-type (type &optional bit-size)
+ (cl:cond
+ ((cl:null bit-size) type)
+ ;; TODO why not ,bit-size
+ ((cl:<= bit-size 16) `(prefix ,type :bit :bit-size 16))
+ ((cl:<= bit-size 32) `(prefix ,type :bit :bit-size 32))
+ ((cl:<= bit-size 64) `(prefix ,type :bit :bit-size 64))
+ (cl:t type)))
+
+(defsyntax set (&body values)
+ `(par (clist ,@values)))
+
+(defsyntax power (lexp rexp)
+ `(function :power ,lexp ,rexp))
diff --git a/orm.lisp b/orm.lisp
@@ -0,0 +1,141 @@
+;;; cl-2sql Copyright (c) 2011 Tomas Hlavaty
+
+(in-package :2sql-orm)
+
+(defun lisp-type-to-ptype (type) ;; TODO more types
+ (if (atom type)
+ (ecase type
+ (integer '(q:integer-type)))
+ (ecase (car type)
+ (or
+ (assert (eq 'null (cadr type)))
+ (assert (not (cddddr type)))
+ (lisp-type-to-ptype (caddr type))))))
+
+(defgeneric list-pslots (class-name))
+
+(defmacro defpclass (name direct-superclasses direct-slots &rest options)
+ `(progn
+ (defclass ,name ,direct-superclasses
+ ,(cons '(oid :type integer :initarg :oid :accessor oid)
+ direct-slots)
+ ,@options)
+ (defmethod list-pslots ((class-name (eql ',name)))
+ ',(loop
+ for x in direct-slots
+ for type = (cadr (member :type x))
+ collect (list (car x)
+ (lisp-type-to-ptype type)
+ (subtypep (type-of nil) type)
+ (cadr (member :initarg x))
+ (cadr (member :initform x)))))))
+
+(defpclass t1 ()
+ ((c1 :type integer :initarg :c1 :accessor c1)
+ (c2 :type (or null integer) :initarg :c2 :initform nil :accessor c2)
+ (c3 :type integer :initarg :c3 :initform 321 :accessor c3)))
+
+(defconstant +class-id-bit-size+ 16)
+
+(defmacro oid-exp (class-id)
+ (let ((bit-size +class-id-bit-size+))
+ `(q:backend-ecase
+ (:oracle (q:+ (q:* (q:nextval oid-seq) (q:power 2 ,bit-size)) ,class-id))
+ (:postgresql (q:\| (q:<< (q:nextval "oid_seq") ,bit-size) ,class-id)))))
+
+(defun class-name-to-class-id (class-name)
+ (mod (ironclad:octets-to-integer
+ (ironclad:digest-sequence
+ :crc32 (babel:string-to-octets (symbol-name class-name) :encoding :utf-8)))
+ (expt 2 +class-id-bit-size+)))
+
+(defun setup-pclass (class-name)
+ (2sql:quoted-query
+ `(q:create-table t1
+ (q:columns
+ (q:column oid (q:integer-type) nil
+ (oid-exp (q:qchunk (class-name-to-class-id ',class-name))))
+ ,@(loop
+ for (name type nullable initarg default) in (list-pslots class-name)
+ collect `(q:column ,name ,type ,nullable ,default))))))
+
+(defun make-pinstance (class-name &rest args)
+ (multiple-value-bind (known unknown)
+ (loop
+ for (name type nullable initarg default) in (list-pslots class-name)
+ for c = (member initarg args)
+ if c collect (list name initarg (cadr c)) into known
+ else collect (cons name initarg) into unknown
+ finally (return (values known unknown)))
+ (apply #'make-instance class-name
+ (nconc
+ (loop
+ for (name initarg value) in known
+ appending (list initarg value))
+ (loop
+ for (name . initarg) in (cons (cons 'oid :oid) unknown)
+ for value in (car (2sql:quoted-query
+ `(q:insert-into t1 ,(mapcar #'car known)
+ (q:values ,@(mapcar #'caddr known))
+ (q:returning ,(cons 'oid (mapcar #'car unknown))))))
+ appending (list initarg value))))))
+
+(defmacro with-tables (names &body body)
+ `(progn
+ (mapcar 'setup-pclass ',names)
+ (unwind-protect (progn ,@body)
+ ,@(mapcar (lambda (x) `(2sql:query (q:drop-table ,x t t))) names))))
+
+(trace 2sql:execute)
+
+(2sql-backend:with-postgresql-connection ("pokus" "tomas" "test123" "localhost")
+ (2sql:query (q:drop-sequence oid-seq t))
+ (2sql:query (q:create-sequence oid-seq))
+ (with-tables (t1)
+ (make-pinstance 't1 :c1 1 :c2 2 :c3 3)
+ (make-pinstance 't1 :c1 1 :c2 2)
+ #+nil(query (q:select :* (q:from t1)))
+ #+nil(x-query (q:select ((x-instance t1)) (q:from t1)))))
+
+
+
+(defparameter *x-alias-to-table* nil)
+
+(defmacro x-query (form &rest qvars)
+ ;; remember stuff, run instance reconstructor at the end
+ `(funcall (compile nil `(lambda ()
+ (let (((*x-alias-to-table* (make-hash-table))))
+ (query ,,form ,,@qvars)))))
+ #+nil
+ `(let* ((*x-alias-to-table* (make-hash-table))
+ #+nil(x (macroexpand `(query ,,form ,,@qvars))))
+ ;;x
+ ))
+
+#+nil
+(defmacro x-select (cols &body body)
+ ;; slice in x-instance slots
+ `(q:select (clist ,@cols) ,@body))
+
+(defmacro x-instance (x)
+ ;; push slot collector and instance reconstructor
+ `(clist
+ ,@(loop
+ for class-name = (gethash x *x-alias-to-table* x)
+ for (name type nullable initarg default) in (list-pslots class-name)
+ collect name)))
+
+(defmacro x-as (tab alias)
+ ;; remember alias -> tab
+ (assert (not (gethash alias *x-alias-to-table*)))
+ (setf (gethash alias *x-alias-to-table*) tab)
+ (list tab alias))
+
+(x-query
+ (x-select ((x-instance x) (x-instance y) (q:sum y.total))
+ (q:from (x-as t1 x) (x-as t2 y))
+ (q:where 1)))
+
+select => populate instances
+update => clear affected instances from cache
+delete => clear affected instances from cache
diff --git a/packages.lisp b/packages.lisp
@@ -4,19 +4,39 @@
(defpackage 2sql
(:use :cl)
- (:export #:print-string
- #:print-symbol
- #:print-form
- #:to-string
- #:execute
- #:query
- #:qlambda
- #:define-function))
+ (:export
+ ;; printer
+ #:print-string
+ #:print-symbol
+ #:print-qvar
+ #:print-form
+ #:pure-form-to-string
+ #:to-string
+ ;; compiler
+ #:*backend*
+ #:*delayed-query-cache*
+ #:execute
+ #:query
+ #:qlambda
+ #:qdefun
+ #:qlet
+ #:qmacroexpand
+ #:qmap
+ #:quoted-query
+ ))
(defpackage 2sql-macros
(:use)
(:nicknames :q) ;; TODO really?
- (:import-from :cl #:&optional #:&body #:nil))
+ (:import-from :cl #:&optional #:&rest #:&body #:nil #:t))
+
+(defpackage 2sql-backend
+ (:use :cl)
+ (:export #+postgresql #:with-postgresql-connection
+ #+sqlite #:with-sqlite-connection))
+
+(defpackage 2sql-orm
+ (:use :cl))
(defpackage 2sql-tests
(:use :cl :2sql))
diff --git a/printer.lisp b/printer.lisp
@@ -0,0 +1,85 @@
+;;; cl-2sql Copyright (c) 2011 Tomas Hlavaty
+
+;;; 1) Redefine PRINT-SYMBOL, PRINT-QVAR and PRINT-STRING if needed.
+;;;
+;;; 2) SETQ *backend* before using the compiler or LET it before
+;;; executing queries (e.g. inside your WITH-DATABASE macro).
+
+(in-package :2sql)
+
+(defparameter *backend* nil)
+(defparameter *suppress-qvar* nil)
+
+(defun print-string (string stream)
+ (write-char #\' stream)
+ (princ string stream) ;; TODO escape
+ (write-char #\' stream))
+
+(defun split (char string)
+ (split-sequence:split-sequence char string))
+
+(defun print-symbol (symbol stream)
+ (format stream "~(~{~a~^.~}~)"
+ (split #\. (substitute #\_ #\- (symbol-name symbol)))))
+
+(defun pure-form-to-string (form)
+ (let ((x (macroexpand form)))
+ (when x
+ (with-output-to-string (s)
+ (multiple-value-bind (qvars qchunks) (print-form x s)
+ (assert (not qvars))
+ (assert (not qchunks)))))))
+
+(defun print-qvar (n type stream)
+ (ecase *backend*
+ (:postgresql
+ (let ((x (pure-form-to-string (car type))))
+ (if x
+ (format stream "$~d::~a" n x)
+ (format stream "$~d" n))))
+ (:sqlite (write-char #\? stream))
+ (:oracle (format stream ":~d" n))))
+
+(defun print-form (form stream)
+ (let (qvars qchunks)
+ (labels ((rec (x)
+ (if (atom x)
+ (etypecase x
+ (string (print-string x stream))
+ (keyword (princ x stream))
+ (symbol (print-symbol x stream))
+ (integer (princ x stream)))
+ (ecase (car x)
+ (:suppress-qvar
+ (let ((*suppress-qvar* t))
+ (rec (cadr x))))
+ (:qvar
+ (cond
+ (*suppress-qvar*
+ (push (list (cadr x)) qchunks) ;; TODO pass type too?
+ (princ "~a" stream))
+ (t
+ (push (cdr x) qvars)
+ (print-qvar (length qvars) (cddr x) stream))))
+ (:qchunk
+ (push (cdr x) qchunks)
+ (princ "~a" stream))
+ (:lst
+ (let ((sep (cadr x))
+ (i 0))
+ (dolist (x (cddr x))
+ (when (plusp i)
+ (princ (or sep " ") stream))
+ (rec x)
+ (incf i))))))))
+ (rec form))
+ (values (nreverse qvars) (nreverse qchunks))))
+
+(defun to-string (form)
+ (let (qvars qchunks)
+ (values
+ (with-output-to-string (s)
+ (multiple-value-setq (qvars qchunks)
+ (print-form form #+nil(macroexpand form) s)))
+ qvars
+ qchunks)))
diff --git a/test.lisp b/test.lisp
@@ -2,6 +2,10 @@
(in-package :2sql-tests)
+
+
+
+
;; s-sql
(to-string
'(q:select ((q:+ field-1 100 @var) field-5)
@@ -170,3 +174,214 @@
(q:= (q:qvar v2) (q:qchunk (+ 1 2)))
(q:= (q:qvar v3) (q:qchunk "one"))
(q:= (q:qvar v4) (q:qchunk '(q:desc x)))))))))
+
+
+
+
+
+
+
+;; *delayed-query-cache* test
+(with-postgresql-connection ("pokus" "tomas" "test123" "localhost")
+ (let ((a 2))
+ ;;(EXECUTE "SELECT |/ $1::INTEGER" (LIST A))
+ ;;(funcall (compile nil (lambda (a) (query (q:select ((q:sqrt (q:qvar a :integer))))))) a)
+ ;;(query (q:select ((q:sqrt (q:qvar a :integer)))))
+ (let ((q (qlambda (a)
+ (q:select ((q:sqrt (q:qvar a :integer)))))))
+ (funcall q a)
+ (funcall q a))))
+
+;; automatic lexvars
+(with-postgresql-connection ("pokus" "tomas" "test123" "localhost")
+ (let ((a 2))
+ ;;(EXECUTE "SELECT |/ $1::INTEGER" (LIST A))
+ ;;(funcall (compile nil (lambda (a) (query (q:select ((q:sqrt (q:qvar a :integer))))))) a)
+ (query (q:select ((q:sqrt (q:qvar a :integer)))))))
+
+;; explicit lexvars
+(with-postgresql-connection ("pokus" "tomas" "test123" "localhost")
+ (let ((a 2))
+ ;;(EXECUTE "SELECT |/ $1::INTEGER" (LIST A))
+ ;;(funcall (compile nil (lambda (a) (query (q:select ((q:sqrt (q:qvar a :integer))))))) a)
+ (query (q:select ((q:sqrt (q:qvar a :integer)))) a)))
+
+
+
+
+;; suppress-qvar
+
+(with-postgresql-connection ("pokus" "tomas" "test123" "localhost")
+ (let ((a 1)
+ (b 2))
+ (query (q:select ((q:+ (q:qvar a :integer)
+ (q:suppress-qvar (q:qvar b :integer)))))))
+ #+nil(query (q:select (3)))
+ #+nil(query (q:select (4))))
+
+(with-postgresql-connection ("pokus" "tomas" "test123" "localhost")
+ (let ((q (qlambda (a b)
+ (q:select ((q:+ (q:qvar a :integer)
+ (q:suppress-qvar (q:qvar b :integer))))))))
+ (list :first (funcall q 1 2) :second (funcall q 2 3))))
+
+(with-postgresql-connection ("pokus" "tomas" "test123" "localhost")
+ (qlet ((q (a b) ;; TODO indenting like flet?
+ (q:select ((q:+ (q:qvar a :integer)
+ (q:suppress-qvar (q:qvar b :integer))
+ (q:qchunk (* a b)))))))
+ (list :first (q 1 2) :second (q 2 3))))
+
+
+
+
+(with-postgresql-connection ("pokus" "tomas" "test123" "localhost")
+ (flet ((mul (x y) ;; TODO undefined function! capture flet?
+ (* x y)))
+ (qlet ((q (a b) ;; TODO indenting like flet?
+ (q:select ((q:+ (q:qvar a :integer)
+ (q:suppress-qvar (q:qvar b :integer))
+ (q:qchunk (mul a b)))))))
+ (list :first (q 1 2) :second (q 2 3)))))
+
+cl-postgres:to-sql-string function value->type? would be handy
+
+smallint integer
+integer integer
+bigint integer
+numeric ratio
+real float
+double precision double-float
+boolean boolean
+varchar string
+text string
+bytea (vector (unsigned-byte 8))
+
+
+;; custom query macro example
+
+(defmacro integer-qvar (name)
+ `(q:qvar ,name :integer))
+
+(with-postgresql-connection ("pokus" "tomas" "test123" "localhost")
+ (let ((a 2))
+ (query (q:select ((q:sqrt (integer-qvar a))
+ (q:+ 1 (q:qchunk (+ 2 3))))))))
+
+
+
+
+
+(with-postgresql-connection ("pokus" "tomas" "test123" "localhost")
+ (query (q:select (22 "Folie et déraison" #+nil 4.5))))
+
+(with-postgresql-connection ("pokus" "tomas" "test123" "localhost")
+ (let ((a 1)
+ (b 2)
+ (c "X")
+ (d "hello"))
+ (query (q:select ((q:+ (q:qvar a :numeric)
+ (q:qvar b :integer))
+ (q:\|\| (q:qvar c (q:char-type))
+ (q:qvar d (q:varchar-type 10))))))))
+
+
+
+
+(doquery (:select 'x 'y :from 'some-imaginary-table) (x y)
+ (format t "On this row, x = ~A and y = ~A.~%" x y))
+
+
+
+
+(with-postgresql-connection ("pokus" "tomas" "test123" "localhost")
+ (query (q:create-table t1 (q:columns
+ (q:column c1 (q:integer-type))
+ (q:column c2 (q:integer-type) 314))
+ t))
+ (qlet ((insert (a b) (q:insert-into t1 (c1 c2)
+ (q:values (q:qvar a) (q:qvar b)))))
+ (insert 1 2)
+ (insert 3 4))
+ (qmap (lambda (a b) (print (list :@@@ a b)))
+ (query (q:select (c1 c2) (q:from t1))))
+ (multiple-value-prog1 (query (q:select (c1 c2) (q:from t1)))
+ (query (q:drop-table t1))))
+
+
+
+
+
+
+(with-postgresql-connection ("pokus" "tomas" "test123" "localhost")
+ (query (q:create-table t1 nil ((q:column c1 (q:integer-type))
+ (q:column c2 (q:integer-type) 314)))))
+
+(with-postgresql-connection ("pokus" "tomas" "test123" "localhost")
+ (query (q:drop-table t1)))
+
+
+
+
+
+
+
+
+
+
+(with-postgresql-connection ("pokus" "tomas" "test123" "localhost")
+ (query
+ (q:select (relname)
+ (q:from (q:inner-join pg_catalog.pg_class
+ pg_catalog.pg_namespace
+ (q:= relnamespace pg_namespace.oid)))
+ (q:where (q:and (q:= relkind "r")
+ (q:not (q:in nspname (q:set "pg_catalog" "pg_toast")))
+ (q:function :pg_catalog.pg_table_is_visible pg_class.oid))))))
+
+(with-postgresql-connection ("pokus" "tomas" "test123" "localhost")
+ (query
+ (q:select (relname)
+ (q:from (q:inner-join (q:as pg_catalog.pg_class c)
+ (q:as pg_catalog.pg_namespace n)
+ (q:= relnamespace n.oid)))
+ (q:where (q:and (q:= relkind "r")
+ (q:not (q:in nspname (q:set "pg_catalog" "pg_toast")))
+ (q:function :pg_catalog.pg_table_is_visible c.oid))))))
+
+#+nil
+(sql
+ (:select 'relname
+ :from 'pg-catalog.pg-class
+ :inner-join 'pg-catalog.pg-namespace
+ :on (:= 'relnamespace 'pg-namespace.oid)
+ :where (:and (:= 'relkind "r")
+ (:not-in 'nspname (:set "pg_catalog" "pg_toast"))
+ (:pg-catalog.pg-table-is-visible 'pg-class.oid))))
+;; => "(SELECT relname FROM pg_catalog.pg_class
+;; INNER JOIN pg_catalog.pg_namespace ON (relnamespace = pg_namespace.oid)
+;; WHERE ((relkind = 'r') and (nspname NOT IN ('pg_catalog', 'pg_toast'))
+;; and pg_catalog.pg_table_is_visible(pg_class.oid)))"
+
+(with-sqlite-connection (":memory:")
+ (query (q:create-table t1 (q:columns
+ (q:column c1 (q:integer-type))
+ (q:column c2 (q:integer-type) 314)
+ (q:column c3 (q:boolean-type))
+ (q:column c4 (q:varchar-type)))
+ nil nil :fts3))
+ (let ((tt (2sql:qmacroexpand (q:true-value)))
+ (ff (2sql:qmacroexpand (q:false-value))))
+ (loop
+ for (a b c d) in `((11 12 ,tt "Ivan Ivanovic Ivanov")
+ (21 22 ,ff "Ivan Ovic"))
+ do (query (q:insert-into t1 (c1 c2 c3 c4)
+ (q:values (q:qvar a) (q:qvar b) (q:qvar c) (q:qvar d))))))
+ ;; my sqlite version supports word and prefix search only
+ (query (q:select :*
+ (q:from t1)
+ ;;(q:where (q:infix " MATCH " c4 "ivan"))
+ (q:where (q:infix " MATCH " c4 "ov*"))
+ ;;(q:where (q:infix " MATCH " c4 "*ov")) ;; doesnt work
+ ;;(q:where (q:infix " MATCH " c4 "ivan AND ivanov"))
+ )))
