From 3a961428b36d0ffa96ad06609c8da75ae1c39a2a Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Fri, 6 Dec 2002 16:18:49 +0000 Subject: [PATCH] r3576: *** empty log message *** --- mop.lisp | 4 +- sqlgen.lisp | 248 ++++++++++++++++++++++------------------------------ 2 files changed, 105 insertions(+), 147 deletions(-) diff --git a/mop.lisp b/mop.lisp index f7f7ae0..45e704a 100644 --- a/mop.lisp +++ b/mop.lisp @@ -11,7 +11,7 @@ ;;;; in Text, HTML, and XML formats. This includes hyperlinking ;;;; capability and sub-objects. ;;;; -;;;; $Id: mop.lisp,v 1.6 2002/12/05 19:15:02 kevin Exp $ +;;;; $Id: mop.lisp,v 1.7 2002/12/06 16:18:49 kevin Exp $ ;;;; ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg ;;;; @@ -47,7 +47,7 @@ "Unique ID for the class") (create-table-cmd :initform nil :reader create-table-cmd) - (create-index-cmds :initform nil :reader create-index-cmds) + (create-indices-cmds :initform nil :reader create-index-cmds) (drop-table-cmd :initform nil :reader drop-table-cmd) (value-func :initform nil :type function) diff --git a/sqlgen.lisp b/sqlgen.lisp index e071c68..9ff023d 100644 --- a/sqlgen.lisp +++ b/sqlgen.lisp @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; -;;;; $Id: sqlgen.lisp,v 1.3 2002/12/05 18:15:23 kevin Exp $ +;;;; $Id: sqlgen.lisp,v 1.4 2002/12/06 16:18:49 kevin Exp $ ;;;; ;;;; This file, part of Hyperobject-SQL, is ;;;; Copyright (c) 2000-2002 by Kevin M. Rosenberg, M.D. @@ -21,77 +21,142 @@ ;;;; Metaclass initialization commands (defun finalize-sql (cl) - (declare (ignore cl)) - nil - ) - -#|| - -(defun finalize-sql (cl) + (setf (slot-value cl 'sql-name) (sql-name cl)) + (setf (slot-value cl 'drop-table-cmd) (generate-drop-table-cmd + (slot-value cl 'sql-name))) (let ((esds (class-slots cl))) - (let* ((table-name-slot (slot-value cl 'sql-name)) - (generate-table-cmd (generate-create-table-string - (if (consp table-name-slot) - (car table-name-slot) - table-name-slot) - esds))) - (setf (slot-value cl 'create-table-cmd) generate-table-cmd)) - + (dolist (esd esds) + (setf (slot-value cl 'sql-name) (sql-name esd))) + (setf (slot-value cl 'create-table-cmd) + (generate-create-table-cmd (slot-value cl 'sql-name) esds)) + (setf (slot-value cl 'create-indices-cmds) + (generate-create-indices-cmds (slot-value cl 'sql-name) esds)) (dolist (esd esds) (when (slot-value esd 'inverse) (define-inverse cl esd)))) ) +(defmethod sql-name ((cl hyperobject-class)) + "Return name of SQL table for a class" + (let-if (it (slot-value cl 'sql-name)) + (let* ((name (if (consp it) (car it) it)) + (lisp-name (if name name (class-name cl)))) + (lisp-name-to-sql-name lisp-name)))) + +(defmethod sql-name ((esd hyperobject-esd)) + (let-if (it (slot-value esd 'sql-name)) + (let* ((name (if (consp it) (car it) it)) + (lisp-name (if name name (slot-definition-name esd)))) + (lisp-name-to-sql-name lisp-name)))) + + +(defun lisp-name-to-sql-name (lisp) + "Convert a lisp name (atom or list, string or symbol) into a canonical +SQL name" + (unless (stringp lisp) + (setq lisp (write-to-string lisp))) + (let ((sql (make-string (length lisp)))) + (dotimes (i (length lisp)) + (declare (fixnum i)) + (let ((c (char lisp i))) + (case c + (#\- #\_) + (#\$ #\_) + (#\+ #\_) + (otherwise c)))) + (string-upcase sql))) + + (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~%" obj) - (make-instance 'st) + (format t "~&Finding key: ~S for class ~S ~%" obj ,class) + ;; create inverse function )) - - ;; create inverse function )) ) -(defun generate-create-table-string (table-name esds) - (let ((cmd (format nil "CREATE TABLE ~A (" - (slot-name-to-sql-name table-name)))) +(defun generate-create-table-cmd (table-name esds) + (let ((cmd (format nil "CREATE TABLE ~A (" table-name))) (dolist (esd esds) (unless (eq esd (car esds)) (string-append cmd ", ")) - (string-append cmd (slot-name-to-sql-name (slot-definition-name esd)) + (string-append cmd (lisp-name-to-sql-name (slot-definition-name esd)) " ") - (let ((length (esd-length esd)) - (sql-type (esd-sql-type esd))) + (let ((length (slot-value esd 'length)) + (sql-type (slot-value esd 'sql-type))) (string-append cmd (sql-field-cmd sql-type length)))) (string-append cmd ")"))) -;;;; Runtime Commands +(defun sql-field-cmd (type length) + (ecase type + (:string + (cond + ((null length) + "LONGTEXT") + ((< length 8) + (format nil "CHAR(~d)" length)) + (t + (format nil "VARCHAR(~d)" length)))) + (:text + "LONGTEXT") + (:fixnum + "INTEGER") + (:bigint + "BIGINT") + (:short-float + "SINGLE") + (:long-float + "DOUBLE"))) -(defclass sqltable () - () - ) +(defun generate-drop-table-cmd (table-name) + (format nil "DROP TABLE ~a" table-name)) -(defmethod sql-create ((self sqltable)) +(defun generate-create-indices-cmds (table-name slots) + (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)))) + indices)) + +(defun sql-cmd-index (table field unique) + (let ((*print-circle* nil)) + (format nil "CREATE ~A INDEX ~A ON ~A(~A)" + (if unique "UNIQUE" "") + table + (sql-index-name table field) + table + field))) + +(defun sql-index-name (table field) + (format nil "~A_~A" table field)) + +;;;; Runtime Commands + +(defmethod sql-create (cl) (with-sql-connection (conn) - (sql-execute (sql-cmd-create-table self) conn) - (dolist (cmd (sql-cmd-create-indices self)) + (sql-execute (slot-value cl 'create-table-cmd) conn) + (dolist (cmd (slot-value cl 'create-indices-cmds)) (sql-execute cmd conn)) (values))) -(defmethod sql-drop ((self sqltable)) - (mutex-sql-execute (sql-cmd-drop-table self)) +(defmethod sql-drop (cl) + (mutex-sql-execute (slot-value cl 'drop-table-cmd)) (values)) -(defmethod sql-insert ((self sqltable)) +#| +(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)))) -(defmethod sql-select ((self sqltable) key) +(defmethod sql-select (obj lisp-name key) (let ((tuple (car (mutex-sql-query @@ -122,47 +187,7 @@ (slot-value self name)))))))))) values)) -(defmacro defsqltable (tname &key fields) - `(progn - (defclass ,tname (sqltable) - ,(parse-fields tname fields) - ,(default-initargs fields)) - - (defmethod sql-name ((self ,tname)) - ,(substitute #\_ #\- (write-to-string tname))) - - (defmethod fields ((self ,tname)) - (quote ,fields)) - - (defmethod sql-cmd-create-table ((self ,tname)) - ,(create-table-string tname fields)) - - (defmethod sql-cmd-create-indices ((self ,tname)) - "Return a list of index cmds" - (quote ,(create-indices-string tname fields))) - - (defmethod sql-cmd-drop-table ((self ,tname)) - ,(format nil "DROP TABLE ~a" tname)) - - (defmethod sql-cmd-field-names ((self ,tname)) - ,(row-field-string fields)) - - (defmethod inverse-field-name ((self ,tname)) - ,(inverse-field-string fields)) - )) -(defun create-indices-string (table-name fields) - (let (indices) - (dolist (field fields) - (let ((name-string (write-to-string (car field)))) - (with-key-value-list (key value (rest field)) - (when (eq key :unique) - (case value - (nil - (push (sql-cmd-index table-name name-string nil) indices)) - (t - (push (sql-cmd-index table-name name-string t) indices))))))) - indices)) (defun inverse-field-string (fields) (let (inverse) @@ -174,72 +199,15 @@ (when inverse (write-to-string inverse)))) -(defun sql-cmd-index (table field unique) - (let ((*print-circle* nil)) - (format nil "CREATE ~A INDEX ~A_~A ON ~A(~A)" - (if unique "UNIQUE" "") - (slot-name-to-sql-name table) - (slot-name-to-sql-name field) - (slot-name-to-sql-name table) - (slot-name-to-sql-name field)))) - (defun row-field-string (fields) (let ((names "")) (dolist (field fields) (unless (eq field (car fields)) (string-append names ",")) - (string-append names (slot-name-to-sql-name (car field)))) + (string-append names (lisp-name-to-sql-name (car field)))) names)) - -(defun slot-name-to-sql-name (name) - (let ((str (string-upcase (etypecase name - (string - name) - (symbol - (write-to-string name)))))) - (substitute #\_ #\- str))) -(defun create-table-string (table-name fields) - (let ((cmd (format nil "CREATE TABLE ~A (" (slot-name-to-sql-name table-name)))) - (dolist (field fields) - (unless (eq field (car fields)) - (string-append cmd ", ")) - (string-append cmd (slot-name-to-sql-name (car field)) " ") - (let (length type) - (with-key-value-list (key value (rest field)) - (case key - (:length - (setq length value)) - (:type - (setq type value)))) - (string-append cmd (sql-field-cmd type length)))) - (string-append cmd ")"))) - - -(defun sql-field-cmd (type length) - (ecase type - (:string - (if (< length 8) - (format nil "CHAR(~d)" length) - (format nil "VARCHAR(~d)" length))) - (:text - "LONGTEXT") - (:fixnum - "INTEGER") - (:bigint - "BIGINT") - (:short-float - "SINGLE") - (:long-float - "DOUBLE"))) -(defmacro with-key-value-list ((key value list) form) - (let ((i (gensym))) - `(loop for ,i from 0 to (1- (length ,list)) by 2 do - (let ((,key (nth ,i ,list)) - (,value (nth (1+ ,i) ,list))) - ,form)))) - (defun parse-fields (table-name fields) (let (class-fields) (dolist (field fields) @@ -273,14 +241,4 @@ (push def class-fields))) class-fields)) -(defun default-initargs (fields) - (let ((initargs (list :default-initargs))) - (dolist (field fields) - (let* ((fname (car field)) - (name-string (write-to-string fname)) - (initarg (intern name-string :keyword))) - (setq initargs (nconc initargs (list initarg nil))))) - initargs)) - - ||# -- 2.34.1