sql.lisp

   1 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: umlisp -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:          sql.lisp
   6 ;;;; Purpose:       SQL Generation functions for Hyperobject
   7 ;;;; Programmer:    Kevin M. Rosenberg
   8 ;;;; Date Started:  Apr 2000
   9 ;;;;
  10 ;;;; $Id$
  11 ;;;;
  12 ;;;; This file is Copyright (c) 2000-2003 by Kevin M. Rosenberg
  13 ;;;; *************************************************************************
  14
  15 (in-package #:hyperobject)
  16
  17 ;;;; Metaclass initialization commands
  18
  19 (defun finalize-sql (cl)
  20   (setf (slot-value cl 'drop-table-cmd) (generate-drop-table-cmd
  21                                          (slot-value cl 'sql-name)))
  22   (let ((esds (class-slots cl)))
  23     (setf (slot-value cl 'create-table-cmd)
  24       (generate-create-table-cmd
  25        cl
  26        (remove-if #'(lambda (esd) (null (esd-stored esd))) esds)))
  27     (setf (slot-value cl 'create-indices-cmds)
  28       (generate-create-indices-cmds (sql-name cl) esds))
  29     (dolist (esd esds)
  30       (when (slot-value esd 'inverse)
  31         (define-inverse cl esd))))
  32   )
  33
  34
  35 (defun define-inverse (class esd)
  36   "Define an inverse function for a slot"
  37   (let ((inverse (slot-value esd 'inverse)))
  38     (when inverse
  39       (eval
  40        `(defun ,inverse (obj)
  41           (format t "~&Finding key: ~S for class ~S ~%" obj ,class)
  42           ;; create inverse function
  43           ))
  44       ))
  45   )
  46
  47 (defun generate-create-table-cmd (cl esds)
  48   (with-output-to-string (s)
  49     (format s "CREATE TABLE ~A (~{~A~^, ~})"
  50             (slot-value cl 'sql-name)
  51             (loop for esd in esds
  52                 collect
  53                   (concatenate
  54                       'string
  55                     (slot-value esd 'sql-name)
  56                     " "
  57                     (sql-type-to-field-string (slot-value esd 'sql-type)
  58                                               (slot-value esd 'sql-length)))))))
  59
  60 (defun sql-type-to-field-string (type length)
  61   (ecase type
  62     (:string
  63      (cond
  64       ((null length)
  65        "LONGTEXT")
  66       ((< length 8)
  67        (format nil "CHAR(~d)" length))
  68       (t
  69        (format nil "VARCHAR(~d)" length))))
  70     (:varchar
  71      (cond
  72       ((null length)
  73        "LONGTEXT")
  74       (t
  75        (format nil "VARCHAR(~d)" length))))
  76     (:text
  77      "LONGTEXT")
  78     (:datetime
  79      "VARCHAR(20)")
  80     (:char
  81      (unless length
  82        (setq length 1))
  83      (format nil "CHAR(~D)" length))
  84     ((or :fixnum :integer)
  85      "INTEGER")
  86     (:boolean
  87      "CHAR(1)")
  88     (:long-integer
  89      "BIGINT")
  90     ((or :short-float :float)
  91      "SINGLE")
  92     (:long-float
  93      "DOUBLE")))
  94
  95 (defun generate-drop-table-cmd (table-name)
  96   (format nil "DROP TABLE ~a" table-name))
  97
  98 (defun generate-create-indices-cmds (table-name slots)
  99   (let (indices)
 100     (dolist (slot slots)
 101       (when (slot-value slot 'indexed)
 102         (let ((sql-name (slot-value slot 'sql-name)))
 103           (push (sql-cmd-index table-name sql-name (slot-value slot 'unique))
 104                 indices))))
 105     indices))
 106
 107 (defun sql-cmd-index (table field unique)
 108   (let ((*print-circle* nil))
 109     (format nil "CREATE ~AINDEX ~A ON ~A(~A)"
 110             (if unique "UNIQUE " "")
 111             (sql-index-name table field)
 112             table
 113             field)))
 114
 115 (defun sql-index-name (table field)
 116   (format nil "~A_~A" table field))
 117
 118 ;;;; Runtime Commands
 119
 120 (defgeneric sql-create (cl))
 121 (defmethod sql-create (cl)
 122  (with-sql-connection (conn)
 123     (sql-execute (slot-value cl 'create-table-cmd) conn)
 124     (dolist (cmd (slot-value cl 'create-indices-cmds))
 125       (sql-execute cmd conn))
 126     (values)))
 127
 128 (defgeneric sql-drop (cl))
 129 (defmethod sql-drop (cl)
 130   (mutex-sql-execute (slot-value cl 'drop-table-cmd))
 131   (values))
 132
 133 #|
 134 (defmethod sql-insert (obj)
 135   (mutex-sql-execute
 136    (format nil "INSERT INTO ~a (~a) VALUES (~a)"
 137            (sql-name self) (sql-cmd-field-names self) (format-values self))))
 138
 139 (defmethod sql-select (obj lisp-name key)
 140   (let ((tuple
 141          (car
 142           (mutex-sql-query
 143            (format nil "SELECT ~a FROM ~a WHERE ~a=~a"
 144                    (sql-cmd-field-names self) (sql-name self)
 145                    (inverse-field-name self) key)))))
 146     (when tuple
 147       (format t "process returned fields"))))
 148
 149
 150 (defun format-values (self)
 151   (let ((values "")
 152         (fields (fields self)))
 153     (dolist (field fields)
 154       (unless (eq field (car fields))
 155         (string-append values ","))
 156       (let ((name (car field)))
 157         (with-key-value-list (key value (rest field))
 158           (when (eq key :type)
 159             (string-append values
 160                               (ecase value
 161                                 ((:fixnum :bigint :short-float :double-float)
 162                                  (write-to-string
 163                                   (slot-value self name)))
 164                                 ((:string :text)
 165                                  (format nil "'~a'"
 166                                          (add-sql-quotes
 167                                           (slot-value self name))))))))))
 168     values))
 169
 170 (defun inverse-field-string (fields)
 171   (let (inverse)
 172     (dolist (field fields)
 173       (let ((name-string (write-to-string (car field))))
 174         (with-key-value-list (key value (rest field))
 175           (when (eq key :inverse)
 176             (setq inverse value)))))
 177     (when inverse
 178       (write-to-string inverse))))
 179
 180 (defun row-field-string (fields)
 181   (let ((names ""))
 182     (dolist (field fields)
 183       (unless (eq field (car fields))
 184         (string-append names ","))
 185       (string-append names (lisp-name-to-sql-name (car field))))
 186     names))
 187
 188
 189 (defun parse-fields (table-name fields)
 190   (let (class-fields)
 191     (dolist (field fields)
 192       (let* ((fname (car field))
 193              (name-string (write-to-string fname))
 194              (initarg (intern name-string :keyword))concat-symbol
 195              (def (list fname))
 196              (options (rest field)))
 197         (with-key-value-list (key value options)
 198           (case key
 199             (:type
 200              (setq def (nconc def (list :type
 201                                         (ecase value
 202                                           (:string
 203                                            'string)
 204                                           (:fixnum
 205                                            'fixnum)
 206                                           (:long-integer
 207                                            'integer)
 208                                           (:short-float
 209                                            'short-float)
 210                                           (:long
 211                                            'long-float)
 212                                           (:text
 213                                            'string))))))))
 214         (setq def (nconc def (list
 215                               :initarg initarg
 216                               :accessor (concat-symbol
 217                                          (write-to-string table-name) "-"
 218                                          (write-to-string fname)))))
 219         (push def class-fields)))
 220     class-fields))
 221
 222 ||#