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