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