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