sqlgen.lisp

   1 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: umlisp -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:          sqlgen.lisp
   6 ;;;; Purpose:       SQL Generation functions for Hyperobject
   7 ;;;; Programmer:    Kevin M. Rosenberg
   8 ;;;; Date Started:  Apr 2000
   9 ;;;;
  10 ;;;; $Id: sqlgen.lisp,v 1.3 2002/12/05 18:15:23 kevin Exp $
  11 ;;;;
  12 ;;;; This file, part of Hyperobject-SQL, is
  13 ;;;;    Copyright (c) 2000-2002 by Kevin M. Rosenberg, M.D.
  14 ;;;; *************************************************************************
  15
  16 (in-package :hyperobject)
  17 (eval-when (:compile-toplevel :execute)
  18   (declaim (optimize (speed 2) (safety 2) (compilation-speed 0) (debug 2))))
  19
  20
  21 ;;;; Metaclass initialization commands
  22
  23 (defun finalize-sql (cl)
  24   (declare (ignore cl))
  25   nil
  26   )
  27
  28 #||
  29
  30 (defun finalize-sql (cl)
  31   (let ((esds (class-slots cl)))
  32     (let* ((table-name-slot (slot-value cl 'sql-name))
  33            (generate-table-cmd (generate-create-table-string
  34                                 (if (consp table-name-slot)
  35                                     (car table-name-slot)
  36                                   table-name-slot)
  37                                 esds)))
  38       (setf (slot-value cl 'create-table-cmd) generate-table-cmd))
  39
  40     (dolist (esd esds)
  41       (when (slot-value esd 'inverse)
  42         (define-inverse cl esd))))
  43   )
  44
  45 (defun define-inverse (class esd)
  46   (let ((inverse (slot-value esd 'inverse)))
  47     (when inverse
  48       (eval
  49        `(defun ,inverse (obj)
  50           (format t "~&Finding key: ~s~%" obj)
  51           (make-instance 'st)
  52           ))
  53
  54       ;; create inverse function
  55       ))
  56   )
  57
  58 (defun generate-create-table-string (table-name esds)
  59   (let ((cmd (format nil "CREATE TABLE ~A ("
  60                      (slot-name-to-sql-name table-name))))
  61     (dolist (esd esds)
  62       (unless (eq esd (car esds))
  63         (string-append cmd ", "))
  64       (string-append cmd (slot-name-to-sql-name (slot-definition-name esd))
  65                              " ")
  66       (let ((length (esd-length esd))
  67             (sql-type (esd-sql-type esd)))
  68         (string-append cmd (sql-field-cmd sql-type length))))
  69     (string-append cmd ")")))
  70
  71
  72 ;;;; Runtime Commands
  73
  74 (defclass sqltable ()
  75   ()
  76   )
  77
  78 (defmethod sql-create ((self sqltable))
  79   (with-sql-connection (conn)
  80     (sql-execute (sql-cmd-create-table self) conn)
  81     (dolist (cmd (sql-cmd-create-indices self))
  82       (sql-execute cmd conn))
  83     (values)))
  84
  85 (defmethod sql-drop ((self sqltable))
  86   (mutex-sql-execute (sql-cmd-drop-table self))
  87   (values))
  88
  89 (defmethod sql-insert ((self sqltable))
  90   (mutex-sql-execute
  91    (format nil "INSERT INTO ~a (~a) VALUES (~a)"
  92            (sql-name self) (sql-cmd-field-names self) (format-values self))))
  93
  94 (defmethod sql-select ((self sqltable) key)
  95   (let ((tuple
  96          (car
  97           (mutex-sql-query
  98            (format nil "SELECT ~a FROM ~a WHERE ~a=~a"
  99                    (sql-cmd-field-names self) (sql-name self)
 100                    (inverse-field-name self) key)))))
 101     (when tuple
 102       (format t "process returned fields"))))
 103
 104
 105 (defun format-values (self)
 106   (let ((values "")
 107         (fields (fields self)))
 108     (dolist (field fields)
 109       (unless (eq field (car fields))
 110         (string-append values ","))
 111       (let ((name (car field)))
 112         (with-key-value-list (key value (rest field))
 113           (when (eq key :type)
 114             (string-append values
 115                               (ecase value
 116                                 ((:fixnum :bigint :short-float :double-float)
 117                                  (write-to-string
 118                                   (slot-value self name)))
 119                                 ((:string :text)
 120                                  (format nil "'~a'"
 121                                          (add-sql-quotes
 122                                           (slot-value self name))))))))))
 123     values))
 124
 125 (defmacro defsqltable (tname &key fields)
 126   `(progn
 127      (defclass ,tname (sqltable)
 128        ,(parse-fields tname fields)
 129        ,(default-initargs fields))
 130
 131      (defmethod sql-name ((self ,tname))
 132        ,(substitute #\_ #\- (write-to-string tname)))
 133
 134      (defmethod fields ((self ,tname))
 135        (quote ,fields))
 136
 137      (defmethod sql-cmd-create-table ((self ,tname))
 138        ,(create-table-string tname fields))
 139
 140      (defmethod sql-cmd-create-indices ((self ,tname))
 141        "Return a list of index cmds"
 142        (quote ,(create-indices-string tname fields)))
 143
 144      (defmethod sql-cmd-drop-table ((self ,tname))
 145        ,(format nil "DROP TABLE ~a" tname))
 146
 147      (defmethod sql-cmd-field-names ((self ,tname))
 148        ,(row-field-string fields))
 149
 150      (defmethod inverse-field-name ((self ,tname))
 151        ,(inverse-field-string fields))
 152      ))
 153
 154 (defun create-indices-string (table-name fields)
 155   (let (indices)
 156     (dolist (field fields)
 157       (let ((name-string (write-to-string (car field))))
 158         (with-key-value-list (key value (rest field))
 159           (when (eq key :unique)
 160             (case value
 161               (nil
 162                (push (sql-cmd-index table-name name-string nil) indices))
 163               (t
 164                (push (sql-cmd-index table-name name-string t) indices)))))))
 165     indices))
 166
 167 (defun inverse-field-string (fields)
 168   (let (inverse)
 169     (dolist (field fields)
 170       (let ((name-string (write-to-string (car field))))
 171         (with-key-value-list (key value (rest field))
 172           (when (eq key :inverse)
 173             (setq inverse value)))))
 174     (when inverse
 175       (write-to-string inverse))))
 176
 177 (defun sql-cmd-index (table field unique)
 178   (let ((*print-circle* nil))
 179     (format nil "CREATE ~A INDEX ~A_~A ON ~A(~A)"
 180             (if unique "UNIQUE" "")
 181             (slot-name-to-sql-name table)
 182             (slot-name-to-sql-name field)
 183             (slot-name-to-sql-name table)
 184             (slot-name-to-sql-name field))))
 185
 186 (defun row-field-string (fields)
 187   (let ((names ""))
 188     (dolist (field fields)
 189       (unless (eq field (car fields))
 190         (string-append names ","))
 191       (string-append names (slot-name-to-sql-name (car field))))
 192     names))
 193
 194 (defun slot-name-to-sql-name (name)
 195   (let ((str (string-upcase (etypecase name
 196                               (string
 197                                name)
 198                               (symbol
 199                                (write-to-string name))))))
 200     (substitute #\_ #\- str)))
 201
 202 (defun create-table-string (table-name fields)
 203   (let ((cmd (format nil "CREATE TABLE ~A (" (slot-name-to-sql-name table-name))))
 204     (dolist (field fields)
 205       (unless (eq field (car fields))
 206         (string-append cmd ", "))
 207       (string-append cmd (slot-name-to-sql-name (car field)) " ")
 208       (let (length type)
 209         (with-key-value-list (key value (rest field))
 210           (case key
 211             (:length
 212              (setq length value))
 213             (:type
 214              (setq type value))))
 215         (string-append cmd (sql-field-cmd type length))))
 216     (string-append cmd ")")))
 217
 218
 219 (defun sql-field-cmd (type length)
 220   (ecase type
 221     (:string
 222      (if (< length 8)
 223          (format nil "CHAR(~d)" length)
 224        (format nil "VARCHAR(~d)" length)))
 225     (:text
 226      "LONGTEXT")
 227     (:fixnum
 228      "INTEGER")
 229     (:bigint
 230      "BIGINT")
 231     (:short-float
 232      "SINGLE")
 233     (:long-float
 234      "DOUBLE")))
 235
 236 (defmacro with-key-value-list ((key value list) form)
 237   (let ((i (gensym)))
 238     `(loop for ,i from 0 to (1- (length ,list)) by 2 do
 239            (let ((,key (nth ,i ,list))
 240                  (,value (nth (1+ ,i) ,list)))
 241              ,form))))
 242
 243 (defun parse-fields (table-name fields)
 244   (let (class-fields)
 245     (dolist (field fields)
 246       (let* ((fname (car field))
 247              (name-string (write-to-string fname))
 248              (initarg (intern name-string :keyword))concat-symbol
 249              (def (list fname))
 250              (options (rest field)))
 251         (with-key-value-list (key value options)
 252           (case key
 253             (:type
 254              (setq def (nconc def (list :type
 255                                         (ecase value
 256                                           (:string
 257                                            'string)
 258                                           (:fixnum
 259                                            'fixnum)
 260                                           (:bigint
 261                                            'integer)
 262                                           (:short-float
 263                                            'short-float)
 264                                           (:long
 265                                            'long-float)
 266                                           (:text
 267                                            'string))))))))
 268         (setq def (nconc def (list
 269                               :initarg initarg
 270                               :accessor (concat-symbol
 271                                          (write-to-string table-name) "-"
 272                                          (write-to-string fname)))))
 273         (push def class-fields)))
 274     class-fields))
 275
 276 (defun default-initargs (fields)
 277   (let ((initargs (list :default-initargs)))
 278     (dolist (field fields)
 279       (let* ((fname (car field))
 280              (name-string (write-to-string fname))
 281              (initarg (intern name-string :keyword)))
 282         (setq initargs (nconc initargs (list initarg nil)))))
 283     initargs))
 284
 285
 286 ||#