+++ /dev/null
-;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
-;;;; ======================================================================
-;;;; File: package.lisp
-;;;; Updated: <04/04/2004 12:05:16 marcusp>
-;;;; ======================================================================
-;;;;
-;;;; Description ==========================================================
-;;;; ======================================================================
-;;;;
-;;;; CLSQL-USQL square bracket symbolic query syntax. Functions for
-;;;; enabling and disabling the syntax and for building SQL
-;;;; expressions using the syntax.
-;;;;
-;;;; ======================================================================
-
-(in-package :clsql-usql-sys)
-
-(defvar *original-reader-enter* nil)
-
-(defvar *original-reader-exit* nil)
-
-(defvar *sql-macro-open-char* #\[)
-
-(defvar *sql-macro-close-char* #\])
-
-(defvar *restore-sql-reader-syntax* nil)
-
-
-;; Exported functions for disabling SQL syntax.
-
-(defmacro disable-sql-reader-syntax ()
- "Turn off SQL square bracket syntax changing syntax state. Set state
-such that RESTORE-SQL-READER-SYNTAX-STATE will make the syntax
-disabled if it is consequently locally enabled."
- '(eval-when (:compile-toplevel :load-toplevel :execute)
- (setf *restore-sql-reader-syntax* nil)
- (%disable-sql-reader-syntax)))
-
-(defmacro locally-disable-sql-reader-syntax ()
- "Turn off SQL square bracket syntax and do not change syntax state."
- '(eval-when (:compile-toplevel :load-toplevel :execute)
- (%disable-sql-reader-syntax)))
-
-(defun %disable-sql-reader-syntax ()
- (when *original-reader-enter*
- (set-macro-character *sql-macro-open-char* *original-reader-enter*))
- (setf *original-reader-enter* nil)
- (values))
-
-
-;; Exported functions for enabling SQL syntax.
-
-(defmacro enable-sql-reader-syntax ()
- "Turn on SQL square bracket syntax changing syntax state. Set state
-such that RESTORE-SQL-READER-SYNTAX-STATE will make the syntax enabled
-if it is consequently locally disabled."
- '(eval-when (:compile-toplevel :load-toplevel :execute)
- (setf *restore-sql-reader-syntax* t)
- (%enable-sql-reader-syntax)))
-
-(defmacro locally-enable-sql-reader-syntax ()
- "Turn on SQL square bracket syntax and do not change syntax state."
- '(eval-when (:compile-toplevel :load-toplevel :execute)
- (%enable-sql-reader-syntax)))
-
-(defun %enable-sql-reader-syntax ()
- (unless *original-reader-enter*
- (setf *original-reader-enter* (get-macro-character *sql-macro-open-char*)))
- (set-macro-character *sql-macro-open-char* #'sql-reader-open)
- (enable-sql-close-syntax)
- (values))
-
-(defmacro restore-sql-reader-syntax-state ()
- "Sets the enable/disable square bracket syntax state to reflect the
-last call to either DISABLE-SQL-READER-SYNTAX or
-ENABLE-SQL-READER-SYNTAX. The default state of the square bracket
-syntax is disabled."
- '(eval-when (:compile-toplevel :load-toplevel :execute)
- (if *restore-sql-reader-syntax*
- (%enable-sql-reader-syntax)
- (%disable-sql-reader-syntax))))
-
-(defun sql-reader-open (stream char)
- (declare (ignore char))
- (let ((sqllist (read-delimited-list #\] stream t)))
- (if (sql-operator (car sqllist))
- (cons (sql-operator (car sqllist)) (cdr sqllist))
- (apply #'generate-sql-reference sqllist))))
-
-;; Internal function that disables the close syntax when leaving sql context.
-(defun disable-sql-close-syntax ()
- (set-macro-character *sql-macro-close-char* *original-reader-exit*)
- (setf *original-reader-exit* nil))
-
-;; Internal function that enables close syntax when entering SQL context.
-(defun enable-sql-close-syntax ()
- (setf *original-reader-exit* (get-macro-character *sql-macro-close-char*))
- (set-macro-character *sql-macro-close-char* (get-macro-character #\))))
-
-(defun generate-sql-reference (&rest arglist)
- (cond ((= (length arglist) 1) ; string, table or attribute
- (if (stringp (car arglist))
- (sql-expression :string (car arglist))
- (sql-expression :attribute (car arglist))))
- ((<= 2 (length arglist))
- (let ((sqltype (if (keywordp (caddr arglist))
- (caddr arglist) nil))
- (sqlparam (if (keywordp (caddr arglist))
- (caddr arglist))))
- (cond
- ((stringp (cadr arglist))
- (sql-expression :table (car arglist)
- :alias (cadr arglist)
- :type sqltype))
- ((keywordp (cadr arglist))
- (sql-expression :attribute (car arglist)
- :type (cadr arglist)
- :params sqlparam))
- (t
- (sql-expression :attribute (cadr arglist)
- :table (car arglist)
- :params sqlparam
- :type sqltype)))))
- (t
- (error 'clsql-sql-syntax-error :reason "bad expression syntax"))))
-
-
-;; Exported functions for dealing with SQL syntax
-
-(defun sql (&rest args)
- "Generates SQL from a set of expressions given by ARGS. Each
-argument is translated into SQL and then the args are concatenated
-with a single space between each pair."
- (format nil "~{~A~^ ~}" (mapcar #'sql-output args)))
-
-(defun sql-expression (&key string table alias attribute type params)
- "Generates an SQL expression from the given keywords. Valid
-combinations of the arguments are: string; table; table and alias;
-table and attribute; table, attribute, and type; table or alias, and
-attribute; table or alias, and attribute and type; attribute; and
-attribute and type."
- (cond
- (string
- (make-instance 'sql :string string))
- (attribute
- (make-instance 'sql-ident-attribute :name attribute
- :qualifier (or table alias)
- :type type
- :params params))
- ((and table (not attribute))
- (make-instance 'sql-ident-table :name table
- :table-alias alias))))
-
-(defun sql-operator (operation)
- "Takes an SQL operator as an argument and returns the Lisp symbol
-for the operator."
- (typecase operation
- (string nil)
- (symbol (gethash (string-upcase (symbol-name operation))
- *sql-op-table*))))
-
-(defun sql-operation (operation &rest rest)
- "Generates an SQL statement from an operator and arguments."
- (if (sql-operator operation)
- (apply (symbol-function (sql-operator operation)) rest)
- (error "~A is not a recognized SQL operator." operation)))
-
-
projects / clsql.git / blobdiff