(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
(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))
(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))))
(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))
||#
projects / hyperobject.git / blobdiff