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