+++ /dev/null
-;;;; -*- 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 +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 " "))))))))
-
projects / clsql.git / blobdiff