X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=usql%2Fclasses.lisp;fp=usql%2Fclasses.lisp;h=7a11ddb2c5a4625ea6b3d9355878562246a88537;hb=ce0e343835a040406678dff74a62d1b0cb56f317;hp=0000000000000000000000000000000000000000;hpb=edd1963395a5b5e5f91ef975fcd329975ae367e2;p=clsql.git

diff --git a/usql/classes.lisp b/usql/classes.lisp
new file mode 100644
index 0000000..7a11ddb
--- /dev/null
+++ b/usql/classes.lisp
@@ -0,0 +1,740 @@
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; ======================================================================
+;;;; File:    classes.lisp
+;;;; Updated: <04/04/2004 12:08:49 marcusp>
+;;;; ======================================================================
+;;;;
+;;;; Description ==========================================================
+;;;; ======================================================================
+;;;;
+;;;; Classes defining SQL expressions and methods for formatting the
+;;;; appropriate SQL commands.
+;;;;
+;;;; ======================================================================
+
+(in-package :clsql-usql-sys)
+
+
+(defvar *default-database* nil
+  "Specifies the default database to be used.")
+
+(defvar +empty-string+ "''")
+
+(defvar +null-string+ "NULL")
+
+(defvar *sql-stream* nil
+  "stream which accumulates SQL output")
+
+(defvar *default-schema* "UNCOMMONSQL")
+
+(defvar *object-schemas* (make-hash-table :test #'equal)
+  "Hash of schema name to class constituent lists.")
+
+(defun in-schema (schemaname)
+  (setf *default-schema* schemaname))
+
+(defun sql-output (sql-expr &optional database)
+  (progv '(*sql-stream*)
+      `(,(make-string-output-stream))
+    (output-sql sql-expr database)
+    (get-output-stream-string *sql-stream*)))
+
+
+(defclass %sql-expression ()
+  ())
+
+(defmethod output-sql ((expr %sql-expression) &optional
+                       (database *default-database*))
+  (declare (ignore database))
+  (write-string +null-string+ *sql-stream*))
+
+(defmethod print-object ((self %sql-expression) stream)
+  (print-unreadable-object
+   (self stream :type t)
+   (write-string (sql-output self) stream)))
+
+;; For straight up strings
+
+(defclass sql (%sql-expression)
+  ((text
+    :initarg :string
+    :initform ""))
+  (:documentation "A literal SQL expression."))
+
+(defmethod make-load-form ((sql sql) &optional environment)
+  (declare (ignore environment))
+  (with-slots (text)
+    sql
+    `(make-instance 'sql :string ',text)))
+
+(defmethod output-sql ((expr sql) &optional (database *default-database*))
+  (declare (ignore database))
+  (write-string (slot-value expr 'text) *sql-stream*)
+  t)
+
+(defmethod print-object ((ident sql) stream)
+  (format stream "#<~S \"~A\">"
+          (type-of ident)
+          (sql-output ident)))
+
+;; For SQL Identifiers of generic type
+(defclass sql-ident (%sql-expression)
+  ((name
+    :initarg :name
+    :initform "NULL"))
+  (:documentation "An SQL identifer."))
+
+(defmethod make-load-form ((sql sql-ident) &optional environment)
+  (declare (ignore environment))
+  (with-slots (name)
+    sql
+    `(make-instance 'sql-ident :name ',name)))
+
+(defvar *output-hash* (make-hash-table :test #'equal))
+
+(defmethod output-sql-hash-key (expr &optional (database *default-database*))
+  (declare (ignore expr database))
+  nil)
+
+(defmethod output-sql :around ((sql t) &optional (database *default-database*))
+  (declare (ignore database))
+  (let* ((hash-key (output-sql-hash-key sql))
+         (hash-value (when hash-key (gethash hash-key *output-hash*))))
+    (cond ((and hash-key hash-value)
+           (write-string hash-value *sql-stream*))
+          (hash-key
+           (let ((*sql-stream* (make-string-output-stream)))
+             (call-next-method)
+             (setf hash-value (get-output-stream-string *sql-stream*))
+             (setf (gethash hash-key *output-hash*) hash-value))
+           (write-string hash-value *sql-stream*))
+          (t
+           (call-next-method)))))
+
+(defmethod output-sql ((expr sql-ident) &optional
+                       (database *default-database*))
+  (declare (ignore database))
+  (with-slots (name)
+    expr
+    (etypecase name
+      (string
+       (write-string name *sql-stream*))
+      (symbol
+       (write-string (symbol-name name) *sql-stream*)))
+    t))
+
+;; For SQL Identifiers for attributes
+
+(defclass sql-ident-attribute (sql-ident)
+  ((qualifier
+    :initarg :qualifier
+    :initform "NULL")
+   (type
+    :initarg :type
+    :initform "NULL")
+   (params
+    :initarg :params
+    :initform nil))
+  (:documentation "An SQL Attribute identifier."))
+
+(defmethod collect-table-refs (sql)
+  (declare (ignore sql))
+  nil)
+
+(defmethod collect-table-refs ((sql sql-ident-attribute))
+  (let ((qual (slot-value sql 'qualifier)))
+    (if (and qual (symbolp (slot-value sql 'qualifier)))
+        (list (make-instance 'sql-ident-table :name
+                             (slot-value sql 'qualifier))))))
+
+(defmethod make-load-form ((sql sql-ident-attribute) &optional environment)
+  (declare (ignore environment))
+  (with-slots (qualifier type name)
+    sql
+    `(make-instance 'sql-ident-attribute :name ',name
+      :qualifier ',qualifier
+      :type ',type)))
+
+(defmethod output-sql ((expr sql-ident-attribute) &optional
+                       (database *default-database*))
+  (declare (ignore database))
+  (with-slots (qualifier name type params)
+    expr
+    (if (and name (not qualifier) (not type))
+        (write-string (sql-escape (symbol-name name)) *sql-stream*)
+        (format *sql-stream* "~@[~A.~]~A~@[ ~A~]"
+                (if qualifier (sql-escape qualifier) qualifier)
+                (sql-escape name)
+                type))
+    t))
+
+(defmethod output-sql-hash-key ((expr sql-ident-attribute) &optional
+                                (database *default-database*))
+  (declare (ignore database))
+  (with-slots (qualifier name type params)
+    expr
+    (list 'sql-ident-attribute qualifier name type params)))
+
+;; For SQL Identifiers for tables
+(defclass sql-ident-table (sql-ident)
+  ((alias
+    :initarg :table-alias :initform nil))
+  (:documentation "An SQL table identifier."))
+
+(defmethod make-load-form ((sql sql-ident-table) &optional environment)
+  (declare (ignore environment))
+  (with-slots (alias name)
+    sql
+    `(make-instance 'sql-ident-table :name name :alias ',alias)))
+
+(defun generate-sql (expr)
+  (let ((*sql-stream* (make-string-output-stream)))
+    (output-sql expr)
+    (get-output-stream-string *sql-stream*)))
+
+(defmethod output-sql ((expr sql-ident-table) &optional
+                       (database *default-database*))
+  (declare (ignore database))
+  (with-slots (name alias)
+    expr
+    (if (null alias)
+        (write-string (sql-escape (symbol-name name)) *sql-stream*)
+        (progn
+          (write-string (sql-escape (symbol-name name)) *sql-stream*)
+          (write-char #\Space *sql-stream*)
+          (format *sql-stream* "~s" alias))))
+  t)
+
+(defmethod output-sql-hash-key ((expr sql-ident-table) &optional
+                                (database *default-database*))
+  (declare (ignore database))
+  (with-slots (name alias)
+    expr
+    (list 'sql-ident-table name alias)))
+
+(defclass sql-relational-exp (%sql-expression)
+  ((operator
+    :initarg :operator
+    :initform nil)
+   (sub-expressions
+    :initarg :sub-expressions
+    :initform nil))
+  (:documentation "An SQL relational expression."))
+
+(defmethod collect-table-refs ((sql sql-relational-exp))
+  (let ((tabs nil))
+    (dolist (exp (slot-value sql 'sub-expressions))
+      (let ((refs (collect-table-refs exp)))
+        (if refs (setf tabs (append refs tabs)))))
+    (remove-duplicates tabs
+                       :test (lambda (tab1 tab2)
+                               (equal (slot-value tab1 'name)
+                                      (slot-value tab2 'name))))))
+
+
+
+
+;; Write SQL for relational operators (like 'AND' and 'OR').
+;; should do arity checking of subexpressions
+
+(defmethod output-sql ((expr sql-relational-exp) &optional
+                       (database *default-database*))
+  (with-slots (operator sub-expressions)
+    expr
+    (let ((subs (if (consp (car sub-expressions))
+                    (car sub-expressions)
+                    sub-expressions)))
+      (write-char #\( *sql-stream*)
+      (do ((sub subs (cdr sub)))
+          ((null (cdr sub)) (output-sql (car sub) database))
+        (output-sql (car sub) database)
+        (write-char #\Space *sql-stream*)
+        (output-sql operator database)
+        (write-char #\Space *sql-stream*))
+      (write-char #\) *sql-stream*)))
+  t)
+
+(defclass sql-upcase-like (sql-relational-exp)
+  ()
+  (:documentation "An SQL 'like' that upcases its arguments."))
+  
+;; Write SQL for relational operators (like 'AND' and 'OR').
+;; should do arity checking of subexpressions
+  
+(defmethod output-sql ((expr sql-upcase-like) &optional
+                       (database *default-database*))
+  (flet ((write-term (term)
+           (write-string "upper(" *sql-stream*)
+           (output-sql term database)
+           (write-char #\) *sql-stream*)))
+    (with-slots (sub-expressions)
+      expr
+      (let ((subs (if (consp (car sub-expressions))
+                      (car sub-expressions)
+                      sub-expressions)))
+        (write-char #\( *sql-stream*)
+        (do ((sub subs (cdr sub)))
+            ((null (cdr sub)) (write-term (car sub)))
+          (write-term (car sub))
+          (write-string " LIKE " *sql-stream*))
+        (write-char #\) *sql-stream*))))
+  t)
+
+(defclass sql-assignment-exp (sql-relational-exp)
+  ()
+  (:documentation "An SQL Assignment expression."))
+
+
+(defmethod output-sql ((expr sql-assignment-exp) &optional
+                       (database *default-database*))
+  (with-slots (operator sub-expressions)
+    expr
+    (do ((sub sub-expressions (cdr sub)))
+        ((null (cdr sub)) (output-sql (car sub) database))
+      (output-sql (car sub) database)
+      (write-char #\Space *sql-stream*)
+      (output-sql operator database)
+      (write-char #\Space *sql-stream*)))
+  t)
+
+(defclass sql-value-exp (%sql-expression)
+  ((modifier
+    :initarg :modifier
+    :initform nil)
+   (components
+    :initarg :components
+    :initform nil))
+  (:documentation
+   "An SQL value expression.")
+  )
+
+(defmethod collect-table-refs ((sql sql-value-exp))
+  (let ((tabs nil))
+    (if (listp (slot-value sql 'components))
+        (progn
+          (dolist (exp (slot-value sql 'components))
+            (let ((refs (collect-table-refs exp)))
+              (if refs (setf tabs (append refs tabs)))))
+          (remove-duplicates tabs
+                             :test (lambda (tab1 tab2)
+                                     (equal (slot-value tab1 'name)
+                                            (slot-value tab2 'name)))))
+        nil)))
+
+
+
+(defmethod output-sql ((expr sql-value-exp) &optional
+                       (database *default-database*))
+  (with-slots (modifier components)
+    expr
+    (if modifier
+        (progn
+          (write-char #\( *sql-stream*)
+          (output-sql modifier database)
+          (write-char #\Space *sql-stream*)
+          (output-sql components database)
+          (write-char #\) *sql-stream*))
+        (output-sql components database))))
+
+(defclass sql-typecast-exp (sql-value-exp)
+  ()
+  (:documentation "An SQL typecast expression."))
+
+(defmethod output-sql ((expr sql-typecast-exp) &optional
+                       (database *default-database*))
+  (database-output-sql expr database))
+
+(defmethod database-output-sql ((expr sql-typecast-exp) database)
+  (with-slots (components)
+    expr
+    (output-sql components database)))
+
+
+(defmethod collect-table-refs ((sql sql-typecast-exp))
+  (when (slot-value sql 'components)
+    (collect-table-refs (slot-value sql 'components))))
+
+(defclass sql-function-exp (%sql-expression)
+  ((name
+    :initarg :name
+    :initform nil)
+   (args
+    :initarg :args
+    :initform nil))
+  (:documentation
+   "An SQL function expression."))
+
+(defmethod collect-table-refs ((sql sql-function-exp))
+  (let ((tabs nil))
+    (dolist (exp (slot-value sql 'components))
+      (let ((refs (collect-table-refs exp)))
+        (if refs (setf tabs (append refs tabs)))))
+    (remove-duplicates tabs
+                       :test (lambda (tab1 tab2)
+                               (equal (slot-value tab1 'name)
+                                      (slot-value tab2 'name))))))
+
+(defmethod output-sql ((expr sql-function-exp) &optional
+                       (database *default-database*))
+  (with-slots (name args)
+    expr
+    (output-sql name database)
+    (when args (output-sql args database)))
+  t)
+
+(defclass sql-query (%sql-expression)
+  ((selections
+    :initarg :selections
+    :initform nil)
+   (all
+    :initarg :all
+    :initform nil)
+   (flatp
+    :initarg :flatp
+    :initform nil)
+   (set-operation
+    :initarg :set-operation
+    :initform nil)
+   (distinct
+    :initarg :distinct
+    :initform nil)
+   (from
+    :initarg :from
+    :initform nil)
+   (where
+    :initarg :where
+    :initform nil)
+   (group-by
+    :initarg :group-by
+    :initform nil)
+   (having
+    :initarg :having
+    :initform nil)
+   (limit
+    :initarg :limit
+    :initform nil)
+   (offset
+    :initarg :offset
+    :initform nil)
+   (order-by
+    :initarg :order-by
+    :initform nil)
+   (order-by-descending
+    :initarg :order-by-descending
+    :initform nil))
+  (:documentation "An SQL SELECT query."))
+
+(defmethod collect-table-refs ((sql sql-query))
+  (remove-duplicates (collect-table-refs (slot-value sql 'where))
+                     :test (lambda (tab1 tab2)
+                             (equal (slot-value tab1 'name)
+                                    (slot-value tab2 'name)))))
+
+(defvar *select-arguments*
+  '(:all :database :distinct :flatp :from :group-by :having :order-by
+    :order-by-descending :set-operation :where :offset :limit))
+
+(defun query-arg-p (sym)
+  (member sym *select-arguments*))
+
+(defun query-get-selections (select-args)
+  "Return two values: the list of select-args up to the first keyword,
+uninclusive, and the args from that keyword to the end."
+  (let ((first-key-arg (position-if #'query-arg-p select-args)))
+    (if first-key-arg
+        (values (subseq select-args 0 first-key-arg)
+                (subseq select-args first-key-arg))
+        select-args)))
+
+(defmethod make-query (&rest args)
+  (multiple-value-bind (selections arglist)
+      (query-get-selections args)
+    (destructuring-bind (&key all flatp set-operation distinct from where
+                              group-by having order-by order-by-descending
+                              offset limit &allow-other-keys)
+        arglist
+      (if (null selections)
+          (error "No target columns supplied to select statement."))
+      (if (null from)
+          (error "No source tables supplied to select statement."))
+      (make-instance 'sql-query :selections selections
+                     :all all :flatp flatp :set-operation set-operation
+                     :distinct distinct :from from :where where
+                     :limit limit :offset offset
+                     :group-by group-by :having having :order-by order-by
+                     :order-by-descending order-by-descending))))
+
+(defvar *in-subselect* nil)
+
+(defmethod output-sql ((query sql-query) &optional
+                       (database *default-database*))
+  (with-slots (distinct selections from where group-by having order-by
+                        order-by-descending limit offset)
+      query
+    (when *in-subselect*
+      (write-string "(" *sql-stream*))
+    (write-string "SELECT " *sql-stream*)
+    (when distinct
+      (write-string "DISTINCT " *sql-stream*)
+      (unless (eql t distinct)
+        (write-string "ON " *sql-stream*)
+        (output-sql distinct database)
+        (write-char #\Space *sql-stream*)))
+    (output-sql (apply #'vector selections) database)
+    (write-string " FROM " *sql-stream*)
+    (if (listp from)
+        (output-sql (apply #'vector from) database)
+        (output-sql from database))
+    (when where
+      (write-string " WHERE " *sql-stream*)
+      (let ((*in-subselect* t))
+        (output-sql where database)))
+    (when group-by
+      (write-string " GROUP BY " *sql-stream*)
+      (output-sql group-by database))
+    (when having
+      (write-string " HAVING " *sql-stream*)
+      (output-sql having database))
+    (when order-by
+      (write-string " ORDER BY " *sql-stream*)
+      (if (listp order-by)
+          (do ((order order-by (cdr order)))
+              ((null order))
+            (output-sql (car order) database)
+            (when (cdr order)
+              (write-char #\, *sql-stream*)))
+          (output-sql order-by database)))
+    (when order-by-descending
+      (write-string " ORDER BY " *sql-stream*)
+      (if (listp order-by-descending)
+          (do ((order order-by-descending (cdr order)))
+              ((null order))
+            (output-sql (car order) database)
+            (when (cdr order)
+              (write-char #\, *sql-stream*)))
+          (output-sql order-by-descending database))
+      (write-string " DESC " *sql-stream*))
+    (when limit
+      (write-string " LIMIT " *sql-stream*)
+      (output-sql limit database))
+    (when offset
+      (write-string " OFFSET " *sql-stream*)
+      (output-sql offset database))
+    (when *in-subselect*
+      (write-string ")" *sql-stream*)))
+  t)
+
+;; INSERT
+
+(defclass sql-insert (%sql-expression)
+  ((into
+    :initarg :into
+    :initform nil)
+   (attributes
+    :initarg :attributes
+    :initform nil)
+   (values
+    :initarg :values
+    :initform nil)
+   (query
+    :initarg :query
+    :initform nil))
+  (:documentation
+   "An SQL INSERT statement."))
+
+(defmethod output-sql ((ins sql-insert) &optional
+                       (database *default-database*))
+  (with-slots (into attributes values query)
+    ins
+    (write-string "INSERT INTO " *sql-stream*)
+    (output-sql into database)
+    (when attributes
+      (write-char #\Space *sql-stream*)
+      (output-sql attributes database))
+    (when values
+      (write-string " VALUES " *sql-stream*)
+      (output-sql values database))
+    (when query
+      (write-char #\Space *sql-stream*)
+      (output-sql query database)))
+  t)
+
+;; DELETE
+
+(defclass sql-delete (%sql-expression)
+  ((from
+    :initarg :from
+    :initform nil)
+   (where
+    :initarg :where
+    :initform nil))
+  (:documentation
+   "An SQL DELETE statement."))
+
+(defmethod output-sql ((stmt sql-delete) &optional
+                       (database *default-database*))
+  (with-slots (from where)
+    stmt
+    (write-string "DELETE FROM " *sql-stream*)
+    (typecase from
+      (symbol (write-string (sql-escape from) *sql-stream*))
+      (t  (output-sql from database)))
+    (when where
+      (write-string " WHERE " *sql-stream*)
+      (output-sql where database)))
+  t)
+
+;; UPDATE
+
+(defclass sql-update (%sql-expression)
+  ((table
+    :initarg :table
+    :initform nil)
+   (attributes
+    :initarg :attributes
+    :initform nil)
+   (values
+    :initarg :values
+    :initform nil)
+   (where
+    :initarg :where
+    :initform nil))
+  (:documentation "An SQL UPDATE statement."))
+
+(defmethod output-sql ((expr sql-update) &optional
+                       (database *default-database*))
+  (with-slots (table where attributes values)
+    expr
+    (flet ((update-assignments ()
+             (mapcar #'(lambda (a b)
+                         (make-instance 'sql-assignment-exp
+                                        :operator '=
+                                        :sub-expressions (list a b)))
+                     attributes values)))
+      (write-string "UPDATE " *sql-stream*)
+      (output-sql table database)
+      (write-string " SET " *sql-stream*)
+      (output-sql (apply #'vector (update-assignments)) database)
+      (when where
+        (write-string " WHERE " *sql-stream*)
+        (output-sql where database))))
+  t)
+
+;; CREATE TABLE
+
+(defclass sql-create-table (%sql-expression)
+  ((name
+    :initarg :name
+    :initform nil)
+   (columns
+    :initarg :columns
+    :initform nil)
+   (modifiers
+    :initarg :modifiers
+    :initform nil))
+  (:documentation
+   "An SQL CREATE TABLE statement."))
+
+;; Here's a real warhorse of a function!
+
+(defun listify (x)
+  (if (atom x)
+      (list x)
+      x))
+
+(defmethod output-sql ((stmt sql-create-table) &optional
+                       (database *default-database*))
+  (flet ((output-column (column-spec)
+           (destructuring-bind (name type &rest constraints)
+               column-spec
+             (let ((type (listify type)))
+               (output-sql name database)
+               (write-char #\Space *sql-stream*)
+               (write-string
+                (database-get-type-specifier (car type) (cdr type) database)
+                *sql-stream*)
+               (let ((constraints
+                      (database-constraint-statement constraints database)))
+                 (when constraints
+                   (write-string " " *sql-stream*)
+                   (write-string constraints *sql-stream*)))))))
+    (with-slots (name columns modifiers)
+      stmt
+      (write-string "CREATE TABLE " *sql-stream*)
+      (output-sql name database)
+      (write-string " (" *sql-stream*)
+      (do ((column columns (cdr column)))
+          ((null (cdr column))
+           (output-column (car column)))
+        (output-column (car column))
+        (write-string ", " *sql-stream*))
+      (when modifiers
+        (do ((modifier (listify modifiers) (cdr modifier)))
+            ((null modifier))
+          (write-string ", " *sql-stream*)
+          (write-string (car modifier) *sql-stream*)))
+      (write-char #\) *sql-stream*)))
+  t)
+
+
+;; CREATE VIEW
+
+(defclass sql-create-view (%sql-expression)
+  ((name :initarg :name :initform nil)
+   (column-list :initarg :column-list :initform nil)
+   (query :initarg :query :initform nil)
+   (with-check-option :initarg :with-check-option :initform nil))
+  (:documentation "An SQL CREATE VIEW statement."))
+
+(defmethod output-sql ((stmt sql-create-view) &optional database)
+  (with-slots (name column-list query with-check-option) stmt
+    (write-string "CREATE VIEW " *sql-stream*)
+    (output-sql name database)
+    (when column-list (write-string " " *sql-stream*)
+          (output-sql (listify column-list) database))
+    (write-string " AS " *sql-stream*)
+    (output-sql query database)
+    (when with-check-option (write-string " WITH CHECK OPTION" *sql-stream*))))
+
+
+;;
+;; Column constraint types
+;;
+(defparameter *constraint-types*
+  '(("NOT-NULL" . "NOT NULL")
+    ("PRIMARY-KEY" . "PRIMARY KEY")))
+
+;;
+;; Convert type spec to sql syntax
+;;
+
+(defmethod database-constraint-description (constraint database)
+  (declare (ignore database))
+  (let ((output (assoc (symbol-name constraint) *constraint-types*
+                       :test #'equal)))
+    (if (null output)
+        (error 'clsql-sql-syntax-error
+               :reason (format nil "unsupported column constraint '~a'"
+                               constraint))
+        (cdr output))))
+
+(defmethod database-constraint-statement (constraint-list database)
+  (declare (ignore database))
+  (make-constraints-description constraint-list))
+  
+(defun make-constraints-description (constraint-list)
+  (if constraint-list
+      (let ((string ""))
+        (do ((constraint constraint-list (cdr constraint)))
+            ((null constraint) string)
+          (let ((output (assoc (symbol-name (car constraint))
+                               *constraint-types*
+                               :test #'equal)))
+            (if (null output)
+                (error 'clsql-sql-syntax-error
+                       :reason (format nil "unsupported column constraint '~a'"
+                                       constraint))
+                (setq string (concatenate 'string string (cdr output))))
+            (if (< 1 (length constraint))
+                (setq string (concatenate 'string string " "))))))))
+