sql.lisp

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