cl-2sql

Lisp to SQL compiler for Common Lisp
git clone https://logand.com/git/cl-2sql.git/
Log | Files | Refs | README | LICENSE

commit 2853aa882c9be6718135107b6ea166b90e877c9e
parent 51c9d9408159416facf8762b5bcb06dede37b509
Author: Tomas Hlavaty <tom@logand.com>
Date:   Sat, 13 Aug 2011 20:00:52 +0200

orm improved

Diffstat:
Mbackend.lisp | 6------
Mcl-2sql.asd | 11++++++++---
Morm.lisp | 289++++++++++++++++++++++++++++++++++++++++++++++++++-----------------------------
Mpackages.lisp | 18+++++++++++++++---
Mtest.lisp | 42++++++++++++++++++++++++++++++++++++++++++
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