commit 2853aa882c9be6718135107b6ea166b90e877c9e
parent 51c9d9408159416facf8762b5bcb06dede37b509
Author: Tomas Hlavaty <tom@logand.com>
Date: Sat, 13 Aug 2011 20:00:52 +0200
orm improved
Diffstat:
5 files changed, 249 insertions(+), 117 deletions(-)
diff --git a/backend.lisp b/backend.lisp
@@ -6,7 +6,6 @@
(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
@@ -18,7 +17,6 @@
(unwind-protect (funcall fn)
(cl-postgres:close-database *database*))))
-#+postgresql
(defmacro with-postgresql-connection ((database user password host
&optional (port 5432)
(use-ssl :no))
@@ -26,7 +24,6 @@
`(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))
@@ -36,14 +33,12 @@
(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
@@ -56,7 +51,6 @@
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/
diff --git a/cl-2sql.asd b/cl-2sql.asd
@@ -13,11 +13,16 @@
:depends-on (:split-sequence
:ironclad
:babel
- #+postgresql :cl-postgres
- #+sqlite :sqlite)
+ ;;#+postgresql :cl-postgres
+ ;;#+sqlite :sqlite
+ :cl-postgres
+ :sqlite
+ )
:serial t
:components ((:file "packages")
(:file "printer")
(:file "compiler")
(:file "macros")
- #+(or postgresql sqlite) (:file "backend")))
+ ;;#+(or postgresql sqlite) (:file "backend")
+ (:file "backend")
+ (:file "orm")))
diff --git a/orm.lisp b/orm.lisp
@@ -2,43 +2,149 @@
(in-package :2sql-orm)
+;; 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
+
+(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 y m d)
+(defstruct ptime hh mm ss ms)
+(defstruct ptimestamp-with-timezone date time timezone)
+;;(defstruct pinterval y m d hh mm ss ms)
+
+(defmethod cl-postgres:to-sql-string ((a pdate))
+ (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
+ (with-slots (date time timezone) a
+ (with-slots (y m d) date
+ (with-slots (hh mm ss ms) time
+ (values
+ (format nil "~4,'0d-~2,'0d-~2,'0d ~2,'0d:~2,'0d:~2,'0d~@[.~3,'0d~]"
+ y m d hh mm ss (if (zerop ms) nil ms))
+ "timestamp")))))
+
+#+nil
+(defmethod cl-postgres:to-sql-string ((a pinterval))
+ (with-slots (y m d hh mm ss ms) a
+ (if (= year month day hour min sec ms 0)
+ (values "0 milliseconds" "interval")
+ (flet ((not-zero (x) (if (zerop x) nil x)))
+ (values
+ (format nil "~@[~d years ~]~@[~d months ~]~@[~d days ~]~@[~d hours ~]~@[~d minutes ~]~@[~d seconds ~]~@[~d milliseconds~]"
+ (not-zero year) (not-zero month) (not-zero day)
+ (not-zero hour) (not-zero min) (not-zero sec) (not-zero ms))
+ "interval")))))
+
+(deftype octet () '(unsigned-byte 8))
+(deftype octet-vector (&optional size) `(simple-array octet (,size)))
+
+(defgeneric ptype-macroexpand (type))
+
+(defgeneric pclassp (class-name)
+ (:method (a)))
+
(defun lisp-type-to-ptype (type) ;; TODO more types
(if (atom type)
- (ecase type
- (integer '(q:integer-type)))
+ (case type
+ (boolean '(q:boolean-type))
+ (integer '(q:integer-type))
+ (string '(q:varchar-type))
+ (pdate '(q:date-type))
+ (ptime '(q:time-type))
+ (ptimestamp-with-timezone '(q:timestamp-with-timezone-type))
+ (octet-vector '(q:blob-type))
+ (t
+ (cond
+ ((pclassp type) (lisp-type-to-ptype 'oid))
+ (t (let ((x (ptype-macroexpand type)))
+ (assert (not (eq x type)))
+ (lisp-type-to-ptype x))))))
(ecase (car type)
(or
(assert (eq 'null (cadr type)))
(assert (not (cddddr type)))
- (lisp-type-to-ptype (caddr type))))))
+ (lisp-type-to-ptype (caddr type)))
+ (integer `(q:integer-type ,(cadr type)))
+ (string `(q:char-type ,(cadr type)))
+ (text `(q:varchar-type ,(cadr type))))))
+
+;; (lisp-type-to-ptype 'integer)
+;; (lisp-type-to-ptype 'string)
+;; (lisp-type-to-ptype '(integer 16))
+;; (lisp-type-to-ptype '(string 3))
+;; (lisp-type-to-ptype '(text 3))
+;; (lisp-type-to-ptype '(text 3 2))
+
+(defmacro defptype (name args specifier &optional db-type db-check)
+ `(progn
+ (deftype ,name ,args ,specifier)
+ (defmethod 2sql-orm::ptype-macroexpand ((type (eql ',name)))
+ ,(if db-type `(values ,db-type ,db-check) specifier))))
+
+(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)
+
+(defptype oid () 'natural1)
+
+(defstruct pslot name ltype ptype nullable initarg initform)
(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)
+ ,(cons '(oid :type oid :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)))
-
-(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)))
+ (defmethod pclassp ((class-name (eql ',name)))
+ t)
+ (defmethod cl-postgres:to-sql-string ((a ,name))
+ (cl-postgres:to-sql-string (oid a)))
+ (let ((cache nil))
+ (defmethod list-pslots ((class-name (eql ',name)))
+ (or cache
+ (setq cache
+ (list
+ ,@(loop
+ for x in direct-slots
+ for type = (cadr (member :type x))
+ collect `(make-pslot
+ :name ',(car x)
+ :ltype ',type
+ :ptype ',(lisp-type-to-ptype type)
+ :nullable ', (unless (eql 'boolean type)
+ (typep nil type))
+ :initarg ',(cadr (member :initarg x))
+ :initform ',(cadr (member :initform x)))))))))))
(defconstant +class-id-bit-size+ 16)
@@ -56,130 +162,103 @@
(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 (name type nullable initarg default) in (list-pslots class-name)
- collect `(q:column ,name ,type ,nullable ,default))))))
+ `(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)
+ collect `(q:column ,(pslot-name x)
+ ,(pslot-ptype x)
+ ,(pslot-nullable x)
+ ,(pslot-initform 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 assert-type (value type)
+ (assert (typep value type))
+ value)
(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 x in (list-pslots class-name)
+ for name = (pslot-name x)
+ for initarg = (pslot-initarg x)
+ for ltype = (pslot-ltype x)
for c = (member initarg args)
- if c collect (list name initarg (cadr c)) into known
- else collect (cons name initarg) into unknown
+ if c collect (list (cadr c) name initarg ltype) into known
+ else collect (list name initarg ltype) into unknown
finally (return (values known unknown)))
+ ;; TODO cache eql oid->instance
(apply #'make-instance class-name
(nconc
(loop
- for (name initarg value) in known
- appending (list initarg value))
+ for (v name initarg ltype) in known
+ appending (list initarg (assert-type v ltype)))
(loop
- for (name . initarg) in (cons (cons 'oid :oid) unknown)
- for value in (car (2sql: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)
+ for (name initarg ltype) in (cons (list 'oid :oid 'oid) unknown)
+ for v in (car
+ (insert-into class-name (mapcar #'cadr known)
+ (mapcar #'car known)
+ (cons 'oid (mapcar #'car unknown))))
+ appending (list initarg (assert-type v ltype)))))))
(defparameter *instance-collector-cache* nil) ;; equal form->fn
-(defmacro with-instance-collector-cache (args &body body)
+(defmacro with-pinstance-collector-cache (args &body body)
(declare (ignore args))
`(let ((*instance-collector-cache* (make-hash-table :test #'equal)))
,@body))
-(2sql-backend:with-postgresql-connection ("pokus" "tomas" "test123" "localhost")
- (with-instance-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)))
- )))
-
-;;(defparameter *x-alias-to-table* nil)
-(defparameter *x-instance-collectors* nil) ;; list fn
+(defparameter *instance-collectors* nil) ;; list fn
-#+nil
-(defmacro x-columns (cols)
- (cols))
-
-(defmacro x-query (args form)
- `(let* (#+nil(*x-alias-to-table* (make-hash-table))
- (*x-instance-collectors* nil) ;; TODO that's not right is it? need to remember form->collector! for subsequent queries
+(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))) *x-alias-to-table*)
+ ;;(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 *x-instance-collectors*))
- (setq *x-instance-collectors* (gethash ,form *instance-collector-cache*)))
+ (assert (not *instance-collectors*))
+ (setq *instance-collectors* value))
(t
- (setq *x-instance-collectors* (nreverse *x-instance-collectors*))
- (setf (gethash ,form *instance-collector-cache*) *x-instance-collectors*))))
+ (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 *x-instance-collectors*
+ for fn in *instance-collectors*
collect (multiple-value-bind (instance tail2)
(funcall fn tail)
(setq tail tail2)
instance))
tail))))
-#+nil ;; happens after x-instance:-{
-(defmacro x-as (tab alias)
- ;; remember alias -> tab
- (assert (not (gethash alias *x-alias-to-table*)))
- (setf (gethash alias *x-alias-to-table*) tab)
- `(q:as ,tab ,alias))
-
-(defmacro x-instance (tab &optional alias)
+(defmacro instance (tab &optional alias) ;; use inside 2sql queries
(let ((pslots (list-pslots tab)))
(push (lambda (row)
(values (let ((oid (pop row))
(args (loop
- for (name type nullable initarg default) in pslots
- appending (list initarg (pop row)))))
+ for x in pslots
+ appending (list (pslot-initarg x) (pop row))))) ;; TODO resolve pclassp foreign ref (lazy foreign reference?)
(unless (eq :null oid)
- ;; TODO uniq oid instance cache
+ ;; TODO uniq oid->instance cache
(apply #'make-instance tab :oid oid args)))
row))
- *x-instance-collectors*)
+ *instance-collectors*)
`(q:clist
,@ (flet ((sym (name)
(if alias
(intern (format nil "~a.~a" alias name)) ;; TODO avoid intern
name)))
- (cons (sym 'oid) (mapcar (lambda (x) (sym (car x))) pslots))))))
-
-select => populate instances
-update => clear affected instances from cache
-delete => clear affected instances from cache
+ (cons (sym 'oid) (mapcar (lambda (x) (sym (pslot-name x))) pslots))))))
diff --git a/packages.lisp b/packages.lisp
@@ -33,11 +33,23 @@
(defpackage 2sql-backend
(:use :cl)
- (:export #+postgresql #:with-postgresql-connection
- #+sqlite #:with-sqlite-connection))
+ (:export
+ #:with-postgresql-connection
+ #:with-sqlite-connection))
(defpackage 2sql-orm
- (:use :cl))
+ (:use :cl)
+ (:export
+ #:textp
+ #:text
+ #:defptype
+ #:defpclass
+ #:setup-pclass
+ #:make-pinstance
+ #:with-pinstance-collector-cache
+ #:query
+ #:instance
+ ))
(defpackage 2sql-tests
(:use :cl :2sql))
diff --git a/test.lisp b/test.lisp
@@ -389,3 +389,45 @@ bytea (vector (unsigned-byte 8))
;;(q:where (q:infix " MATCH " c4 "*ov")) ;; doesnt work
;;(q:where (q:infix " MATCH " c4 "ivan AND ivanov"))
)))
+
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 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 ()
+ ((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)))
+
+(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
