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