commit e43721e0b368ad17191e2372f04dabd770cf7cc8
parent 713e9113770f7c35304e030c1111b93d3e4c8cb2
Author: Tomas Hlavaty <tom@logand.com>
Date: Sun, 16 Feb 2014 21:54:32 +0100
reorganize, obsolete clos, change backend stuff
Diffstat:
17 files changed, 1452 insertions(+), 435 deletions(-)
diff --git a/2sql-cl-postgres.lisp b/2sql-cl-postgres.lisp
@@ -0,0 +1,28 @@
+;;; cl-2sql Copyright (c) 2011 Tomas Hlavaty
+
+(defpackage :2sql-cl-postgres
+ (:use :cl)
+ (:export :make-backend))
+
+(in-package :2sql-cl-postgres)
+
+(defun make-backend (db user password host port use-ssl)
+ (let ((x (cl-postgres:open-database db user password host port use-ssl)))
+ (lambda (msg &rest args)
+ (assert x)
+ (ecase msg
+ (:finish
+ (destructuring-bind () args
+ (cl-postgres:close-database x)
+ (setq x nil)))
+ (:query
+ (destructuring-bind (q) args ;; TODO query args
+ (cl-postgres:exec-query x q 'cl-postgres:list-row-reader)))
+ (:prepare
+ (destructuring-bind (stm q &rest args2) args
+ (declare (ignore args2)) ;; TODO args2
+ (cl-postgres:prepare-query x stm q)))
+ (:execute
+ (destructuring-bind (stm &rest args2) args
+ ;; TODO return ctype . cname too
+ (cl-postgres:exec-prepared x stm args2 'cl-postgres:list-row-reader)))))))
diff --git a/2sql-cl-sqlite.lisp b/2sql-cl-sqlite.lisp
@@ -0,0 +1,21 @@
+;;; cl-2sql Copyright (c) 2011 Tomas Hlavaty
+
+(defpackage :2sql-cl-sqlite
+ (:use :cl)
+ (:export :make-backend))
+
+(in-package :2sql-cl-sqlite)
+
+(defun make-backend (database-path busy-timeout)
+ (let ((x (sqlite:connect database-path :busy-timeout busy-timeout)))
+ (lambda (msg &rest args)
+ (assert x)
+ (ecase msg
+ (:finish
+ (destructuring-bind () args
+ (sqlite:disconnect x)
+ (setq x nil)))
+ (:query (apply 'sqlite:execute-to-list x args))
+ ;; TODO via prep stm http://common-lisp.net/project/cl-sqlite/
+ #+nil(:prepare)
+ #+nil(:execute)))))
diff --git a/2sql-dbquery.lisp b/2sql-dbquery.lisp
@@ -0,0 +1,18 @@
+;;; cl-2sql Copyright (c) 2011 Tomas Hlavaty
+
+(defpackage :2sql-dbquery
+ (:use :cl)
+ (:export :make-backend))
+
+(in-package :2sql-dbquery)
+
+(defun make-backend (dbquery-server)
+ (lambda (msg &rest args)
+ (assert dbquery-server)
+ (ecase msg
+ (:finish
+ (apply 'dbquery:finish dbquery-server args)
+ (setq dbquery-server nil))
+ (:query (apply 'dbquery:query dbquery-server args))
+ (:prepare (apply 'dbquery:prepare dbquery-server args))
+ (:execute (apply 'dbquery:execute dbquery-server args)))))
diff --git a/2sql.lisp b/2sql.lisp
@@ -0,0 +1,236 @@
+;;; cl-2sql Copyright (c) 2011 Tomas Hlavaty
+
+(defpackage 2sql
+ (:use :cl)
+ (:export :*backend*
+ :*server*
+ ;; printer
+ ;;:print-string
+ :print-symbol
+ ;;:print-qvar
+ ;;:print-form
+ ;;:pure-form-to-string
+ ;;:to-string
+ ;; run-time
+ :with-server
+ ;; compiler
+ ;;:*compiled-query-lambda-cache*
+ :with-backend
+ ;;:execute
+ :query
+ :qlambda
+ :qdefun
+ :apply-query
+ :qlet
+ ;;:qmacroexpand
+ ;;:qmap
+ ;;:quoted-query
+ ))
+
+(in-package :2sql)
+
+(defparameter *backend* nil)
+(defparameter *server* nil)
+
+;;; printer
+
+;;; 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).
+
+(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 &optional stream)
+ (flet ((out (s)
+ (when symbol
+ (format s "~(~{~a_~^.~}~)"
+ (split #\. (substitute #\_ #\- (symbol-name symbol)))))))
+ (if stream
+ (out stream)
+ (with-output-to-string (s)
+ (out s)))))
+
+(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 :mysql) (write-char #\? stream))
+ (:oracle (format stream ":~d" n))))
+
+;;(defparameter *suppress-qvar* nil)
+
+(defun print-form (form stream)
+ (let (qvars qchunks *suppress-qvar*)
+ (declare (special *suppress-qvar*))
+ (labels ((rec (x)
+ (declare (special *suppress-qvar*))
+ (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))
+ (declare (special *suppress-qvar*))
+ (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)))
+
+;;; run-time
+
+(defun make-server (backend) ;; TODO thread safety
+ (let ((cache (make-hash-table :test #'equal)) ;; q->stm
+ (n 0))
+ (lambda (msg &rest args)
+ (ecase msg
+ ;;(:clear-cache (clrhash cache))
+ ((:finish :query) (apply backend msg args))
+ (:execute
+ (destructuring-bind (q &rest args2) args
+ (apply backend msg
+ (princ-to-string
+ (or (gethash q cache)
+ (let ((x (setf (gethash q cache) (incf n))))
+ (apply backend :prepare (princ-to-string x) q args2)
+ x)))
+ args2)))))))
+
+(defun call-with-server (server finish fn)
+ (let ((*server* server))
+ (unwind-protect (funcall fn)
+ (when finish
+ (funcall server :finish)))))
+
+(defmacro with-server ((server &optional (finish t)) &body body)
+ `(call-with-server ,server ,finish (lambda () ,@body)))
+
+;;; compiler
+
+(defparameter *compiled-query-lambda-cache* nil) ;; equal form->fn
+
+(defun call-with-backend (backend compiled-query-lambda-cache fn)
+ (let ((*backend* backend)
+ (*compiled-query-lambda-cache* (or compiled-query-lambda-cache
+ (make-hash-table :test #'equal))))
+ (funcall fn)))
+
+(defmacro with-backend ((backend &optional compiled-query-lambda-cache) &body body)
+ `(call-with-backend ,backend ,compiled-query-lambda-cache (lambda () ,@body)))
+
+;; good for development, let *backend* in with-database, leave
+;; *compiled-query-lambda-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)
+
+(defun execute (q &rest qvars)
+ (apply *server* :execute q qvars))
+
+(defmacro qmacroexpand (form)
+ `(funcall (lambda () (macroexpand ',form))))
+
+(defun process-qchunk (x)
+ `(pure-form-to-string (macroexpand (funcall (lambda () ,@x)))))
+
+(defun make-query-lambda (args form)
+ `(lambda ,args
+ , (multiple-value-bind (str qvars qchunks) (to-string (macroexpand form))
+ `(execute
+ ,(if qchunks
+ `(format nil ,str ,@(mapcar 'process-qchunk qchunks))
+ str)
+ ,@(mapcar #'car qvars)
+ #+nil(list ,@(mapcar #'car qvars))))))
+
+;;(make-query-lambda '(a b) '(q:+ (q:qvar a) (q:qvar b)))
+
+(defun compiled-query-lambda (args form)
+ (or (when *compiled-query-lambda-cache*
+ (or (gethash form *compiled-query-lambda-cache*)
+ (setf (gethash form *compiled-query-lambda-cache*)
+ (compile nil (make-query-lambda args form)))))
+ (compile nil (make-query-lambda args form))))
+
+;;(compiled-query-lambda '(a b) '(q:+ (q:qvar a) (q:qvar b)))
+
+(defmacro query (args &body form)
+ (assert (not (cdr form)))
+ `(funcall (compiled-query-lambda ',args ,(car form)) ,@args))
+
+;;(let ((a 1) (b 2)) (query (a b) '(q:+ (q:qvar a) (q:qvar b))))
+
+(defun queries (args forms)
+ (mapcar (lambda (form) `(query ,args ',form)) forms))
+
+(defmacro qlambda (args &body body)
+ `(lambda ,args ,@(queries args body)))
+
+(defmacro qdefun (name args &body body)
+ `(defun ,name ,args ,@(queries args body)))
+
+(defun apply-query (args vals form)
+ (apply (compiled-query-lambda args form) vals))
+
+#+nil
+(defmacro qlet (bindings &body body)
+ `(flet ,(mapcar (lambda (x)
+ (print `(,(car x) ,(cadr x) ,@(queries (cadr x) (cddr x))))
+ `(,(car x) ,(cadr x) ,@(queries (cadr x) (cddr x))))
+ bindings)
+ ,@body))
+
+#+nil
+(defun qmap (fn q) ;; TODO optimize properly using cl-postgres, move to backend?
+ (mapcar (lambda (x) (apply fn x)) q))
diff --git a/README b/README
@@ -1,3 +1,5 @@
+-*- org -*-
+
http://ondoc.logand.com/d/900/5/
http://users.encs.concordia.ca/~haarslev/publications/jvlc92/node6.html
http://www.cliki.net/MOP%20design%20patterns
@@ -87,6 +89,7 @@ built on top of it.
- Compiler
- Macros
- Backends
+ - Full text search
- Portability
- Object Relational Mapping
- Custom persistent slot types
@@ -122,6 +125,9 @@ built on top of it.
Backends
--------
+ Full text search
+ ----------------
+
Portability
-----------
diff --git a/backend.lisp b/backend.lisp
@@ -1,67 +0,0 @@
-;;; cl-2sql Copyright (c) 2011 Tomas Hlavaty
-
-(in-package :2sql-backend)
-
-(defparameter *database* nil)
-(defparameter *query-to-name* nil)
-(defparameter *name-seq* nil)
-
-(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:*compiled-query-lambda-cache* (make-hash-table :test #'equal)))
- (unwind-protect (funcall fn)
- (cl-postgres:close-database *database*))))
-
-(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)))
-
-(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:*compiled-query-lambda-cache* (make-hash-table :test #'equal)))
- (unwind-protect (funcall fn)
- (sqlite:disconnect *database*))))
-
-(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
- (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
- (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
-;; *compiled-query-lambda-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-cl-postgres.asd b/cl-2sql-cl-postgres.asd
@@ -0,0 +1,12 @@
+;; -*- lisp; -*-
+;;; cl-2sql Copyright (c) 2011 Tomas Hlavaty
+
+(asdf:defsystem :cl-2sql-cl-postgres
+ :description "cl-2sql -- Lisp to SQL compiler for Common Lisp."
+ :version ""
+ :author "Tomas Hlavaty"
+ :maintainer "Tomas Hlavaty"
+ :licence "MIT"
+ :depends-on (:cl-postgres)
+ :serial t
+ :components ((:file "2sql-cl-postgres")))
diff --git a/cl-2sql-cl-sqlite.asd b/cl-2sql-cl-sqlite.asd
@@ -0,0 +1,12 @@
+;; -*- lisp; -*-
+;;; cl-2sql Copyright (c) 2011 Tomas Hlavaty
+
+(asdf:defsystem :cl-2sql-cl-sqlite
+ :description "cl-2sql -- Lisp to SQL compiler for Common Lisp."
+ :version ""
+ :author "Tomas Hlavaty"
+ :maintainer "Tomas Hlavaty"
+ :licence "MIT"
+ :depends-on (:cl-sqlite)
+ :serial t
+ :components ((:file "2sql-cl-sqlite")))
diff --git a/cl-2sql-dbquery.asd b/cl-2sql-dbquery.asd
@@ -0,0 +1,12 @@
+;; -*- lisp; -*-
+;;; cl-2sql Copyright (c) 2011 Tomas Hlavaty
+
+(asdf:defsystem :cl-2sql-dbquery
+ :description "cl-2sql -- Lisp to SQL compiler for Common Lisp."
+ :version ""
+ :author "Tomas Hlavaty"
+ :maintainer "Tomas Hlavaty"
+ :licence "MIT"
+ :depends-on (:dbquery)
+ :serial t
+ :components ((:file "2sql-dbquery")))
diff --git a/cl-2sql.asd b/cl-2sql.asd
@@ -1,29 +1,14 @@
;; -*- 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."
:version ""
:author "Tomas Hlavaty"
:maintainer "Tomas Hlavaty"
:licence "MIT"
- :depends-on (:split-sequence
- :ironclad
- :babel
- ;;#+postgresql :cl-postgres
- ;;#+sqlite :sqlite
- :cl-postgres
- :sqlite
- :closer-mop
- )
+ :depends-on (:split-sequence) ;; TODO remove
:serial t
- :components ((:file "packages")
- (:file "printer")
- (:file "compiler")
+ :components ((:file "2sql")
(:file "macros")
- ;;#+(or postgresql sqlite) (:file "backend")
- (:file "backend")
- (:file "orm")))
+ (:file "ormc")))
diff --git a/compiler.lisp b/compiler.lisp
@@ -1,66 +0,0 @@
-;;; cl-2sql Copyright (c) 2011 Tomas Hlavaty
-
-;;; Redefine EXECUTE.
-
-(in-package :2sql)
-
-(defparameter *compiled-query-lambda-cache* nil) ;; equal form->fn
-
-(defun execute (q qvars) ;; to be redefined in user code
- (values q qvars))
-
-(defmacro qmacroexpand (form)
- `(funcall (lambda () (macroexpand ',form))))
-
-(defun process-qchunk (x)
- `(pure-form-to-string (macroexpand (funcall (lambda () ,@x)))))
-
-(defun make-query-lambda (args form)
- `(lambda ,args
- , (multiple-value-bind (str qvars qchunks) (to-string (macroexpand form))
- `(execute
- ,(if qchunks
- `(format nil ,str ,@(mapcar 'process-qchunk qchunks))
- str)
- (list ,@(mapcar #'car qvars))))))
-
-;;(make-query-lambda '(a b) '(q:+ (q:qvar a) (q:qvar b)))
-
-(defun compiled-query-lambda (args form)
- (or (when *compiled-query-lambda-cache*
- (or (gethash form *compiled-query-lambda-cache*)
- (setf (gethash form *compiled-query-lambda-cache*)
- (compile nil (make-query-lambda args form)))))
- (compile nil (make-query-lambda args form))))
-
-;;(compiled-query-lambda '(a b) '(q:+ (q:qvar a) (q:qvar b)))
-
-(defmacro query (args &body form)
- (assert (not (cdr form)))
- `(funcall (compiled-query-lambda ',args ,(car form)) ,@args))
-
-;;(let ((a 1) (b 2)) (query (a b) '(q:+ (q:qvar a) (q:qvar b))))
-
-(defun queries (args forms)
- (mapcar (lambda (form) `(query ,args ',form)) forms))
-
-(defmacro qlambda (args &body body)
- `(lambda ,args ,@(queries args body)))
-
-(defmacro qdefun (name args &body body)
- `(defun ,name ,args ,@(queries args body)))
-
-(defun apply-query (args vals form)
- (apply (compiled-query-lambda args form) vals))
-
-#+nil
-(defmacro qlet (bindings &body body)
- `(flet ,(mapcar (lambda (x)
- (print `(,(car x) ,(cadr x) ,@(queries (cadr x) (cddr x))))
- `(,(car x) ,(cadr x) ,@(queries (cadr x) (cddr x))))
- bindings)
- ,@body))
-
-#+nil
-(defun qmap (fn q) ;; TODO optimize properly using cl-postgres, move to backend?
- (mapcar (lambda (x) (apply fn x)) q))
diff --git a/macros.lisp b/macros.lisp
@@ -1,5 +1,10 @@
;;; cl-2sql Copyright (c) 2011 Tomas Hlavaty
+(defpackage :2sql-macros
+ (:use)
+ (:nicknames :q) ;; TODO really?
+ (:import-from :cl :&optional :&rest :&body :nil :t))
+
(in-package :2sql-macros)
(cl:defmacro defsyntax (name args &body body)
@@ -30,7 +35,10 @@
(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:or (cl:eq t backend)
+ (cl:if (cl:atom backend)
+ (cl:eq backend 2sql:*backend*)
+ (cl:member 2sql:*backend* backend))))
(cl:return-from here (cl:cadr x)))) ;; cadr or cdr?
(cl:when ,ecase
(cl:error "Backend ~s fell through BACKEND-CASE ~s"
@@ -173,9 +181,11 @@
`(drop-if-exists ,name :index ,if-exists))
(defsyntax drop-sequence (name &optional if-exists)
- `(drop-if-exists ,name :sequence ,if-exists))
+ `(backend-ecase
+ (:postgresql (drop-if-exists ,name :sequence ,if-exists))
+ (:sqlite (drop-table ,name ,if-exists))))
-;;(2sql:query (drop-sequence seq t))
+;;(2sql:query () '(drop-sequence seq t))
(defsyntax create-index (name unique tab using cols properties triggers &body where)
#+nil ;; -> cols
@@ -232,10 +242,25 @@
(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)))))
+ (:postgresql ,@(cl:when cols `((prefix :returning (clist ,@cols)))))))
+
+(defsyntax column (name type &optional nullable default other)
+ `(prefix ,name ,type
+ (nullable ,nullable)
+ ,@(cl:when default `(:default ,default))
+ ,@(cl:when other (cl:list (cl:macroexpand other)))))
+
+(defsyntax columns (&body cols)
+ `(clist ,@cols))
(defsyntax create-sequence (name &optional temp)
- `(prefix :create ,@(cl:when temp '(:temporary)) :sequence ,name))
+ `(backend-ecase
+ (:postgresql
+ (prefix :create ,@(cl:when temp '(:temporary)) :sequence ,name))
+ (:sqlite
+ (create-table ,name
+ (columns (column seq (integer-type) nil nil
+ (prefix :primary :key #+nil :autoincrement)))))))
(defsyntax curval (seq)
`(function :curval ,seq))
@@ -243,7 +268,7 @@
(defsyntax nextval (seq)
`(backend-case
(:oracle ,(cl:intern (cl:format nil "~:@(~a.nextval~)" seq))) ;; TODO dont intern, polutes this package
- (:postgresql (function :nextval ,seq))))
+ (:postgresql (function :nextval ,(2sql:print-symbol seq)))))
(defsyntax setval (seq val &optional current)
`(function :curval ,seq ,val ,@(cl:unless current '(:false))))
@@ -263,13 +288,13 @@
(defsyntax true-value ()
`(backend-ecase
(:oracle "Y")
- (:postgresql :true)
+ (:postgresql t #+nil :true)
(:sqlite 1)))
(defsyntax false-value ()
`(backend-ecase
(:oracle "N")
- (:postgresql :false)
+ (:postgresql nil #+nil :false)
(:sqlite 0)))
(defsyntax true-exp ()
@@ -354,8 +379,8 @@
(defop avg :avg)
(defop sum :sum))
-(defsyntax asc (exp) `(prefix :asc ,exp))
-(defsyntax desc (exp) `(prefix :desc ,exp))
+(defsyntax asc (exp) `(prefix ,exp :asc))
+(defsyntax desc (exp) `(prefix ,exp :desc))
(defsyntax as (tab alias) `(prefix ,tab ,alias))
@@ -368,6 +393,9 @@
(defsyntax alter-table (tab &body clist)
`(prefix :alter :table ,tab (clist ,@clist)))
+(defsyntax alter-sequence (seq &body body)
+ `(prefix :alter :sequence ,seq ,@body))
+
(defsyntax nullable (nullable)
(cl:if nullable '(prefix :null) '(prefix :not :null)))
@@ -443,15 +471,6 @@
(clist ,@(cl:loop :for (k v) :in alist :collect `(lst " = " ,k ,v)))
,where))
-(defsyntax column (name type &optional nullable default other)
- `(prefix ,name ,type
- (nullable ,nullable)
- ,@(cl:when default `(:default ,default))
- ,@(cl:when other (cl:list (cl:macroexpand other)))))
-
-(defsyntax columns (&body cols)
- `(clist ,@cols))
-
(defsyntax create-table (name cols &optional temp as using)
`(prefix :create
,@(cl:when temp '(:global :temporary))
@@ -500,7 +519,7 @@
(defsyntax sqrt (exp)
`(backend-ecase
- (:oracle (function :sqrt ,exp))
+ ((:oracle :mysql) (function :sqrt ,exp))
(:postgresql (\|/ ,exp))))
(defsyntax bitand(lexp rexp)
diff --git a/orm.lisp b/orm.lisp
@@ -1,5 +1,19 @@
;;; cl-2sql Copyright (c) 2011 Tomas Hlavaty
+(defpackage 2sql-orm
+ (:use :cl)
+ (:export :textp
+ :text
+ :defptype
+ :defpclass
+ :setup-pclass
+ :with-instance-cache
+ :make-pinstance
+ :with-pinstance-collector-cache
+ :query
+ :instance
+ ))
+
(in-package :2sql-orm)
;;; orm types
@@ -36,8 +50,8 @@
(defstruct (pdate (:constructor make-pdate (y m d))) y m d)
(defstruct (ptime (:constructor make-ptime (hh mm ss ms))) hh mm ss ms)
-(defstruct (ptimestamp-with-timezone
- (:constructor make-ptimestamp-with-timezone (date time timezone)))
+(defstruct (ptimestamp-tz
+ (:constructor make-ptimestamp-tz (date time timezone)))
date time timezone)
;;(defstruct pinterval y m d hh mm ss ms)
@@ -45,7 +59,7 @@
(with-slots (y m d) a
(values (format nil "~4,'0d-~2,'0d-~2,'0d" y m d) "date")))
-(defmethod cl-postgres:to-sql-string ((a ptimestamp-with-timezone)) ;; TODO timezone
+(defmethod cl-postgres:to-sql-string ((a ptimestamp-tz)) ;; TODO timezone
(with-slots (date time timezone) a
(with-slots (y m d) date
(with-slots (hh mm ss ms) time
@@ -71,6 +85,11 @@
(defgeneric ptype-macroexpand (type))
+(defun persistent-type-p (type)
+ (get type 'persistent-type))
+
+(deftype persistent-type () '(satisfies persistent-type-p))
+
(defun lisp-type-to-ptype (type) ;; TODO more types
(if (atom type)
(case type
@@ -79,11 +98,13 @@
(string '(q:varchar-type))
(pdate '(q:date-type))
(ptime '(q:time-type))
- (ptimestamp-with-timezone '(q:timestamp-with-timezone-type))
+ (ptimestamp-tz '(q:timestamp-with-timezone-type))
(octet-vector '(q:blob-type))
(t
(cond
((subtypep type 'persistent-object) (lisp-type-to-ptype 'oid))
+ ((subtypep type 'persistent-type) (lisp-type-to-ptype 'oid))
+ ;;((persistent-type-p type) (lisp-type-to-ptype 'oid))
(t (let ((x (ptype-macroexpand type)))
(assert (not (eq x type)))
(lisp-type-to-ptype x))))))
@@ -103,6 +124,10 @@
;; (lisp-type-to-ptype '(text 3))
;; (lisp-type-to-ptype '(text 3 2))
+(defun lisp-type-nullable-p (type)
+ (unless (eql 'boolean type)
+ (typep nil type)))
+
(defmacro defptype (name args specifier &optional db-type db-check)
`(progn
(deftype ,name ,args ,specifier)
@@ -112,10 +137,13 @@
(defun natural0p (a)
(and (integerp a) (<= 0 a)))
-(defptype natural0 () '(and integer (satisfies natural0p)) 'integer 'q:le0)
-(defptype natural1 () '(and integer (satisfies plusp)) 'integer 'q:plusp)
+(defmethod ptype-macroexpand ((type (eql 'list)))
+ 'string)
-(defptype oid () 'natural1)
+(defptype natural0 () '(and integer (satisfies natural0p)) 'integer 'q:le0)
+(defptype natural () '(and integer (satisfies plusp)) 'integer 'q:plusp)
+(defptype universal-time () 'integer 'ptimestamp-tz)
+(defptype oid () 'natural)
;;; persistent-object
@@ -453,12 +481,23 @@
(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))))) ;; TODO oid_seq_ via symbol printing
+ (:postgresql (q:\| (q:<< (q:nextval "oid_seq_") ,bit-size) ,class-id)) ;; TODO oid_seq_ via symbol printing
+ (:sqlite (q:\| (q:<< (q:nextval oid-seq) ,bit-size) ,class-id)))))
+#+nil
+(defun octets-to-integer (octets) ;; TODO
+ (do ()
+ ()
+ ))
+
+#+nil
+(defun string-to-octets () ;; TODO
+ (babel:string-to-octets (symbol-name class-name) :encoding :utf-8))
+
+#+nil
(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)))
+ (ironclad:digest-sequence :crc32 (string-to-octets (symbol-name class-name))))
(expt 2 +class-id-bit-size+)))
(defmacro defpclass (name superclasses slots)
@@ -496,9 +535,9 @@
((typep value 'simple-date:timestamp)
(setq value (multiple-value-bind (y m d hh mm ss ms)
(simple-date:decode-timestamp value)
- (make-ptimestamp-with-timezone (make-pdate y m d)
- (make-ptime hh mm ss ms)
- nil))))
+ (make-ptimestamp-tz (make-pdate y m d)
+ (make-ptime hh mm ss ms)
+ nil))))
((subtypep type 'persistent-object)
(setq value (or (gethash value *instance-cache*)
(make-proxy value))))))
diff --git a/ormc.lisp b/ormc.lisp
@@ -0,0 +1,840 @@
+;;; cl-2sql Copyright (c) 2011 Tomas Hlavaty
+
+(defpackage 2sql-ormc
+ (:use :cl)
+ (:export :textp
+ :text
+ :defptype
+ :defpclass
+ :deftable
+ :setup-pclass
+ :with-instance-cache
+ :make-pinstance
+ :with-pinstance-collector-cache
+ :query
+ :instance
+ ))
+
+(in-package :2sql-ormc)
+
+;;; orm types
+
+;; string => string | clob
+;; string 3 => char 3
+;; text 5 &optional 2 => varchar 5 (no "" allowed, due to oracle)
+;; string-or-text => string | varchar
+;; char 1 => boolean
+
+(deftype universal-time () 'integer)
+
+(defun textp (a max &optional (min 1))
+ (and (stringp a) (<= min (length a) max)))
+
+;; (textp "h" 3)
+;; (textp "h" 3 2)
+;; (textp "hi" 3)
+;; (textp "hi" 3 2)
+;; (textp "hello" 3)
+;; (textp "hello" 3 2)
+
+(deftype text (max &optional (min 1))
+ (assert (plusp min))
+ (assert (< min max))
+ (let ((p (gensym)))
+ (setf (symbol-function p) #'(lambda (a) (textp a max min)))
+ `(and string (satisfies ,p))))
+
+;; (typep "h" '(text 3))
+;; (typep "h" '(text 3 2))
+;; (typep "hi" '(text 3))
+;; (typep "hi" '(text 3 2))
+;; (typep "hello" '(text 3))
+;; (typep "hello" '(text 3 2))
+
+(defstruct (pdate (:constructor make-pdate (y m d))) y m d)
+(defstruct (ptime (:constructor make-ptime (hh mm ss ms))) hh mm ss ms)
+(defstruct (ptimestamp-tz
+ (:constructor make-ptimestamp-tz (date time timezone)))
+ date time timezone)
+;;(defstruct pinterval y m d hh mm ss ms)
+
+(defun persistent-type-p (type)
+ (get type 'persistent-type))
+
+(deftype persistent-type () '(satisfies persistent-type-p))
+
+(defun oid (x) (funcall x 'oid))
+
+;;(defstruct (proxy (:constructor make-proxy (oid object))) oid object)
+
+(defun nullablep (type)
+ (unless (eql 'boolean type)
+ (typep nil type)))
+
+(defun persistent-type-pkey (type1 &optional specs)
+ (unless specs
+ (setq specs (get type1 'deftable-specs)))
+ (when type1
+ (destructuring-bind (a) (cdr (assoc :pkey specs))
+ a)))
+
+(defun persistent-type-pkey-type (type1)
+ (destructuring-bind (&key type &allow-other-keys)
+ (cdr (assoc (persistent-type-pkey type1) (get type1 'deftable-slots)))
+ type))
+
+(defun ptype-specifier (type)
+ (let ((y (get type 'ptype-specifier)))
+ (assert y)
+ (assert (not (eq y type)))
+ (assert (not (get type 'ptype-args)))
+ y))
+
+(defun expand-ptype-to-db (type)
+ (assert type)
+ (if (atom type)
+ (case type
+ (boolean '(q:boolean-type))
+ (integer '(q:integer-type))
+ (string '(q:varchar-type))
+ (pdate '(q:date-type))
+ (ptime '(q:time-type))
+ (ptimestamp-tz '(q:timestamp-with-timezone-type))
+ (universal-time '(q:timestamp-with-timezone-type))
+ (octet-vector '(q:blob-type))
+ (t (if (subtypep type 'persistent-type)
+ (expand-ptype-to-db (persistent-type-pkey-type type))
+ (or (get type 'db-type)
+ (expand-ptype-to-db (ptype-specifier type))))))
+ (ecase (car type)
+ (or
+ (destructuring-bind (a b) (cdr type)
+ (assert (eq 'null a))
+ (expand-ptype-to-db b)))
+ (integer `(q:integer-type ,(cadr type)))
+ (string `(q:char-type ,(cadr type)))
+ (text `(q:varchar-type ,(cadr type))))))
+
+;;(expand-ptype-to-db 'integer)
+;;(expand-ptype-to-db 'string)
+;;(expand-ptype-to-db '(integer 16))
+;;(expand-ptype-to-db '(string 3))
+;;(expand-ptype-to-db '(text 3))
+;;(expand-ptype-to-db '(text 3 2))
+;;(expand-ptype-to-db 'oid)
+;;(expand-ptype-to-db 'natural)
+
+(defun format-pdate (x)
+ (format nil "~4,'0d-~2,'0d-~2,'0d" (pdate-y x) (pdate-m x) (pdate-d x)))
+
+(defun format-ptime (x)
+ (format nil "~2,'0d:~2,'0d:~2,'0d" (ptime-hh x) (ptime-mm x) (ptime-mm x)))
+
+(defun format-ptimestamp-tz (x)
+ (error "TODO to-db ptmestamp-tz"))
+
+(defun format-universal-time (x)
+ (multiple-value-bind (ss mm hh d m y dw st tz)
+ (decode-universal-time x)
+ (declare (ignore dw st))
+ (format nil "~4,'0d-~2,'0d-~2,'0dT~2,'0d:~2,'0d:~2,'0d~a~2,'0d"
+ y m d hh mm ss (if (plusp tz) "+" "-") (abs tz))))
+
+(defun parse-pdate (x)
+ (assert (= 10 (length x)))
+ (assert (char= #\- (char x 4)))
+ (assert (char= #\- (char x 7)))
+ (make-pdate (parse-integer (subseq x 0 4))
+ (parse-integer (subseq x 5 7))
+ (parse-integer (subseq x 8 10))))
+
+(defun parse-ptime (x)
+ (assert (= 8 (length x)))
+ (assert (char= #\: (char x 2)))
+ (assert (char= #\: (char x 5)))
+ (make-ptime (parse-integer (subseq x 0 2))
+ (parse-integer (subseq x 3 5))
+ (parse-integer (subseq x 6))
+ 0))
+
+(defun parse-ptimestamp-tz (x)
+ (error "TODO parse-ptimestamp-tz"))
+
+(defun parse-universal-time (x)
+ (assert (= 22 (length x)))
+ (assert (char= #\- (char x 4)))
+ (assert (char= #\- (char x 7)))
+ (assert (char= #\T (char x 10)))
+ (assert (char= #\: (char x 13)))
+ (assert (char= #\: (char x 16)))
+ (encode-universal-time (parse-integer (subseq x 17 19))
+ (parse-integer (subseq x 14 16))
+ (parse-integer (subseq x 11 13))
+ (parse-integer (subseq x 8 10))
+ (parse-integer (subseq x 5 7))
+ (parse-integer (subseq x 0 4))
+ (parse-integer (subseq x 19))))
+
+;;(print (parse-universal-time (print (format-universal-time (print (get-universal-time)))))) ;; TODO fix tz stuff!
+
+(defun to-db (x type)
+ (if (atom type)
+ (case type
+ (boolean (macroexpand (if x '(q:true-value) '(q:false-value))))
+ (integer x)
+ (string x)
+ (pdate (format-pdate x))
+ (ptime (format-ptime x))
+ (ptimestamp-tz (format-ptimestamp-tz x))
+ (universal-time (format-universal-time x))
+ (octet-vector x)
+ ((t) (prin1-to-string x))
+ (t (if (subtypep type 'persistent-type)
+ (let ((oid (oid x)))
+ (if (atom oid)
+ oid
+ (destructuring-bind (type2 &rest pkey) oid
+ (assert (eq type type2))
+ (assert (not (cdr pkey))) ;; TODO multislot pkey
+ (car pkey))))
+ (to-db x (ptype-specifier type)))))
+ (ecase (car type)
+ (or
+ (destructuring-bind (a b) (cdr type)
+ (assert (eq 'null a))
+ (if x (to-db x b) :null)))
+ (and
+ (destructuring-bind (a b) (cdr type)
+ (assert a)
+ (assert (eq 'satisfies (car b)))
+ (assert (funcall (cadr b) x))
+ (to-db x a)))
+ #+nil(integer `(q:integer-type ,(cadr type)))
+ (string
+ (destructuring-bind (a) (cdr type)
+ (assert (= a (length x)))
+ (to-db x 'string)))
+ (text
+ (assert (apply 'textp (cons x (cdr type))))
+ (to-db x 'string)))))
+
+(defun from-db (x type)
+ (if (atom type)
+ (case type
+ (boolean (cond
+ ((eql x (macroexpand '(q:true-value))) t)
+ ((eql x (macroexpand '(q:false-value))) nil)
+ (t (error "Unknown boolean value ~s of type ~s" x type))))
+ (integer x)
+ (string x)
+ (pdate (parse-pdate x))
+ (ptime (parse-ptime x))
+ (ptimestamp-tz (parse-ptimestamp-tz x))
+ (universal-time (parse-universal-time x))
+ (octet-vector x)
+ (oid x)
+ ((t) (read-from-string x))
+ (t (if (subtypep type 'persistent-type)
+ (error "TODO from-db persistent-type ~s ~s" x type)
+ #+nil
+ (let ((oid (oid x)))
+ (if (atom oid)
+ oid
+ (destructuring-bind (type2 &rest pkey) oid
+ (assert (eq type type2))
+ (assert (not (cdr pkey))) ;; TODO multislot pkey
+ (car pkey))))
+ (from-db x (ptype-specifier type)))
+ ;;(error "TODO from-db")
+ #+nil
+ (if (subtypep type 'persistent-type)
+ (make-proxy x nil)
+ (error "TODO from-db"))))
+ (ecase (car type)
+ (or
+ (destructuring-bind (a b) (cdr type)
+ (assert (eq 'null a))
+ (unless (eq :null x) (from-db x b))))
+ (and
+ (destructuring-bind (a b) (cdr type)
+ (assert a)
+ (assert (eq 'satisfies (car b)))
+ (assert (funcall (cadr b) x))
+ (from-db x a)))
+ #+nil(integer `(q:integer-type ,(cadr type)))
+ (string
+ (destructuring-bind (a) (cdr type)
+ (assert (= a (length x)))
+ (from-db x 'string)))
+ (text
+ (assert (apply 'textp (cons x (cdr type))))
+ (from-db x 'string)))))
+
+(defun to-internal (x type)
+ (if (atom type)
+ (case type
+ (boolean x)
+ (integer x)
+ (string x)
+ (pdate x)
+ (ptime x)
+ (ptimestamp-tz x)
+ (universal-time x)
+ (octet-vector x)
+ ((t) x)
+ (t (if (subtypep type 'persistent-type)
+ x ;;(error "TODO to-internal") ;;(make-proxy (oid x) x)
+ (to-internal x (ptype-specifier type)))))
+ (ecase (car type)
+ (or
+ (destructuring-bind (a b) (cdr type)
+ (assert (eq 'null a))
+ (when x (to-internal x b))))
+ (and
+ (destructuring-bind (a b) (cdr type)
+ (assert a)
+ (assert (eq 'satisfies (car b)))
+ (assert (funcall (cadr b) x))
+ (to-internal x a)))
+ #+nil(integer `(q:integer-type ,(cadr type)))
+ (string
+ (destructuring-bind (a) (cdr type)
+ (assert (= a (length x)))
+ (to-internal x 'string)))
+ (text
+ (assert (apply 'textp (cons x (cdr type))))
+ (to-internal x 'string)))))
+
+(defun from-internal (x type)
+ (if (atom type)
+ (case type
+ (boolean x)
+ (integer x)
+ (string x)
+ (pdate x)
+ (ptime x)
+ (ptimestamp-tz x)
+ (universal-time x)
+ (octet-vector x)
+ (oid x)
+ ((t) x)
+ (t (if (subtypep type 'persistent-type)
+ (load-object type x)
+ (from-internal x (ptype-specifier type)))))
+ (ecase (car type)
+ (or
+ (assert (eq 'null (cadr type)))
+ (assert (not (cddddr type)))
+ (unless (eq :null x)
+ (from-internal x (caddr type))))
+ (and
+ (destructuring-bind (a b) (cdr type)
+ (assert a)
+ (assert (eq 'satisfies (car b)))
+ (assert (funcall (cadr b) x))
+ (from-internal x a)))
+ #+nil(integer `(q:integer-type ,(cadr type)))
+ (string
+ (destructuring-bind (a) (cdr type)
+ (assert (= a (length x)))
+ (from-internal x 'string)))
+ (text
+ (assert (apply 'textp (cons x (cdr type))))
+ (from-internal x 'string)))))
+
+(defmacro defptype (name args specifier &optional #+nil internal db-type db-check)
+ (assert name)
+ `(progn
+ ,@(when specifier `((deftype ,name ,args ,specifier)))
+ (eval-when (:compile-toplevel :load-toplevel :execute)
+ (setf (get ',name 'ptype-args) ,args
+ (get ',name 'ptype-specifier) ,specifier
+ ;;(get ',name 'internal-type) ,internal
+ (get ',name 'db-type) ,db-type
+ (get ',name 'db-check) ,db-check))))
+
+(deftype octet () '(unsigned-byte 8))
+(deftype octet-vector (&optional size) `(simple-array octet (,size)))
+
+(defun natural0p (a)
+ (and (integerp a) (<= 0 a)))
+
+(defptype natural0 () '(and integer (satisfies natural0p)) '(q:integer-type) 'q:le0)
+(defptype natural () '(and integer (satisfies plusp)) '(q:integer-type) 'q:plusp)
+(defptype oid () 'natural)
+(defptype t () () '(q:varchar-type))
+
+(defvar *object-cache*)
+
+(defmacro with-object-cache (() &body body)
+ `(let ((*object-cache* (make-hash-table :test #'equal)))
+ ,@body))
+
+(defun check-cached-object (x)
+ (assert (eq x (gethash (oid x) *object-cache*))))
+
+(defun cache-object (x)
+ (assert (not (gethash (oid x) *object-cache*)))
+ (setf (gethash (oid x) *object-cache*) x))
+
+(defun insert-into (tab args vals returning-cols)
+ (2sql:apply-query args
+ vals
+ `(q:insert-into ,tab ,args
+ (q:values ,@(mapcar (lambda (x) `(q:qvar ,x)) args))
+ (q:returning ,returning-cols))))
+
+(defun %pslot-accessor (k)
+ (values (intern (format nil "$~a" k) (symbol-package k))))
+
+(defun pslot-accessor (table slot)
+ (%pslot-accessor
+ (or (getf (cdr (assoc slot (list-pslots table))) :accessor)
+ (pslot-name (assoc slot (list-pslots table))))))
+
+;;(pslot-accessor 'ex::document 'ex::nr)
+
+(defun build-deftable-args (slots)
+ (loop
+ for x in slots
+ collect (destructuring-bind (k &key initform &allow-other-keys) x
+ (if initform
+ `(,k ,initform)
+ `(,k '%unbound-slot)))))
+
+(defun build-deftable-insert (name slots)
+ (let ((unbound (gensym))
+ (args (gensym))
+ (vals (gensym))
+ (ret (gensym))
+ (ret1 (gensym)))
+ `(let (,unbound ,args ,vals)
+ ,@(loop
+ for x in slots
+ collect (destructuring-bind (k &key type &allow-other-keys) x
+ `(cond
+ ((eq '%unbound-slot ,k) (push ',k ,unbound))
+ (t (push ',k ,args)
+ (push (to-db ,k ',type) ,vals)))))
+ (let ((,ret (insert-into ',name ,args ,vals (nreverse ,unbound))))
+ (assert (not (cdr ,ret)))
+ (let ((,ret1 (car ,ret)))
+ ,@(loop
+ for x in slots
+ collect (destructuring-bind (k &key type &allow-other-keys) x
+ `(when (eq '%unbound-slot ,k)
+ (setq ,k (from-db (pop ,ret1) ',type))))))))))
+
+(defun build-deftable-messages (name slots specs)
+ (nconc
+ (unless (member 'oid slots :key #'car)
+ `((oid
+ (assert (not p))
+ (list ',name ,@(cdr (assoc :pkey specs))))))
+ (loop
+ for x in slots
+ collect (destructuring-bind (k &key type &allow-other-keys) x
+ `(,k ,(if (eq 'oid k)
+ `(progn
+ (assert (not p))
+ (from-internal (bound ,k ',k) ',type))
+ `(if p
+ (setq ,k (to-internal v ',type))
+ (from-internal (bound ,k ',k) ',type))))))))
+
+(defun build-deftable-accessors (slots)
+ (loop
+ for x in slots
+ appending (destructuring-bind (k &key accessor &allow-other-keys) x
+ (unless accessor
+ (setq accessor (%pslot-accessor k)))
+ (unless (eq 'oid k)
+ `((defun ,accessor (x) (funcall x ',k))
+ (defun (setf ,accessor) (v x) (funcall x ',k v)))))))
+
+(defun persistent-type1 (type)
+ (when (subtypep type 'persistent-type)
+ (if (atom type)
+ type
+ (ecase (car type)
+ (or (destructuring-bind (a b) (cdr type)
+ (assert (eq 'null a))
+ b))))))
+
+(defun build-deftable-create-table (name slots specs)
+ `(,@(loop
+ for x in specs
+ when (eq :sequence (car x))
+ appending (destructuring-bind (seq &optional slot) (cdr x)
+ `((q:create-sequence ,seq)
+ ,@ (when slot
+ #+nil ;; TODO alter sequence password_seq_ owned by password.nr
+ (q:alter-sequence seq :owned :by name.slot)))))
+ (q:create-table
+ ,name
+ (q:columns
+ ,@(loop
+ for x in slots
+ collect (destructuring-bind
+ (k &key type db-initform &allow-other-keys) x
+ `(q:column ,k
+ ,(expand-ptype-to-db type)
+ ,(nullablep type)
+ ,db-initform)))))
+ ,@ (let ((pkey (cdr (assoc :pkey specs))))
+ (when pkey
+ `((q:alter-table ,name
+ (q:add-primary-key-constraint
+ ,(intern (format nil "~a-PK" name) (symbol-package name))
+ ,@pkey)))))
+ ,@(loop
+ for x in slots
+ appending (destructuring-bind
+ (k &key type on-delete on-update &allow-other-keys)
+ x
+ (let ((pkey (persistent-type-pkey
+ (persistent-type1 type))))
+ (when pkey
+ `((q:alter-table ,name
+ (q:add-foreign-key-constraint
+ ,(intern (format nil "~a-~a-FK" name k)
+ (symbol-package name))
+ (,k)
+ (,pkey)
+ ,type
+ ,on-delete
+ ,on-update)))))))
+ ,@ (loop
+ for x in specs
+ when (eq :unique (car x))
+ collect (destructuring-bind (uname &rest cols) (cdr x)
+ `(q:alter-table
+ ,name (q:add-unique-constraint ,uname ,@cols))))))
+
+(defun build-deftable-load (name slots specs)
+ (let* ((pkey (cdr (assoc :pkey specs)))
+ (npkey (loop
+ for x in slots
+ for k = (car x)
+ unless (member k pkey)
+ collect k))
+ (package (symbol-package name))
+ (load-name (intern (format nil "LOAD-~a" name) (symbol-package name)))
+ (%class-name (intern (format nil "MAKE-~a" name) package)))
+ `(defun ,load-name ,pkey
+ (or (gethash ,(if (find 'oid slots :key #'car) ;; or (car pkey) ?
+ 'oid
+ `(cons ',name (list ,@pkey)))
+ *object-cache*)
+ (let ((z (2sql:query ,pkey
+ '(q:select (q:clist ,@npkey)
+ (q:from ,name)
+ (q:where
+ (q:and ,@(loop
+ for x in pkey
+ collect `(q:= ,x (q:qvar ,x)))))))))
+ (assert z)
+ (assert (not (cdr z)))
+ (let ((zz (car z)))
+ (let (,@(loop
+ for x in npkey
+ collect `(,x (pop zz))))
+ (cache-object
+ (,%class-name
+ ,@(loop
+ for x in slots
+ for k = (car x)
+ appending `(,(intern (symbol-name k) :keyword) ,k)))))))))))
+
+(defun build-deftable-list (name slots)
+ (let* ((package (symbol-package name))
+ (where
+ (loop
+ for s in slots
+ as n = (pslot-name s)
+ as type = (pslot-type s)
+ collect `(unless (eq '%unbound-slot ,n)
+ (if (atom ,n)
+ `(q:= ,',n ,(to-internal (to-db ,n ',type) ',type))
+ `(q:in ,',n
+ (q:par
+ (q:clist
+ ,@(loop
+ for x in ,n
+ collect (to-internal (to-db x ',type)
+ ',type))))))))))
+ `(defun ,(intern (format nil "LIST-~a" name) package)
+ (project order limit offset
+ &key ,@(mapcar (lambda (x) `(,(pslot-name x) '%unbound-slot)) slots))
+ (2sql-ormc:query ()
+ `(q:select (,@(or project `((2sql-ormc::instance ,',name))))
+ (q:from ,',name)
+ (q:where (q:and ,@(loop
+ for x in (list ,@where)
+ when x
+ collect x)))
+ ,@(when order `((q:order-by ,@order)))
+ ,@(when limit `((q:limit ,limit)))
+ ,@(when offset `((q:offset ,offset))))))))
+
+(defun build-deftable (name body)
+ (let ((package (symbol-package name)))
+ (let ((class-name (intern (format nil "CREATE-~a" name) package))
+ (%class-name (intern (format nil "MAKE-~a" name) package))
+ (slots (car body))
+ (specs (cdr body)))
+ `(progn
+ (defun ,%class-name (&key ,@(build-deftable-args slots))
+ (lambda (msg &optional (v nil p))
+ (flet ((bound (v slot)
+ (if (eq '%unbound-slot v)
+ (error "unbound slot ~s in ~s" slot ',class-name)
+ v)))
+ (ecase msg
+ ,@(build-deftable-messages name slots specs)))))
+ (defun ,class-name (&key ,@(build-deftable-args slots))
+ ,@(loop
+ for x in slots
+ collect (destructuring-bind (k &key type &allow-other-keys) x
+ `(unless (eq '%unbound-slot ,k)
+ (setq ,k (to-internal ,k ',type)))))
+ ,(build-deftable-insert name slots)
+ (cache-object
+ (,%class-name
+ ,@(loop
+ for x in slots
+ for k = (car x)
+ appending `(,(intern (symbol-name k) :keyword) ,k)))))
+ ,@(build-deftable-accessors slots)
+ ,(build-deftable-load name slots specs)
+ ,(build-deftable-list name slots)
+ (eval-when (:compile-toplevel :load-toplevel :execute)
+ (deftype ,name () '(satisfies persistent-type-p))
+ (setf (get ',name 'create-table)
+ ',(build-deftable-create-table name slots specs)
+ (get ',name 'make-object)
+ ',%class-name
+ #+nil(get ',name 'persistent-type)
+ #+nil t))))))
+
+(defmacro deftable (name () &body body)
+ `(progn
+ ,(build-deftable name body)
+ (eval-when (:compile-toplevel :load-toplevel :execute)
+ (setf (get ',name 'deftable-slots) ',(car body)
+ (get ',name 'deftable-specs) ',(cdr body)))))
+
+#+nil
+(2sql:query (oid value)
+ `(q:update ,tab
+ ((,pslot-name (q:qvar value)))
+ (q:where (q:= oid (q:qvar oid)))))
+
+#+nil
+(defconstant +table-id-bit-size+ 16)
+
+;; #+nil
+;; (defmacro oid-exp (table-id)
+;; (let ((bit-size +table-id-bit-size+))
+;; `(q:backend-ecase
+;; (:oracle (q:+ (q:* (q:nextval oid-seq) (q:power 2 ,bit-size)) ,table-id))
+;; (:postgresql ;; TODO oid_seq_ via symbol printing
+;; (q:\| (q:<< (q:nextval "oid_seq_") ,bit-size) ,table-id))
+;; (:sqlite (q:\| (q:<< (q:nextval oid-seq) ,bit-size) ,table-id)))))
+
+#+nil
+(defun setup-pclass (class-name)
+ (2sql:query ()
+ `(q:create-table
+ ,class-name
+ (q:columns
+ (q:column oid (q:integer-type) nil
+ (oid-exp (q:qchunk (class-name-to-class-id ',class-name))))
+ ,@(loop
+ for x in (list-pslots class-name)
+ unless (eq 'oid (pslot-name x))
+ collect `(q:column ,(pslot-name x)
+ ,(pslot-ptype x)
+ ,(pslot-nullable x)
+ ,(pslot-initform x)))))))
+
+#+nil
+(defun assert-type (value type)
+ (unless (typep value type)
+ (cond ;; TODO more cases
+ ((typep value 'string)
+ (setq value (coerce value 'simple-string)))
+ ((typep value 'simple-date:timestamp)
+ (setq value (multiple-value-bind (y m d hh mm ss ms)
+ (simple-date:decode-timestamp value)
+ (make-ptimestamp-tz (make-pdate y m d)
+ (make-ptime hh mm ss ms)
+ nil))))
+ ((subtypep type 'persistent-object)
+ (setq value (or (gethash value *instance-cache*)
+ (make-proxy value))))))
+ (assert (or (typep value type)
+ (when (subtypep type 'persistent-object)
+ (proxy-p value))))
+ value)
+
+#+nil
+(defun delete-object (x)
+ (let ((oid (oid x)))
+ (remhash oid *object-cache*)
+ (2sql:query (oid)
+ `(q:delete-from ,(type-of a)
+ (q:where (q:= oid (q:qvar oid)))))))
+
+(defparameter *instance-collector-cache* nil) ;; equal form->fn
+
+(defmacro with-pinstance-collector-cache (args &body body)
+ (declare (ignore args))
+ `(let ((*instance-collector-cache* (make-hash-table :test #'equal)))
+ ,@body))
+
+(defparameter *instance-collectors* nil) ;; list fn
+
+(defun %query (form rows)
+ (multiple-value-bind (value present)
+ (gethash form *instance-collector-cache*)
+ (cond
+ (present
+ (assert (not *instance-collectors*))
+ (setq *instance-collectors* value))
+ (t
+ (setq *instance-collectors* (nreverse *instance-collectors*))
+ (setf (gethash form *instance-collector-cache*) *instance-collectors*))))
+ (loop
+ for row in rows
+ for tail = row
+ collect (nconc (loop
+ for fn in *instance-collectors*
+ collect (multiple-value-bind (instance tail2)
+ (funcall fn tail)
+ (setq tail tail2)
+ instance))
+ tail)))
+
+(defmacro query (args form)
+ `(let ((*instance-collectors* nil) ;; TODO that's not right is it? need to remember form->collector! for subsequent queries
+ #+nil(*alias-to-table* (make-hash-table)))
+ ;;(maphash (lambda (k v) (print (list :@@@ k v))) *alias-to-table*)
+ (%query ,form (2sql:query ,args ,form))))
+
+#+nil
+(defmacro query (args form)
+ `(let* (#+nil(*alias-to-table* (make-hash-table))
+ (*instance-collectors* nil) ;; TODO that's not right is it? need to remember form->collector! for subsequent queries
+ (rows (2sql:query ,args ,form)))
+ ;;(maphash (lambda (k v) (print (list :@@@ k v))) *alias-to-table*)
+ (multiple-value-bind (value present)
+ (gethash ,form *instance-collector-cache*)
+ (cond
+ (present
+ (assert (not *instance-collectors*))
+ (setq *instance-collectors* value))
+ (t
+ (setq *instance-collectors* (nreverse *instance-collectors*))
+ (setf (gethash ,form *instance-collector-cache*) *instance-collectors*))))
+ (loop
+ for row in rows
+ for tail = row
+ collect (nconc (loop
+ for fn in *instance-collectors*
+ collect (multiple-value-bind (instance tail2)
+ (funcall fn tail)
+ (setq tail tail2)
+ instance))
+ tail))))
+
+(defun list-pslots (table)
+ (get table 'deftable-slots))
+
+(defun pslot-name (pslot)
+ (car pslot))
+
+(defun pslot-type (pslot)
+ (getf (cdr pslot) :type))
+
+;;(list-pslots 'ex::document)
+;;(pslot-name (car (list-pslots 'ex::document)))
+;;(pslot-type (cadr (list-pslots 'ex::document)))
+
+(defun pslot-initarg (pslot)
+ (or (getf (cdr pslot) :initarg)
+ (values (intern (symbol-name (pslot-name pslot)) :keyword))
+ #+nil(pslot-name pslot))) ;; TODO this is better + explicit keyword
+
+(defun make-object (table &rest args)
+ (apply (get table 'make-object) args))
+
+;;(get 'ex::document 'make-object)
+
+(defmacro instance (tab &optional alias) ;; use inside 2sql queries
+ (let ((pslots (list-pslots tab)))
+ (push (lambda (row)
+ (values (let ((oid (car row))
+ (args (loop
+ for x in pslots
+ appending (list (pslot-initarg x)
+ (pop row)
+ ;;(from-db (pop row) (pslot-type x))
+ #+nil(assert-type (pop row) (pslot-type x)))))) ;; TODO resolve pclassp foreign ref (lazy foreign reference?)
+ ;;(print (list :@@@ (mapcar (lambda (x) (cons x (type-of x))) args)))
+ (or (gethash oid *object-cache*)
+ (cache-object (apply 'make-object tab args)))
+ #+nil
+ (unless (eq :null oid)
+ ;; TODO uniq oid->instance cache
+ (apply #'make-instance tab :oid oid args))) ;; TODO fix values from rdbms backend to lisp, e.g. :null :true :false pclasp
+ row))
+ *instance-collectors*)
+ `(q:clist
+ ,@ (flet ((sym (name)
+ (if alias
+ (intern (format nil "~a.~a" alias name)) ;; TODO avoid intern
+ name)))
+ (mapcar (lambda (x) (sym (pslot-name x))) pslots)))))
+
+(defmacro with-pobject ((name &rest slots) object &body body)
+ (let ((_object (gensym)))
+ `(let ((,_object ,object))
+ (symbol-macrolet
+ ,(mapcar (lambda (s) `(,s (,(pslot-accessor name s) ,_object))) slots)
+ ,@body))))
+
+(defun load-object (table oid)
+ (or (gethash oid *object-cache*)
+ (let ((x (query (oid)
+ `(q:select ((instance ,table))
+ (q:from ,table)
+ (q:where (q:= oid (q:qvar oid)))))))
+ (assert (not (cdr x)))
+ (assert (car x))
+ (assert (not (cadr x)))
+ (assert (functionp (caar x)))
+ (caar x))))
+
+;; #+nil
+;; (defmacro with-pclasses (names &body body)
+;; (labels ((rec (x)
+;; (if x
+;; `(progn
+;; (c2mop:ensure-finalized (find-class ',(car x)))
+;; (2sql-orm:setup-pclass ',(car x))
+;; (unwind-protect ,(rec (cdr x))
+;; (2sql:query () '(q:drop-table ,(car x) t t))))
+;; `(progn ,@body))))
+;; (rec names)))
+
+;; #+nil
+;; (defmacro with-psequences (names &body body)
+;; (labels ((rec (x)
+;; (if x
+;; `(progn
+;; (2sql:query () '(q:create-sequence ,(car x)))
+;; (unwind-protect ,(rec (cdr x))
+;; (2sql:query () '(q:drop-sequence ,(car x) t))))
+;; `(progn ,@body))))
+;; (rec names)))
diff --git a/packages.lisp b/packages.lisp
@@ -1,56 +0,0 @@
-;;; cl-2sql Copyright (c) 2011 Tomas Hlavaty
-
-(in-package :cl-user)
-
-(defpackage 2sql
- (:use :cl)
- (:export
- ;; printer
- #:print-string
- #:print-symbol
- #:print-qvar
- #:print-form
- #:pure-form-to-string
- #:to-string
- ;; compiler
- #:*backend*
- #:*compiled-query-lambda-cache*
- #:execute
- #:query
- #:qlambda
- #:qdefun
- #:apply-query
- #:qlet
- #:qmacroexpand
- #:qmap
- #:quoted-query
- ))
-
-(defpackage 2sql-macros
- (:use)
- (:nicknames :q) ;; TODO really?
- (:import-from :cl #:&optional #:&rest #:&body #:nil #:t))
-
-(defpackage 2sql-backend
- (:use :cl)
- (:export
- #:with-postgresql-connection
- #:with-sqlite-connection))
-
-(defpackage 2sql-orm
- (:use :cl)
- (:export
- #:textp
- #:text
- #:defptype
- #:defpclass
- #:setup-pclass
- #:with-instance-cache
- #:make-pinstance
- #:with-pinstance-collector-cache
- #:query
- #:instance
- ))
-
-(defpackage 2sql-tests
- (:use :cl :2sql))
diff --git a/printer.lisp b/printer.lisp
@@ -1,85 +0,0 @@
-;;; 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
@@ -1,7 +1,68 @@
;;; cl-2sql Copyright (c) 2011 Tomas Hlavaty
+(defpackage 2sql-tests
+ (:use :cl :2sql))
+
(in-package :2sql-tests)
+;; (setq c (make-sqlite-server "./dbquery-sqlite" "sqlite.db"))
+;; (time (funcall c "select 1, 2+3"))
+;; (time (funcall c "select 4, 'hello'"))
+;; (funcall c nil)
+;; (funcall c)
+
+;; (setq c (make-pg-server "./dbquery-pg" "dbname='pokus' user='tomas'"))
+;; (time (funcall c "select 1, 2+3"))
+;; (time (funcall c "select 4, 'hello'"))
+;; (funcall c nil)
+;; (funcall c)
+
+;; (setq c (make-mysql-server "./dbquery-mysql" "localhost" "tomas" "Ri3OoL3h" "pokus"))
+;; (time (funcall c "select 1, 2+3"))
+;; (time (funcall c "select 4, 'hello'"))
+;; (funcall c nil)
+;; (funcall c)
+
+
+(loop
+ for (2sql:*backend* backend)
+ in (list
+ (list :postgresql
+ (2sql-dbquery:make-backend
+ (dbquery:make-pg-server "/home/tomas/git/dbquery/dbquery-pg"
+ "dbname='pokus' user='tomas'")))
+ #+nil
+ (list :postgresql
+ (2sql-cl-postgres:make-backend "pokus" "tomas" "test123" "localhost" 5432 :no))
+ #+nil
+ (list :sqlite
+ (2sql-dbquery:make-backend
+ (dbquery:make-sqlite-server "/home/tomas/git/dbquery/dbquery-sqlite"
+ "/home/tomas/git/dbquery/sqlite.db")))
+ #+nil ;; TODO dbquery-mysql
+ (list :mysql
+ (2sql-dbquery:make-backend
+ (dbquery:make-mysql-server "/home/tomas/git/dbquery/dbquery-mysql"
+ "localhost" "tomas" "Ri3OoL3h" "pokus"))))
+ collect (progn ;;time
+ (2sql:with-server ((2sql::make-server backend))
+ (2sql:with-backend (2sql:*backend*)
+ (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)
+ #+nil
+ (q:select ((q:sqrt 2)))
+ #+nil
+ (q:select ((q:sqrt (q:qvar a #+nil(q:integer-type)))))
+ (q:select ((q:sqrt (q:qvar a (q:integer-type))))))))
+ (progn ;;time
+ (list 2sql:*backend*
+ (funcall q a)
+ (funcall q a))))))))))
+
+
@@ -138,19 +199,18 @@
(let ((v1 "hello")
(v2 314159))
- (query (q:select (:*)
- (q:from x)
- (q:where (q:= (q:qvar v1) (q:qvar v2))))))
+ (2sql:query (v1 v2)
+ '(q:select (q:+ (q:qvar v1) (q:qvar v2)))))
(let ((v1 "hello")
(v2 314159))
- (query ;; macroexpand
- (q:select (:*)
- (q:from x)
- (q:where (q:where (q:= (q:qvar v1) (q:qvar v2)))))))
+ (2sql:query (v1 v2) ;; macroexpand
+ '(q:select (:*)
+ (q:from x)
+ (q:where (q:where (q:= (q:qvar v1) (q:qvar v2)))))))
(let ((v1 "hello")
(v2 314159)
@@ -188,7 +248,7 @@
;;(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)))))))
+ (q:select ((q:sqrt (q:qvar a (q:integer-type))))))))
(funcall q a)
(funcall q a)))) ;; reusing from *compiled-query-lambda-cache*
@@ -210,30 +270,33 @@
;; suppress-qvar
-(with-postgresql-connection ("pokus" "tomas" "test123" "localhost")
+(2sql-backend: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)))))))
+ (2sql:query (a b)
+ '(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")
+(2sql-backend: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))))
+#+nil
+(2sql-backend:with-postgresql-connection ("pokus" "tomas" "test123" "localhost")
+ (2sql: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))))
+#+nil
(with-postgresql-connection ("pokus" "tomas" "test123" "localhost")
(flet ((mul (x y) ;; TODO undefined function! capture flet?
(* x y)))
@@ -262,27 +325,28 @@ bytea (vector (unsigned-byte 8))
(defmacro integer-qvar (name)
`(q:qvar ,name :integer))
-(with-postgresql-connection ("pokus" "tomas" "test123" "localhost")
+(2sql-backend:with-postgresql-connection ("pokus" "tomas" "test123" "localhost")
(let ((a 2))
- (query (q:select ((q:sqrt (integer-qvar a))
- (q:+ 1 (q:qchunk (+ 2 3))))))))
+ (2sql:query (a)
+ '(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))))
+(2sql-backend:with-postgresql-connection ("pokus" "tomas" "test123" "localhost")
+ (2sql:query () '(q:select (q:clist 22 "Folie et déraison" #+nil 4.5 ))))
-(with-postgresql-connection ("pokus" "tomas" "test123" "localhost")
+(2sql-backend: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))))))))
+ (2sql:query (a b c d)
+ '(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))))))))
@@ -330,25 +394,25 @@ bytea (vector (unsigned-byte 8))
-(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))))))
+(2sql-backend:with-postgresql-connection ("pokus" "tomas" "test123" "localhost")
+ (2sql: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))))))
+(2sql-backend:with-postgresql-connection ("pokus" "tomas" "test123" "localhost")
+ (2sql: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
@@ -394,12 +458,12 @@ bytea (vector (unsigned-byte 8))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; orm
-(defpclass t1 ()
+(2sql-orm: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)))
-(defpclass t2 ()
+(2sql-orm:defpclass t2 ()
((d1 :type integer :initarg :d1 :accessor d1)
(d2 :type (or null integer) :initarg :d2 :initform nil :accessor d2)
(d3 :type integer :initarg :d3 :initform 271 :accessor d3)))
@@ -407,30 +471,27 @@ bytea (vector (unsigned-byte 8))
(trace 2sql:execute)
(2sql-backend:with-postgresql-connection ("pokus" "tomas" "test123" "localhost")
- (with-pinstance-collector-cache ()
- (2sql:query () '(q:drop-sequence oid-seq t))
- (2sql:query () '(q:create-sequence oid-seq))
- (with-tables (t1 t2)
- (make-pinstance 't1 :c1 1 :c2 2 :c3 3)
- (make-pinstance 't1 :c1 1 :c2 2)
- (2sql:query () '(q:select :* (q:from t1)))
-
- #+nil
- (x-query ()
- '(q:select ((x-instance t1 x) (q:sum x.c1))
- (q:from (q:as t1 x))))
- ;;(x-query () '(q:select ((x-instance t1)) (q:from t1)))
- (x-query ()
- '(q:select ((x-instance t1 a) (x-instance t2 b) a.c2)
- (q:from (q:left-join (q:as t1 a) (q:as t2 b) (q:= a.c1 b.d1)))))
- ;; this works 2nd time only with *instance-collector-cache*
- ;;(x-query () '(q:select ((x-instance t1)) (q:from t1)))
- ;;(x-query () '(q:select ((x-instance t1)) (q:from t1)))
- )))
-
-select => populate instances
-update => clear affected instances from cache
-delete => clear affected instances from cache
+ (2sql-orm:with-pinstance-collector-cache ()
+ (2sql-orm:with-instance-cache ()
+ (2sql:query () '(q:drop-sequence oid-seq t))
+ (2sql:query () '(q:create-sequence oid-seq))
+ (2sql-orm::with-pclasses (t1 t2)
+ (2sql-orm:make-pinstance 't1 :c1 1 :c2 2 :c3 3)
+ (2sql-orm:make-pinstance 't1 :c1 1 :c2 2)
+ (2sql:query () '(q:select :* (q:from t1)))
+ #+nil
+ (x-query ()
+ '(q:select ((x-instance t1 x) (q:sum x.c1))
+ (q:from (q:as t1 x))))
+ ;;(x-query () '(q:select ((x-instance t1)) (q:from t1)))
+ #+nil
+ (x-query ()
+ '(q:select ((x-instance t1 a) (x-instance t2 b) a.c2)
+ (q:from (q:left-join (q:as t1 a) (q:as t2 b) (q:= a.c1 b.d1)))))
+ ;; this works 2nd time only with *instance-collector-cache*
+ ;;(x-query () '(q:select ((x-instance t1)) (q:from t1)))
+ ;;(x-query () '(q:select ((x-instance t1)) (q:from t1)))
+ ))))
;;; http://www.pui.ch/phred/archives/2005/04/tags-database-schemas.html
;;; toxi solution
@@ -460,6 +521,7 @@ delete => clear affected instances from cache
(defun build-sql-query (q)
`(q:par
,(if (atom q)
+ ;; TODO not :b_.* but (2sql-orm:instance b) and coolect only if toplevel select
`(q:select :b_.* ;; TODO b.* w/o interning (q:dotted-name b :*)
(q:from (q:as bookmark b) (q:as tag t) (q:as tagmap m))
(q:where (q:and (q:= b.oid m.bookmark)
@@ -472,31 +534,32 @@ delete => clear affected instances from cache
(2sql-backend:with-postgresql-connection ("pokus" "tomas" "test123" "localhost")
(2sql-orm:with-pinstance-collector-cache ()
- (2sql-orm::with-psequences (oid-seq)
- (2sql-orm::with-pclasses (tag bookmark tagmap)
- (let ((t1 (make-tag "bookmark"))
- (t2 (make-tag "webservice"))
- (t3 (make-tag "semweb"))
- (t4 (make-tag "lisp"))
- (t5 (make-tag "sql"))
- (b1 (make-bookmark "b1"))
- (b2 (make-bookmark "b2")))
- (make-tagmap b1 t1)
- (make-tagmap b1 t2)
- (make-tagmap b1 t3)
- (make-tagmap b1 t4)
- (make-tagmap b2 t1)
- (make-tagmap b2 t2)
- (flet ((look-up (q)
- (2sql-orm:query () ;; TODO cache compiled queries
- `(q:select ((2sql-orm:instance bookmark x))
- (q:from (q:as ,(build-sql-query q) x))))))
- ;; Query for “bookmark+webservice+semweb”
- (look-up '(and "bookmark" "webservice" "semweb"))
- ;; Query for “bookmark|webservice|semweb”
- (look-up '(or "bookmark" "webservice" "semweb"))
- ;; Query for “bookmark+webservice-semweb”
- (look-up '(not (and "bookmark" "webservice") "semweb"))))))))
+ (2sql-orm:with-instance-cache ()
+ (2sql-orm::with-psequences (oid-seq)
+ (2sql-orm::with-pclasses (tag bookmark tagmap)
+ (let ((t1 (make-tag "bookmark"))
+ (t2 (make-tag "webservice"))
+ (t3 (make-tag "semweb"))
+ (t4 (make-tag "lisp"))
+ (t5 (make-tag "sql"))
+ (b1 (make-bookmark "b1"))
+ (b2 (make-bookmark "b2")))
+ (make-tagmap b1 t1)
+ (make-tagmap b1 t2)
+ (make-tagmap b1 t3)
+ (make-tagmap b1 t4)
+ (make-tagmap b2 t1)
+ (make-tagmap b2 t2)
+ (flet ((look-up (q)
+ (2sql-orm:query () ;; TODO cache compiled queries
+ `(q:select ((2sql-orm:instance bookmark x))
+ (q:from (q:as ,(build-sql-query q) x))))))
+ ;; Query for “bookmark+webservice+semweb”
+ (look-up '(and "bookmark" "webservice" "semweb"))
+ ;; Query for “bookmark|webservice|semweb”
+ (look-up '(or "bookmark" "webservice" "semweb"))
+ ;; Query for “bookmark+webservice-semweb”
+ (look-up '(not (and "bookmark" "webservice") "semweb")))))))))
;; http://pinterface.livejournal.com/34706.html
;; http://pinterface.livejournal.com/35042.html
@@ -507,7 +570,7 @@ delete => clear affected instances from cache
(2sql-orm:defptype title () '(2sql-orm:text 64))
(2sql-orm:defptype body () '(2sql-orm:text 128))
-(2sql-orm:defptype timestamp () '2sql-orm::ptimestamp-with-timezone)
+(2sql-orm:defptype timestamp () '2sql-orm::ptimestamp-tz)
(2sql-orm:defpclass blog-post ()
((title :type title :initarg :title)
@@ -515,24 +578,24 @@ delete => clear affected instances from cache
(created :type timestamp :initarg :created)))
(defun now ()
- (2sql-orm::make-ptimestamp-with-timezone
- :date (2sql-orm::make-pdate :y 2011 :m 8 :d 13)
- :time (2sql-orm::make-ptime :hh 17 :mm 4 :ss 0 :ms 0)
- :timezone nil))
+ (2sql-orm::make-ptimestamp-tz (2sql-orm::make-pdate 2011 8 13)
+ (2sql-orm::make-ptime 17 4 0 0)
+ nil))
(defun make-blog-post (title body)
(2sql-orm:make-pinstance 'blog-post :title title :body body :created (now)))
(2sql-backend:with-postgresql-connection ("pokus" "tomas" "test123" "localhost")
(2sql-orm:with-pinstance-collector-cache ()
- (2sql-orm::with-psequences (oid-seq)
- (2sql-orm::with-pclasses (blog-post)
- (let ((p1 (make-blog-post "Hello blog world" "First post!"))
- (p2 (make-blog-post "This is fun" "Common Lisp is easy!")))
- (2sql-orm:query ()
- `(q:select ((2sql-orm:instance blog-post x))
- (q:from (q:as blog-post x))
- (q:where (q:like x.title "%wor%")))))))))
+ (2sql-orm:with-instance-cache ()
+ (2sql-orm::with-psequences (oid-seq)
+ (2sql-orm::with-pclasses (blog-post)
+ (let ((p1 (make-blog-post "Hello blog world" "First post!"))
+ (p2 (make-blog-post "This is fun" "Common Lisp is easy!")))
+ (2sql-orm:query ()
+ `(q:select ((2sql-orm:instance blog-post x))
+ (q:from (q:as blog-post x))
+ (q:where (q:like x.title "%wor%"))))))))))
#+nil
(defun save-blog-post ()
