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