ormc.lisp (30460B)
1 ;;; cl-2sql Copyright (c) 2011 Tomas Hlavaty 2 3 (defpackage 2sql-ormc 4 (:use :cl) 5 (:export :textp 6 :text 7 :defptype 8 :defpclass 9 :deftable 10 :setup-pclass 11 :with-instance-cache 12 :make-pinstance 13 :with-pinstance-collector-cache 14 :query 15 :instance 16 )) 17 18 (in-package :2sql-ormc) 19 20 ;;; orm types 21 22 ;; string => string | clob 23 ;; string 3 => char 3 24 ;; text 5 &optional 2 => varchar 5 (no "" allowed, due to oracle) 25 ;; string-or-text => string | varchar 26 ;; char 1 => boolean 27 28 (deftype universal-time () 'integer) 29 30 (defun textp (a max &optional (min 1)) 31 (and (stringp a) (<= min (length a) max))) 32 33 ;; (textp "h" 3) 34 ;; (textp "h" 3 2) 35 ;; (textp "hi" 3) 36 ;; (textp "hi" 3 2) 37 ;; (textp "hello" 3) 38 ;; (textp "hello" 3 2) 39 40 (deftype text (max &optional (min 1)) 41 (assert (plusp min)) 42 (assert (< min max)) 43 (let ((p (gensym))) 44 (setf (symbol-function p) #'(lambda (a) (textp a max min))) 45 `(and string (satisfies ,p)))) 46 47 ;; (typep "h" '(text 3)) 48 ;; (typep "h" '(text 3 2)) 49 ;; (typep "hi" '(text 3)) 50 ;; (typep "hi" '(text 3 2)) 51 ;; (typep "hello" '(text 3)) 52 ;; (typep "hello" '(text 3 2)) 53 54 (defstruct (pdate (:constructor make-pdate (y m d))) y m d) 55 (defstruct (ptime (:constructor make-ptime (hh mm ss ms))) hh mm ss ms) 56 (defstruct (ptimestamp-tz 57 (:constructor make-ptimestamp-tz (date time timezone))) 58 date time timezone) 59 ;;(defstruct pinterval y m d hh mm ss ms) 60 61 (defun persistent-type-p (type) 62 (get type 'persistent-type)) 63 64 (deftype persistent-type () '(satisfies persistent-type-p)) 65 66 (defun oid (x) (funcall x 'oid)) 67 68 ;;(defstruct (proxy (:constructor make-proxy (oid object))) oid object) 69 70 (defun nullablep (type) 71 (unless (eql 'boolean type) 72 (typep nil type))) 73 74 (defun persistent-type-pkey (type1 &optional specs) 75 (unless specs 76 (setq specs (get type1 'deftable-specs))) 77 (when type1 78 (destructuring-bind (a) (cdr (assoc :pkey specs)) 79 a))) 80 81 (defun persistent-type-pkey-type (type1) 82 (destructuring-bind (&key type &allow-other-keys) 83 (cdr (assoc (persistent-type-pkey type1) (get type1 'deftable-slots))) 84 type)) 85 86 (defun ptype-specifier (type) 87 (let ((y (get type 'ptype-specifier))) 88 (assert y) 89 (assert (not (eq y type))) 90 (assert (not (get type 'ptype-args))) 91 y)) 92 93 (defun expand-ptype-to-db (type) 94 (assert type) 95 (if (atom type) 96 (case type 97 (boolean '(q:boolean-type)) 98 (integer '(q:integer-type)) 99 (string '(q:varchar-type)) 100 (pdate '(q:date-type)) 101 (ptime '(q:time-type)) 102 (ptimestamp-tz '(q:timestamp-with-timezone-type)) 103 (universal-time '(q:timestamp-with-timezone-type)) 104 (octet-vector '(q:blob-type)) 105 (t (if (subtypep type 'persistent-type) 106 (expand-ptype-to-db (persistent-type-pkey-type type)) 107 (or (get type 'db-type) 108 (expand-ptype-to-db (ptype-specifier type)))))) 109 (ecase (car type) 110 (or 111 (destructuring-bind (a b) (cdr type) 112 (assert (eq 'null a)) 113 (expand-ptype-to-db b))) 114 (integer `(q:integer-type ,(cadr type))) 115 (string `(q:char-type ,(cadr type))) 116 (text `(q:varchar-type ,(cadr type)))))) 117 118 ;;(expand-ptype-to-db 'integer) 119 ;;(expand-ptype-to-db 'string) 120 ;;(expand-ptype-to-db '(integer 16)) 121 ;;(expand-ptype-to-db '(string 3)) 122 ;;(expand-ptype-to-db '(text 3)) 123 ;;(expand-ptype-to-db '(text 3 2)) 124 ;;(expand-ptype-to-db 'oid) 125 ;;(expand-ptype-to-db 'natural) 126 127 (defun format-pdate (x) 128 (format nil "~4,'0d-~2,'0d-~2,'0d" (pdate-y x) (pdate-m x) (pdate-d x))) 129 130 (defun format-ptime (x) 131 (format nil "~2,'0d:~2,'0d:~2,'0d" (ptime-hh x) (ptime-mm x) (ptime-mm x))) 132 133 (defun format-ptimestamp-tz (x) 134 (error "TODO to-db ptmestamp-tz")) 135 136 (defun format-universal-time (x) 137 (multiple-value-bind (ss mm hh d m y dw st tz) 138 (decode-universal-time x) 139 (declare (ignore dw st)) 140 (format nil "~4,'0d-~2,'0d-~2,'0dT~2,'0d:~2,'0d:~2,'0d~a~2,'0d" 141 y m d hh mm ss (if (plusp tz) "+" "-") (abs tz)))) 142 143 (defun parse-pdate (x) 144 (assert (= 10 (length x))) 145 (assert (char= #\- (char x 4))) 146 (assert (char= #\- (char x 7))) 147 (make-pdate (parse-integer (subseq x 0 4)) 148 (parse-integer (subseq x 5 7)) 149 (parse-integer (subseq x 8 10)))) 150 151 (defun parse-ptime (x) 152 (assert (= 8 (length x))) 153 (assert (char= #\: (char x 2))) 154 (assert (char= #\: (char x 5))) 155 (make-ptime (parse-integer (subseq x 0 2)) 156 (parse-integer (subseq x 3 5)) 157 (parse-integer (subseq x 6)) 158 0)) 159 160 (defun parse-ptimestamp-tz (x) 161 (error "TODO parse-ptimestamp-tz")) 162 163 (defun parse-universal-time (x) 164 (assert (= 22 (length x))) 165 (assert (char= #\- (char x 4))) 166 (assert (char= #\- (char x 7))) 167 (assert (char= #\T (char x 10))) 168 (assert (char= #\: (char x 13))) 169 (assert (char= #\: (char x 16))) 170 (encode-universal-time (parse-integer (subseq x 17 19)) 171 (parse-integer (subseq x 14 16)) 172 (parse-integer (subseq x 11 13)) 173 (parse-integer (subseq x 8 10)) 174 (parse-integer (subseq x 5 7)) 175 (parse-integer (subseq x 0 4)) 176 (parse-integer (subseq x 19)))) 177 178 ;;(print (parse-universal-time (print (format-universal-time (print (get-universal-time)))))) ;; TODO fix tz stuff! 179 180 (defun to-db (x type) 181 (if (atom type) 182 (case type 183 (boolean (macroexpand (if x '(q:true-value) '(q:false-value)))) 184 (integer x) 185 (string x) 186 (pdate (format-pdate x)) 187 (ptime (format-ptime x)) 188 (ptimestamp-tz (format-ptimestamp-tz x)) 189 (universal-time (format-universal-time x)) 190 (octet-vector x) 191 ((t) (prin1-to-string x)) 192 (t (if (subtypep type 'persistent-type) 193 (let ((oid (oid x))) 194 (if (atom oid) 195 oid 196 (destructuring-bind (type2 &rest pkey) oid 197 (assert (eq type type2)) 198 (assert (not (cdr pkey))) ;; TODO multislot pkey 199 (car pkey)))) 200 (to-db x (ptype-specifier type))))) 201 (ecase (car type) 202 (or 203 (destructuring-bind (a b) (cdr type) 204 (assert (eq 'null a)) 205 (if x (to-db x b) :null))) 206 (and 207 (destructuring-bind (a b) (cdr type) 208 (assert a) 209 (assert (eq 'satisfies (car b))) 210 (assert (funcall (cadr b) x)) 211 (to-db x a))) 212 #+nil(integer `(q:integer-type ,(cadr type))) 213 (string 214 (destructuring-bind (a) (cdr type) 215 (assert (= a (length x))) 216 (to-db x 'string))) 217 (text 218 (assert (apply 'textp (cons x (cdr type)))) 219 (to-db x 'string))))) 220 221 (defun from-db (x type) 222 (if (atom type) 223 (case type 224 (boolean (cond 225 ((eql x (macroexpand '(q:true-value))) t) 226 ((eql x (macroexpand '(q:false-value))) nil) 227 (t (error "Unknown boolean value ~s of type ~s" x type)))) 228 (integer x) 229 (string x) 230 (pdate (parse-pdate x)) 231 (ptime (parse-ptime x)) 232 (ptimestamp-tz (parse-ptimestamp-tz x)) 233 (universal-time (parse-universal-time x)) 234 (octet-vector x) 235 (oid x) 236 ((t) (read-from-string x)) 237 (t (if (subtypep type 'persistent-type) 238 (error "TODO from-db persistent-type ~s ~s" x type) 239 #+nil 240 (let ((oid (oid x))) 241 (if (atom oid) 242 oid 243 (destructuring-bind (type2 &rest pkey) oid 244 (assert (eq type type2)) 245 (assert (not (cdr pkey))) ;; TODO multislot pkey 246 (car pkey)))) 247 (from-db x (ptype-specifier type))) 248 ;;(error "TODO from-db") 249 #+nil 250 (if (subtypep type 'persistent-type) 251 (make-proxy x nil) 252 (error "TODO from-db")))) 253 (ecase (car type) 254 (or 255 (destructuring-bind (a b) (cdr type) 256 (assert (eq 'null a)) 257 (unless (eq :null x) (from-db x b)))) 258 (and 259 (destructuring-bind (a b) (cdr type) 260 (assert a) 261 (assert (eq 'satisfies (car b))) 262 (assert (funcall (cadr b) x)) 263 (from-db x a))) 264 #+nil(integer `(q:integer-type ,(cadr type))) 265 (string 266 (destructuring-bind (a) (cdr type) 267 (assert (= a (length x))) 268 (from-db x 'string))) 269 (text 270 (assert (apply 'textp (cons x (cdr type)))) 271 (from-db x 'string))))) 272 273 (defun to-internal (x type) 274 (if (atom type) 275 (case type 276 (boolean x) 277 (integer x) 278 (string x) 279 (pdate x) 280 (ptime x) 281 (ptimestamp-tz x) 282 (universal-time x) 283 (octet-vector x) 284 ((t) x) 285 (t (if (subtypep type 'persistent-type) 286 x ;;(error "TODO to-internal") ;;(make-proxy (oid x) x) 287 (to-internal x (ptype-specifier type))))) 288 (ecase (car type) 289 (or 290 (destructuring-bind (a b) (cdr type) 291 (assert (eq 'null a)) 292 (when x (to-internal x b)))) 293 (and 294 (destructuring-bind (a b) (cdr type) 295 (assert a) 296 (assert (eq 'satisfies (car b))) 297 (assert (funcall (cadr b) x)) 298 (to-internal x a))) 299 #+nil(integer `(q:integer-type ,(cadr type))) 300 (string 301 (destructuring-bind (a) (cdr type) 302 (assert (= a (length x))) 303 (to-internal x 'string))) 304 (text 305 (assert (apply 'textp (cons x (cdr type)))) 306 (to-internal x 'string))))) 307 308 (defun from-internal (x type) 309 (if (atom type) 310 (case type 311 (boolean x) 312 (integer x) 313 (string x) 314 (pdate x) 315 (ptime x) 316 (ptimestamp-tz x) 317 (universal-time x) 318 (octet-vector x) 319 (oid x) 320 ((t) x) 321 (t (if (subtypep type 'persistent-type) 322 (load-object type x) 323 (from-internal x (ptype-specifier type))))) 324 (ecase (car type) 325 (or 326 (assert (eq 'null (cadr type))) 327 (assert (not (cddddr type))) 328 (unless (eq :null x) 329 (from-internal x (caddr type)))) 330 (and 331 (destructuring-bind (a b) (cdr type) 332 (assert a) 333 (assert (eq 'satisfies (car b))) 334 (assert (funcall (cadr b) x)) 335 (from-internal x a))) 336 #+nil(integer `(q:integer-type ,(cadr type))) 337 (string 338 (destructuring-bind (a) (cdr type) 339 (assert (= a (length x))) 340 (from-internal x 'string))) 341 (text 342 (assert (apply 'textp (cons x (cdr type)))) 343 (from-internal x 'string))))) 344 345 (defmacro defptype (name args specifier &optional #+nil internal db-type db-check) 346 (assert name) 347 `(progn 348 ,@(when specifier `((deftype ,name ,args ,specifier))) 349 (eval-when (:compile-toplevel :load-toplevel :execute) 350 (setf (get ',name 'ptype-args) ,args 351 (get ',name 'ptype-specifier) ,specifier 352 ;;(get ',name 'internal-type) ,internal 353 (get ',name 'db-type) ,db-type 354 (get ',name 'db-check) ,db-check)))) 355 356 (deftype octet () '(unsigned-byte 8)) 357 (deftype octet-vector (&optional size) `(simple-array octet (,size))) 358 359 (defun natural0p (a) 360 (and (integerp a) (<= 0 a))) 361 362 (defptype natural0 () '(and integer (satisfies natural0p)) '(q:integer-type) 'q:le0) 363 (defptype natural () '(and integer (satisfies plusp)) '(q:integer-type) 'q:plusp) 364 (defptype oid () 'natural) 365 (defptype t () () '(q:varchar-type)) 366 367 (defvar *object-cache*) 368 369 (defmacro with-object-cache (() &body body) 370 `(let ((*object-cache* (make-hash-table :test #'equal))) 371 ,@body)) 372 373 (defun check-cached-object (x) 374 (assert (eq x (gethash (oid x) *object-cache*)))) 375 376 (defun cache-object (x) 377 (assert (not (gethash (oid x) *object-cache*))) 378 (setf (gethash (oid x) *object-cache*) x)) 379 380 (defun insert-into (tab args vals returning-cols) 381 (2sql:apply-query args 382 vals 383 `(q:insert-into ,tab ,args 384 (q:values ,@(mapcar (lambda (x) `(q:qvar ,x)) args)) 385 (q:returning ,returning-cols)))) 386 387 (defun %pslot-accessor (k) 388 (values (intern (format nil "$~a" k) (symbol-package k)))) 389 390 (defun pslot-accessor (table slot) 391 (%pslot-accessor 392 (or (getf (cdr (assoc slot (list-pslots table))) :accessor) 393 (pslot-name (assoc slot (list-pslots table)))))) 394 395 ;;(pslot-accessor 'ex::document 'ex::nr) 396 397 (defun build-deftable-args (slots) 398 (loop 399 for x in slots 400 collect (destructuring-bind (k &key initform &allow-other-keys) x 401 (if initform 402 `(,k ,initform) 403 `(,k '%unbound-slot))))) 404 405 (defun build-deftable-insert (name slots) 406 (let ((unbound (gensym)) 407 (args (gensym)) 408 (vals (gensym)) 409 (ret (gensym)) 410 (ret1 (gensym))) 411 `(let (,unbound ,args ,vals) 412 ,@(loop 413 for x in slots 414 collect (destructuring-bind (k &key type &allow-other-keys) x 415 `(cond 416 ((eq '%unbound-slot ,k) (push ',k ,unbound)) 417 (t (push ',k ,args) 418 (push (to-db ,k ',type) ,vals))))) 419 (let ((,ret (insert-into ',name ,args ,vals (nreverse ,unbound)))) 420 (assert (not (cdr ,ret))) 421 (let ((,ret1 (car ,ret))) 422 ,@(loop 423 for x in slots 424 collect (destructuring-bind (k &key type &allow-other-keys) x 425 `(when (eq '%unbound-slot ,k) 426 (setq ,k (from-db (pop ,ret1) ',type)))))))))) 427 428 (defun build-deftable-messages (name slots specs) 429 (nconc 430 (unless (member 'oid slots :key #'car) 431 `((oid 432 (assert (not p)) 433 (list ',name ,@(cdr (assoc :pkey specs)))))) 434 (loop 435 for x in slots 436 collect (destructuring-bind (k &key type &allow-other-keys) x 437 `(,k ,(if (eq 'oid k) 438 `(progn 439 (assert (not p)) 440 (from-internal (bound ,k ',k) ',type)) 441 `(if p 442 (setq ,k (to-internal v ',type)) 443 (from-internal (bound ,k ',k) ',type)))))))) 444 445 (defun build-deftable-accessors (slots) 446 (loop 447 for x in slots 448 appending (destructuring-bind (k &key accessor &allow-other-keys) x 449 (unless accessor 450 (setq accessor (%pslot-accessor k))) 451 (unless (eq 'oid k) 452 `((defun ,accessor (x) (funcall x ',k)) 453 (defun (setf ,accessor) (v x) (funcall x ',k v))))))) 454 455 (defun persistent-type1 (type) 456 (when (subtypep type 'persistent-type) 457 (if (atom type) 458 type 459 (ecase (car type) 460 (or (destructuring-bind (a b) (cdr type) 461 (assert (eq 'null a)) 462 b)))))) 463 464 (defun build-deftable-create-table (name slots specs) 465 `(,@(loop 466 for x in specs 467 when (eq :sequence (car x)) 468 appending (destructuring-bind (seq &optional slot) (cdr x) 469 `((q:create-sequence ,seq) 470 ,@ (when slot 471 #+nil ;; TODO alter sequence password_seq_ owned by password.nr 472 (q:alter-sequence seq :owned :by name.slot))))) 473 (q:create-table 474 ,name 475 (q:columns 476 ,@(loop 477 for x in slots 478 collect (destructuring-bind 479 (k &key type db-initform &allow-other-keys) x 480 `(q:column ,k 481 ,(expand-ptype-to-db type) 482 ,(nullablep type) 483 ,db-initform))))) 484 ,@ (let ((pkey (cdr (assoc :pkey specs)))) 485 (when pkey 486 `((q:alter-table ,name 487 (q:add-primary-key-constraint 488 ,(intern (format nil "~a-PK" name) (symbol-package name)) 489 ,@pkey))))) 490 ,@(loop 491 for x in slots 492 appending (destructuring-bind 493 (k &key type on-delete on-update &allow-other-keys) 494 x 495 (let ((pkey (persistent-type-pkey 496 (persistent-type1 type)))) 497 (when pkey 498 `((q:alter-table ,name 499 (q:add-foreign-key-constraint 500 ,(intern (format nil "~a-~a-FK" name k) 501 (symbol-package name)) 502 (,k) 503 (,pkey) 504 ,type 505 ,on-delete 506 ,on-update))))))) 507 ,@ (loop 508 for x in specs 509 when (eq :unique (car x)) 510 collect (destructuring-bind (uname &rest cols) (cdr x) 511 `(q:alter-table 512 ,name (q:add-unique-constraint ,uname ,@cols)))))) 513 514 (defun build-deftable-load (name slots specs) 515 (let* ((pkey (cdr (assoc :pkey specs))) 516 (npkey (loop 517 for x in slots 518 for k = (car x) 519 unless (member k pkey) 520 collect k)) 521 (package (symbol-package name)) 522 (load-name (intern (format nil "LOAD-~a" name) (symbol-package name))) 523 (%class-name (intern (format nil "MAKE-~a" name) package))) 524 `(defun ,load-name ,pkey 525 (or (gethash ,(if (find 'oid slots :key #'car) ;; or (car pkey) ? 526 'oid 527 `(cons ',name (list ,@pkey))) 528 *object-cache*) 529 (let ((z (2sql:query ,pkey 530 '(q:select (q:clist ,@npkey) 531 (q:from ,name) 532 (q:where 533 (q:and ,@(loop 534 for x in pkey 535 collect `(q:= ,x (q:qvar ,x))))))))) 536 (assert z) 537 (assert (not (cdr z))) 538 (let ((zz (car z))) 539 (let (,@(loop 540 for x in npkey 541 collect `(,x (pop zz)))) 542 (cache-object 543 (,%class-name 544 ,@(loop 545 for x in slots 546 for k = (car x) 547 appending `(,(intern (symbol-name k) :keyword) ,k))))))))))) 548 549 (defun build-deftable-list (name slots) 550 (let* ((package (symbol-package name)) 551 (where 552 (loop 553 for s in slots 554 as n = (pslot-name s) 555 as type = (pslot-type s) 556 collect `(unless (eq '%unbound-slot ,n) 557 (if (atom ,n) 558 `(q:= ,',n ,(to-internal (to-db ,n ',type) ',type)) 559 `(q:in ,',n 560 (q:par 561 (q:clist 562 ,@(loop 563 for x in ,n 564 collect (to-internal (to-db x ',type) 565 ',type)))))))))) 566 `(defun ,(intern (format nil "LIST-~a" name) package) 567 (project order limit offset 568 &key ,@(mapcar (lambda (x) `(,(pslot-name x) '%unbound-slot)) slots)) 569 (2sql-ormc:query () 570 `(q:select (,@(or project `((2sql-ormc::instance ,',name)))) 571 (q:from ,',name) 572 (q:where (q:and ,@(loop 573 for x in (list ,@where) 574 when x 575 collect x))) 576 ,@(when order `((q:order-by ,@order))) 577 ,@(when limit `((q:limit ,limit))) 578 ,@(when offset `((q:offset ,offset)))))))) 579 580 (defun build-deftable (name body) 581 (let ((package (symbol-package name))) 582 (let ((class-name (intern (format nil "CREATE-~a" name) package)) 583 (%class-name (intern (format nil "MAKE-~a" name) package)) 584 (slots (car body)) 585 (specs (cdr body))) 586 `(progn 587 (defun ,%class-name (&key ,@(build-deftable-args slots)) 588 (lambda (msg &optional (v nil p)) 589 (flet ((bound (v slot) 590 (if (eq '%unbound-slot v) 591 (error "unbound slot ~s in ~s" slot ',class-name) 592 v))) 593 (ecase msg 594 ,@(build-deftable-messages name slots specs))))) 595 (defun ,class-name (&key ,@(build-deftable-args slots)) 596 ,@(loop 597 for x in slots 598 collect (destructuring-bind (k &key type &allow-other-keys) x 599 `(unless (eq '%unbound-slot ,k) 600 (setq ,k (to-internal ,k ',type))))) 601 ,(build-deftable-insert name slots) 602 (cache-object 603 (,%class-name 604 ,@(loop 605 for x in slots 606 for k = (car x) 607 appending `(,(intern (symbol-name k) :keyword) ,k))))) 608 ,@(build-deftable-accessors slots) 609 ,(build-deftable-load name slots specs) 610 ,(build-deftable-list name slots) 611 (eval-when (:compile-toplevel :load-toplevel :execute) 612 (deftype ,name () '(satisfies persistent-type-p)) 613 (setf (get ',name 'create-table) 614 ',(build-deftable-create-table name slots specs) 615 (get ',name 'make-object) 616 ',%class-name 617 #+nil(get ',name 'persistent-type) 618 #+nil t)))))) 619 620 (defmacro deftable (name () &body body) 621 `(progn 622 ,(build-deftable name body) 623 (eval-when (:compile-toplevel :load-toplevel :execute) 624 (setf (get ',name 'deftable-slots) ',(car body) 625 (get ',name 'deftable-specs) ',(cdr body))))) 626 627 #+nil 628 (2sql:query (oid value) 629 `(q:update ,tab 630 ((,pslot-name (q:qvar value))) 631 (q:where (q:= oid (q:qvar oid))))) 632 633 #+nil 634 (defconstant +table-id-bit-size+ 16) 635 636 ;; #+nil 637 ;; (defmacro oid-exp (table-id) 638 ;; (let ((bit-size +table-id-bit-size+)) 639 ;; `(q:backend-ecase 640 ;; (:oracle (q:+ (q:* (q:nextval oid-seq) (q:power 2 ,bit-size)) ,table-id)) 641 ;; (:postgresql ;; TODO oid_seq_ via symbol printing 642 ;; (q:\| (q:<< (q:nextval "oid_seq_") ,bit-size) ,table-id)) 643 ;; (:sqlite (q:\| (q:<< (q:nextval oid-seq) ,bit-size) ,table-id))))) 644 645 #+nil 646 (defun setup-pclass (class-name) 647 (2sql:query () 648 `(q:create-table 649 ,class-name 650 (q:columns 651 (q:column oid (q:integer-type) nil 652 (oid-exp (q:qchunk (class-name-to-class-id ',class-name)))) 653 ,@(loop 654 for x in (list-pslots class-name) 655 unless (eq 'oid (pslot-name x)) 656 collect `(q:column ,(pslot-name x) 657 ,(pslot-ptype x) 658 ,(pslot-nullable x) 659 ,(pslot-initform x))))))) 660 661 #+nil 662 (defun assert-type (value type) 663 (unless (typep value type) 664 (cond ;; TODO more cases 665 ((typep value 'string) 666 (setq value (coerce value 'simple-string))) 667 ((typep value 'simple-date:timestamp) 668 (setq value (multiple-value-bind (y m d hh mm ss ms) 669 (simple-date:decode-timestamp value) 670 (make-ptimestamp-tz (make-pdate y m d) 671 (make-ptime hh mm ss ms) 672 nil)))) 673 ((subtypep type 'persistent-object) 674 (setq value (or (gethash value *instance-cache*) 675 (make-proxy value)))))) 676 (assert (or (typep value type) 677 (when (subtypep type 'persistent-object) 678 (proxy-p value)))) 679 value) 680 681 #+nil 682 (defun delete-object (x) 683 (let ((oid (oid x))) 684 (remhash oid *object-cache*) 685 (2sql:query (oid) 686 `(q:delete-from ,(type-of a) 687 (q:where (q:= oid (q:qvar oid))))))) 688 689 (defparameter *instance-collector-cache* nil) ;; equal form->fn 690 691 (defmacro with-pinstance-collector-cache (args &body body) 692 (declare (ignore args)) 693 `(let ((*instance-collector-cache* (make-hash-table :test #'equal))) 694 ,@body)) 695 696 (defparameter *instance-collectors* nil) ;; list fn 697 698 (defun %query (form rows) 699 (multiple-value-bind (value present) 700 (gethash form *instance-collector-cache*) 701 (cond 702 (present 703 (assert (not *instance-collectors*)) 704 (setq *instance-collectors* value)) 705 (t 706 (setq *instance-collectors* (nreverse *instance-collectors*)) 707 (setf (gethash form *instance-collector-cache*) *instance-collectors*)))) 708 (loop 709 for row in rows 710 for tail = row 711 collect (nconc (loop 712 for fn in *instance-collectors* 713 collect (multiple-value-bind (instance tail2) 714 (funcall fn tail) 715 (setq tail tail2) 716 instance)) 717 tail))) 718 719 (defmacro query (args form) 720 `(let ((*instance-collectors* nil) ;; TODO that's not right is it? need to remember form->collector! for subsequent queries 721 #+nil(*alias-to-table* (make-hash-table))) 722 ;;(maphash (lambda (k v) (print (list :@@@ k v))) *alias-to-table*) 723 (%query ,form (2sql:query ,args ,form)))) 724 725 #+nil 726 (defmacro query (args form) 727 `(let* (#+nil(*alias-to-table* (make-hash-table)) 728 (*instance-collectors* nil) ;; TODO that's not right is it? need to remember form->collector! for subsequent queries 729 (rows (2sql:query ,args ,form))) 730 ;;(maphash (lambda (k v) (print (list :@@@ k v))) *alias-to-table*) 731 (multiple-value-bind (value present) 732 (gethash ,form *instance-collector-cache*) 733 (cond 734 (present 735 (assert (not *instance-collectors*)) 736 (setq *instance-collectors* value)) 737 (t 738 (setq *instance-collectors* (nreverse *instance-collectors*)) 739 (setf (gethash ,form *instance-collector-cache*) *instance-collectors*)))) 740 (loop 741 for row in rows 742 for tail = row 743 collect (nconc (loop 744 for fn in *instance-collectors* 745 collect (multiple-value-bind (instance tail2) 746 (funcall fn tail) 747 (setq tail tail2) 748 instance)) 749 tail)))) 750 751 (defun list-pslots (table) 752 (get table 'deftable-slots)) 753 754 (defun pslot-name (pslot) 755 (car pslot)) 756 757 (defun pslot-type (pslot) 758 (getf (cdr pslot) :type)) 759 760 ;;(list-pslots 'ex::document) 761 ;;(pslot-name (car (list-pslots 'ex::document))) 762 ;;(pslot-type (cadr (list-pslots 'ex::document))) 763 764 (defun pslot-initarg (pslot) 765 (or (getf (cdr pslot) :initarg) 766 (values (intern (symbol-name (pslot-name pslot)) :keyword)) 767 #+nil(pslot-name pslot))) ;; TODO this is better + explicit keyword 768 769 (defun make-object (table &rest args) 770 (apply (get table 'make-object) args)) 771 772 ;;(get 'ex::document 'make-object) 773 774 (defmacro instance (tab &optional alias) ;; use inside 2sql queries 775 (let ((pslots (list-pslots tab))) 776 (push (lambda (row) 777 (values (let ((oid (car row)) 778 (args (loop 779 for x in pslots 780 appending (list (pslot-initarg x) 781 (pop row) 782 ;;(from-db (pop row) (pslot-type x)) 783 #+nil(assert-type (pop row) (pslot-type x)))))) ;; TODO resolve pclassp foreign ref (lazy foreign reference?) 784 ;;(print (list :@@@ (mapcar (lambda (x) (cons x (type-of x))) args))) 785 (or (gethash oid *object-cache*) 786 (cache-object (apply 'make-object tab args))) 787 #+nil 788 (unless (eq :null oid) 789 ;; TODO uniq oid->instance cache 790 (apply #'make-instance tab :oid oid args))) ;; TODO fix values from rdbms backend to lisp, e.g. :null :true :false pclasp 791 row)) 792 *instance-collectors*) 793 `(q:clist 794 ,@ (flet ((sym (name) 795 (if alias 796 (intern (format nil "~a.~a" alias name)) ;; TODO avoid intern 797 name))) 798 (mapcar (lambda (x) (sym (pslot-name x))) pslots))))) 799 800 (defmacro with-pobject ((name &rest slots) object &body body) 801 (let ((_object (gensym))) 802 `(let ((,_object ,object)) 803 (symbol-macrolet 804 ,(mapcar (lambda (s) `(,s (,(pslot-accessor name s) ,_object))) slots) 805 ,@body)))) 806 807 (defun load-object (table oid) 808 (or (gethash oid *object-cache*) 809 (let ((x (query (oid) 810 `(q:select ((instance ,table)) 811 (q:from ,table) 812 (q:where (q:= oid (q:qvar oid))))))) 813 (assert (not (cdr x))) 814 (assert (car x)) 815 (assert (not (cadr x))) 816 (assert (functionp (caar x))) 817 (caar x)))) 818 819 ;; #+nil 820 ;; (defmacro with-pclasses (names &body body) 821 ;; (labels ((rec (x) 822 ;; (if x 823 ;; `(progn 824 ;; (c2mop:ensure-finalized (find-class ',(car x))) 825 ;; (2sql-orm:setup-pclass ',(car x)) 826 ;; (unwind-protect ,(rec (cdr x)) 827 ;; (2sql:query () '(q:drop-table ,(car x) t t)))) 828 ;; `(progn ,@body)))) 829 ;; (rec names))) 830 831 ;; #+nil 832 ;; (defmacro with-psequences (names &body body) 833 ;; (labels ((rec (x) 834 ;; (if x 835 ;; `(progn 836 ;; (2sql:query () '(q:create-sequence ,(car x))) 837 ;; (unwind-protect ,(rec (cdr x)) 838 ;; (2sql:query () '(q:drop-sequence ,(car x) t)))) 839 ;; `(progn ,@body)))) 840 ;; (rec names)))