X-Git-Url: http://git.kpe.io/?p=hyperobject.git;a=blobdiff_plain;f=sql.lisp;h=294effe8cc135438d94baa522560d133d52eaa91;hp=224652a8e51314716c5abf4f67a2e1d9a9993cfb;hb=HEAD;hpb=0817a8721cbefca2205dcde535ff6b164033abef diff --git a/sql.lisp b/sql.lisp index 224652a..294effe 100644 --- a/sql.lisp +++ b/sql.lisp @@ -18,44 +18,44 @@ (defun finalize-sql (cl) (setf (slot-value cl 'drop-table-cmd) (generate-drop-table-cmd - (slot-value cl 'sql-name))) + (slot-value cl 'sql-name))) (let ((esds (class-slots cl))) (setf (slot-value cl 'create-table-cmd) - (generate-create-table-cmd - cl + (generate-create-table-cmd + cl (remove-if #'(lambda (esd) (null (esd-stored esd))) esds))) (setf (slot-value cl 'create-indices-cmds) (generate-create-indices-cmds (sql-name cl) esds)) (dolist (esd esds) (when (slot-value esd 'inverse) - (define-inverse cl esd)))) + (define-inverse cl esd)))) ) - + (defun define-inverse (class esd) "Define an inverse function for a slot" (let ((inverse (slot-value esd 'inverse))) (when inverse (eval `(defun ,inverse (obj) - (format t "~&Finding key: ~S for class ~S ~%" obj ,class) - ;; create inverse function - )) + (format t "~&Finding key: ~S for class ~S ~%" obj ,class) + ;; create inverse function + )) )) ) (defun generate-create-table-cmd (cl esds) (with-output-to-string (s) - (format s "CREATE TABLE ~A (~{~A~^, ~})" - (slot-value cl 'sql-name) - (loop for esd in esds - collect - (concatenate - 'string - (slot-value esd 'sql-name) - " " - (sql-type-to-field-string (slot-value esd 'sql-type) - (slot-value esd 'sql-length))))))) + (format s "CREATE TABLE ~A (~{~A~^, ~})" + (slot-value cl 'sql-name) + (loop for esd in esds + collect + (concatenate + 'string + (slot-value esd 'sql-name) + " " + (sql-type-to-field-string (slot-value esd 'sql-type) + (slot-value esd 'sql-length))))))) (defun sql-type-to-field-string (type length) (ecase type @@ -99,18 +99,18 @@ (let (indices) (dolist (slot slots) (when (slot-value slot 'indexed) - (let ((sql-name (slot-value slot 'sql-name))) - (push (sql-cmd-index table-name sql-name (slot-value slot 'unique)) - indices)))) + (let ((sql-name (slot-value slot 'sql-name))) + (push (sql-cmd-index table-name sql-name (slot-value slot 'unique)) + indices)))) indices)) (defun sql-cmd-index (table field unique) (let ((*print-circle* nil)) (format nil "CREATE ~AINDEX ~A ON ~A(~A)" - (if unique "UNIQUE " "") - (sql-index-name table field) - table - field))) + (if unique "UNIQUE " "") + (sql-index-name table field) + table + field))) (defun sql-index-name (table field) (format nil "~A_~A" table field)) @@ -134,46 +134,46 @@ (defmethod sql-insert (obj) (mutex-sql-execute (format nil "INSERT INTO ~a (~a) VALUES (~a)" - (sql-name self) (sql-cmd-field-names self) (format-values self)))) + (sql-name self) (sql-cmd-field-names self) (format-values self)))) (defmethod sql-select (obj lisp-name key) - (let ((tuple - (car - (mutex-sql-query - (format nil "SELECT ~a FROM ~a WHERE ~a=~a" - (sql-cmd-field-names self) (sql-name self) - (inverse-field-name self) key))))) + (let ((tuple + (car + (mutex-sql-query + (format nil "SELECT ~a FROM ~a WHERE ~a=~a" + (sql-cmd-field-names self) (sql-name self) + (inverse-field-name self) key))))) (when tuple (format t "process returned fields")))) (defun format-values (self) (let ((values "") - (fields (fields self))) + (fields (fields self))) (dolist (field fields) (unless (eq field (car fields)) - (string-append values ",")) + (string-append values ",")) (let ((name (car field))) - (with-key-value-list (key value (rest field)) - (when (eq key :type) - (string-append values - (ecase value - ((:fixnum :bigint :short-float :double-float) - (write-to-string - (slot-value self name))) - ((:string :text) - (format nil "'~a'" - (add-sql-quotes - (slot-value self name)))))))))) + (with-key-value-list (key value (rest field)) + (when (eq key :type) + (string-append values + (ecase value + ((:fixnum :bigint :short-float :double-float) + (write-to-string + (slot-value self name))) + ((:string :text) + (format nil "'~a'" + (add-sql-quotes + (slot-value self name)))))))))) values)) (defun inverse-field-string (fields) (let (inverse) (dolist (field fields) (let ((name-string (write-to-string (car field)))) - (with-key-value-list (key value (rest field)) - (when (eq key :inverse) - (setq inverse value))))) + (with-key-value-list (key value (rest field)) + (when (eq key :inverse) + (setq inverse value))))) (when inverse (write-to-string inverse)))) @@ -181,42 +181,42 @@ (let ((names "")) (dolist (field fields) (unless (eq field (car fields)) - (string-append names ",")) + (string-append names ",")) (string-append names (lisp-name-to-sql-name (car field)))) names)) - + (defun parse-fields (table-name fields) (let (class-fields) (dolist (field fields) (let* ((fname (car field)) - (name-string (write-to-string fname)) - (initarg (intern name-string :keyword))concat-symbol - (def (list fname)) - (options (rest field))) - (with-key-value-list (key value options) - (case key - (:type - (setq def (nconc def (list :type - (ecase value - (:string - 'string) - (:fixnum - 'fixnum) - (:long-integer - 'integer) - (:short-float - 'short-float) - (:long - 'long-float) - (:text - 'string)))))))) - (setq def (nconc def (list - :initarg initarg - :accessor (concat-symbol - (write-to-string table-name) "-" - (write-to-string fname))))) - (push def class-fields))) + (name-string (write-to-string fname)) + (initarg (intern name-string :keyword))concat-symbol + (def (list fname)) + (options (rest field))) + (with-key-value-list (key value options) + (case key + (:type + (setq def (nconc def (list :type + (ecase value + (:string + 'string) + (:fixnum + 'fixnum) + (:long-integer + 'integer) + (:short-float + 'short-float) + (:long + 'long-float) + (:text + 'string)))))))) + (setq def (nconc def (list + :initarg initarg + :accessor (concat-symbol + (write-to-string table-name) "-" + (write-to-string fname))))) + (push def class-fields))) class-fields)) ||#