--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; $Id: $
+
+(in-package #:clsql-base-sys)
+
+;;; Query
+
+(defgeneric query (query-expression &key database result-types flatp)
+ (:documentation
+ "Execute the SQL query expression QUERY-EXPRESSION on the given
+DATABASE which defaults to *default-database*. RESULT-TYPES is a list
+of symbols such as :string and :integer, one for each field in the
+query, which are used to specify the types to return. The FLATP
+argument, which has a default value of nil, specifies if full
+bracketed results should be returned for each matched entry. If FLATP
+is nil, the results are returned as a list of lists. If FLATP is t,
+the results are returned as elements of a list, only if there is only
+one result per row. Returns a list of lists of values of the result of
+that expression and a list of field names selected in sql-exp."))
+
+(defmethod query ((query-expression string) &key (database *default-database*)
+ (result-types nil) (flatp nil))
+ (record-sql-command query-expression database)
+ (let* ((res (database-query query-expression database result-types))
+ (res (if (and flatp (= (length
+ (slot-value query-expression 'selections))
+ 1))
+ (mapcar #'car res)
+ res)))
+ (record-sql-result res database)
+ res))
+
+;;; Execute
+
+(defgeneric execute-command (expression &key database)
+ (:documentation
+ "Executes the SQL command specified by EXPRESSION for the database
+specified by DATABASE, which has a default value of
+*DEFAULT-DATABASE*. The argument EXPRESSION may be any SQL statement
+other than a query. To run a stored procedure, pass an appropriate
+string. The call to the procedure needs to be wrapped in a BEGIN END
+pair."))
+
+(defmethod execute-command ((sql-expression string)
+ &key (database *default-database*))
+ (record-sql-command sql-expression database)
+ (let ((res (database-execute-command sql-expression database)))
+ (record-sql-result res database))
+ (values))
+
+
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
-;;;; Name: classes.cl
+;;;; Name: classes.lisp
;;;; Purpose: Classes for High-level SQL interface
;;;; Programmers: Kevin M. Rosenberg based on
;;;; original code by Pierre R. Mai
;;;;
;;;; $Id$
;;;;
-;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;; This file, part of CLSQL, is Copyright (c) 2002-2004 by Kevin M. Rosenberg
;;;; and Copyright (c) 1999-2001 by Pierre R. Mai
;;;;
;;;; CLSQL users are granted the rights to distribute and use this software
;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;; *************************************************************************
-(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
-(in-package :clsql-base-sys)
+(in-package #:clsql-base-sys)
(defclass database ()
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
-;;;; Name: cmucl-compat.sql
+;;;; Name: cmucl-compat.lisp
;;;; Purpose: Compatiblity library for CMUCL functions
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Feb 2002
;;;;
;;;; $Id$
;;;;
-;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;; This file, part of CLSQL, is Copyright (c) 2002-2004 by Kevin M. Rosenberg
;;;;
;;;; CLSQL users are granted the rights to distribute and use this software
;;;; as governed by the terms of the Lisp Lesser GNU Public License
;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;; *************************************************************************
-(in-package :cl-user)
+(in-package #:cl-user)
-(defpackage :cmucl-compat
+(defpackage #:cmucl-compat
(:use #:common-lisp)
(:export
#:shrink-vector
#:result-type-or-lose
#:required-argument
))
-(in-package :cmucl-compat)
+(in-package #:cmucl-compat)
#+(or cmu scl)
(defmacro required-argument ()
(defun make-sequence-of-type (type len)
(lisp::make-sequence-of-type type len))
(defun make-sequence-of-type (type len)
- (system::make-sequence-of-type type len)))
+ (common-lisp::make-sequence-of-type type len)))
#-(or cmu scl)
(defun result-type-or-lose (type nil-ok)
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
-;;;; Name: conditions.cl
+;;;; Name: conditions.lisp
;;;; Purpose: Error conditions for high-level SQL interface
;;;; Programmers: Kevin M. Rosenberg based on
;;;; Original code by Pierre R. Mai
;;;;
;;;; $Id$
;;;;
-;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;; This file, part of CLSQL, is Copyright (c) 2002-2004 by Kevin M. Rosenberg
;;;; and Copyright (c) 1999-2001 by Pierre R. Mai
;;;;
;;;; CLSQL users are granted the rights to distribute and use this software
;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;; *************************************************************************
-(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
-(in-package :clsql-base-sys)
+(in-package #:clsql-base-sys)
;;; Conditions
(define-condition clsql-condition ()
'clsql-nodb-error
:database database))
+(defun signal-no-database-error ()
+ (cerror "Ignore this error and return nil."
+ 'clsql-nodb-error))
;; for USQL support
:reader clsql-sql-syntax-error-reason))
(:report (lambda (c stream)
(format stream "Invalid SQL syntax: ~A"
- (clsql-sql-syntax-error-reason c)))))
\ No newline at end of file
+ (clsql-sql-syntax-error-reason c)))))
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;;
+;;;; $Id: $
+
+(in-package #:clsql-base-sys)
+
+(setf (documentation 'database-name 'function)
+ "Returns the name of a database.")
+
+;;; Database handling
+
+(defvar *connect-if-exists* :error
+ "Default value for the if-exists parameter of connect calls.")
+
+(defvar *connected-databases* nil
+ "List of active database objects.")
+
+(defun connected-databases ()
+ "Return the list of active database objects."
+ *connected-databases*)
+
+(defvar *default-database* nil
+ "Specifies the default database to be used.")
+
+;;; usql
+(defun find-database (database &key (errorp t) (db-type nil))
+ "The function FIND-DATABASE, given a string DATABASE, searches
+amongst the connected databases for one matching the name DATABASE. If
+there is exactly one such database, it is returned and the second
+return value count is 1. If more than one databases match and ERRORP
+is nil, then the most recently connected of the matching databases is
+returned and count is the number of matches. If no matching database
+is found and ERRORP is nil, then nil is returned. If none, or more
+than one, matching databases are found and ERRORP is true, then an
+error is signalled. If the argument database is a database, it is
+simply returned."
+ (etypecase database
+ (database
+ (values database 1))
+ (string
+ (let* ((matches (remove-if
+ #'(lambda (db)
+ (not (and (string= (database-name db) database)
+ (if db-type
+ (equal (database-type db) db-type)
+ t))))
+ (connected-databases)))
+ (count (length matches)))
+ (if (or (not errorp) (= count 1))
+ (values (car matches) count)
+ (cerror "Return nil."
+ 'clsql-simple-error
+ :format-control "There exists ~A database called ~A."
+ :format-arguments
+ (list (if (zerop count) "no" "more than one")
+ database)))))))
+
+
+(defun connect (connection-spec
+ &key (if-exists *connect-if-exists*)
+ (make-default t)
+ (pool nil)
+ (database-type *default-database-type*))
+ "Connects to a database of the given database-type, using the
+type-specific connection-spec. The value of if-exists determines what
+happens if a connection to that database is already established. A
+value of :new means create a new connection. A value of :warn-new
+means warn the user and create a new connect. A value of :warn-old
+means warn the user and use the old connection. A value of :error
+means fail, notifying the user. A value of :old means return the old
+connection. If make-default is true, then *default-database* is set
+to the new connection, otherwise *default-database is not changed. If
+pool is t the connection will be taken from the general pool, if pool
+is a conn-pool object the connection will be taken from this pool."
+ (if pool
+ (acquire-from-pool connection-spec database-type pool)
+ (let* ((db-name (database-name-from-spec connection-spec database-type))
+ (old-db (unless (eq if-exists :new)
+ (find-database db-name :db-type database-type
+ :errorp nil)))
+ (result nil))
+ (if old-db
+ (ecase if-exists
+ (:warn-new
+ (setq result
+ (database-connect connection-spec database-type))
+ (warn 'clsql-exists-warning :old-db old-db :new-db result))
+ (:error
+ (restart-case
+ (error 'clsql-exists-error :old-db old-db)
+ (create-new ()
+ :report "Create a new connection."
+ (setq result
+ (database-connect connection-spec database-type)))
+ (use-old ()
+ :report "Use the existing connection."
+ (setq result old-db))))
+ (:warn-old
+ (setq result old-db)
+ (warn 'clsql-exists-warning :old-db old-db :new-db old-db))
+ (:old
+ (setq result old-db)))
+ (setq result
+ (database-connect connection-spec database-type)))
+ (when result
+ (pushnew result *connected-databases*)
+ (when make-default (setq *default-database* result))
+ result))))
+
+
+(defun disconnect (&key (database *default-database*) (error nil))
+
+ "Closes the connection to DATABASE and resets *default-database* if
+that database was disconnected. If database is a database object, then
+it is used directly. Otherwise, the list of connected databases is
+searched to find one with DATABASE as its connection
+specifications. If no such database is found, then if ERROR and
+DATABASE are both non-nil an error is signaled, otherwise DISCONNECT
+returns nil. If the database is from a pool it will be released to
+this pool."
+ (let ((database (find-database database :errorp (and database error))))
+ (when database
+ (if (conn-pool database)
+ (when (release-to-pool database)
+ (setf *connected-databases* (delete database *connected-databases*))
+ (when (eq database *default-database*)
+ (setf *default-database* (car *connected-databases*)))
+ t)
+ (when (database-disconnect database)
+ (setf *connected-databases* (delete database *connected-databases*))
+ (when (eq database *default-database*)
+ (setf *default-database* (car *connected-databases*)))
+ (change-class database 'closed-database)
+ t)))))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+
+
+
+(defun reconnect (&key (database *default-database*) (error nil) (force t))
+ "Reconnects DATABASE to its underlying RDBMS. If successful, returns
+t and the variable *default-database* is set to the newly reconnected
+database. The default value for DATABASE is *default-database*. If
+DATABASE is a database object, then it is used directly. Otherwise,
+the list of connected databases is searched to find one with database
+as its connection specifications (see CONNECT). If no such database is
+found, then if ERROR and DATABASE are both non-nil an error is
+signaled, otherwise RECONNECT returns nil. FORCE controls whether an
+error should be signaled if the existing database connection cannot be
+closed. When non-nil (this is the default value) the connection is
+closed without error checking. When FORCE is nil, an error is signaled
+if the database connection has been lost."
+ ;; TODO: just a placeholder
+ (declare (ignore database error force)))
+
+
+
+(defun status (&optional full)
+ "The function STATUS prints status information to the standard
+output, for the connected databases and initialized database types. If
+full is T, detailed status information is printed. The default value
+of full is NIL."
+ (declare (ignore full))
+ ;; TODO: table details if full is true?
+ (flet ((get-data ()
+ (let ((data '()))
+ (dolist (db (connected-databases) data)
+ (push (list (database-name db)
+ (string (database-type db))
+ (when (conn-pool db) "T" "NIL")
+ (format nil "~A" (length (database-list-tables db)))
+ (format nil "~A" (length (database-list-views db)))
+ (if (equal db *default-database*) " *" ""))
+ data))))
+ (compute-sizes (data)
+ (mapcar #'(lambda (x) (apply #'max (mapcar #'length x)))
+ (apply #'mapcar (cons #'list data))))
+ (print-separator (size)
+ (format t "~&~A" (make-string size :initial-element #\-))))
+ (let ((data (get-data)))
+ (when data
+ (let* ((titles (list "NAME" "TYPE" "POOLED" "TABLES" "VIEWS" "DEFAULT"))
+ (sizes (compute-sizes (cons titles data)))
+ (total-size (+ (apply #'+ sizes) (* 2 (1- (length titles)))))
+ (control-string (format nil "~~&~~{~{~~~AA ~}~~}" sizes)))
+ (print-separator total-size)
+ (format t control-string titles)
+ (print-separator total-size)
+ (dolist (d data) (format t control-string d))
+ (print-separator total-size))))
+ (values)))
+
+
+(defmacro with-database ((db-var connection-spec &rest connect-args) &body body)
+ "Evaluate the body in an environment, where `db-var' is bound to the
+database connection given by `connection-spec' and `connect-args'.
+The connection is automatically closed or released to the pool on exit from the body."
+ (let ((result (gensym "result-")))
+ (unless db-var (setf db-var '*default-database*))
+ `(let ((,db-var (connect ,connection-spec ,@connect-args))
+ (,result nil))
+ (unwind-protect
+ (let ((,db-var ,db-var))
+ (setf ,result (progn ,@body)))
+ (disconnect :database ,db-var))
+ ,result)))
+
+
+(defmacro with-default-database ((database) &rest body)
+ "Perform BODY with DATABASE bound as *default-database*."
+ `(progv '(*default-database*)
+ (list ,database)
+ ,@body))
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
-;;;; Name: db-interface.cl
+;;;; Name: db-interface.lisp
;;;; Purpose: Generic function definitions for DB interfaces
;;;; Programmers: Kevin M. Rosenberg based on
;;;; Original code by Pierre R. Mai. Additions from
;;;;
;;;; $Id$
;;;;
-;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;; This file, part of CLSQL, is Copyright (c) 2002-2004 by Kevin M. Rosenberg
;;;; and Copyright (c) 1999-2001 by Pierre R. Mai, and onShoreD
;;;;
;;;; CLSQL users are granted the rights to distribute and use this software
;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;; *************************************************************************
-(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
-(in-package :clsql-base-sys)
+(in-package #:clsql-base-sys)
(defgeneric database-type-load-foreign (database-type)
(:documentation
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
-;;;; Name: initialize.cl
+;;;; Name: initialize.lisp
;;;; Purpose: Initializion routines for backend
;;;; Programmers: Kevin M. Rosenberg
;;;; Date Started: May 2002
;;;;
;;;; $Id$
;;;;
-;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;; This file, part of CLSQL, is Copyright (c) 2002-2004 by Kevin M. Rosenberg
;;;; and Copyright (c) 1999-2001 by Pierre R. Mai
;;;;
;;;; CLSQL users are granted the rights to distribute and use this software
;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;; *************************************************************************
-(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
-(in-package :clsql-base-sys)
+(in-package #:clsql-base-sys)
(defvar *loaded-database-types* nil
"Contains a list of database types which have been defined/loaded.")
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: loop-extension.lisp
+;;;; Purpose: Extensions to the Loop macro for CMUCL
+;;;; Programmer: Pierre R. Mai
+;;;;
+;;;; Copyright (c) 1999-2001 Pierre R. Mai
+;;;;
+;;;; $Id$
+;;;;
+;;;; The functions in this file were orignally distributed in the
+;;;; MaiSQL package in the file sql/sql.cl
+;;;; *************************************************************************
+
+(in-package #:cl-user)
+
+;;;; MIT-LOOP extension
+
+#+(or cmu scl)
+(defun loop-record-iteration-path (variable data-type prep-phrases)
+ (let ((in-phrase nil)
+ (from-phrase nil))
+ (loop for (prep . rest) in prep-phrases
+ do
+ (case prep
+ ((:in :of)
+ (when in-phrase
+ (ansi-loop::loop-error
+ "Duplicate OF or IN iteration path: ~S." (cons prep rest)))
+ (setq in-phrase rest))
+ ((:from)
+ (when from-phrase
+ (ansi-loop::loop-error
+ "Duplicate FROM iteration path: ~S." (cons prep rest)))
+ (setq from-phrase rest))
+ (t
+ (ansi-loop::loop-error
+ "Unknown preposition: ~S." prep))))
+ (unless in-phrase
+ (ansi-loop::loop-error "Missing OF or IN iteration path."))
+ (unless from-phrase
+ (setq from-phrase '(*default-database*)))
+ (cond
+ ((consp variable)
+ (let ((query-var (ansi-loop::loop-gentemp 'loop-record-))
+ (db-var (ansi-loop::loop-gentemp 'loop-record-database-))
+ (result-set-var (ansi-loop::loop-gentemp
+ 'loop-record-result-set-))
+ (step-var (ansi-loop::loop-gentemp 'loop-record-step-)))
+ (push `(when ,result-set-var
+ (database-dump-result-set ,result-set-var ,db-var))
+ ansi-loop::*loop-epilogue*)
+ `(((,variable nil ,data-type) (,query-var ,(first in-phrase))
+ (,db-var ,(first from-phrase))
+ (,result-set-var nil)
+ (,step-var nil))
+ ((multiple-value-bind (%rs %cols)
+ (database-query-result-set ,query-var ,db-var)
+ (setq ,result-set-var %rs ,step-var (make-list %cols))))
+ ()
+ ()
+ (not (database-store-next-row ,result-set-var ,db-var ,step-var))
+ (,variable ,step-var)
+ (not ,result-set-var)
+ ()
+ (not (database-store-next-row ,result-set-var ,db-var ,step-var))
+ (,variable ,step-var))))
+ (t
+ (let ((query-var (ansi-loop::loop-gentemp 'loop-record-))
+ (db-var (ansi-loop::loop-gentemp 'loop-record-database-))
+ (result-set-var (ansi-loop::loop-gentemp
+ 'loop-record-result-set-)))
+ (push `(when ,result-set-var
+ (database-dump-result-set ,result-set-var ,db-var))
+ ansi-loop::*loop-epilogue*)
+ `(((,variable nil ,data-type) (,query-var ,(first in-phrase))
+ (,db-var ,(first from-phrase))
+ (,result-set-var nil))
+ ((multiple-value-bind (%rs %cols)
+ (database-query-result-set ,query-var ,db-var)
+ (setq ,result-set-var %rs ,variable (make-list %cols))))
+ ()
+ ()
+ (not (database-store-next-row ,result-set-var ,db-var ,variable))
+ ()
+ (not ,result-set-var)
+ ()
+ (not (database-store-next-row ,result-set-var ,db-var ,variable))
+ ()))))))
+
+#+(or cmu scl)
+(ansi-loop::add-loop-path '(record records tuple tuples)
+ 'loop-record-iteration-path
+ ansi-loop::*loop-ansi-universe*
+ :preposition-groups '((:of :in) (:from))
+ :inclusive-permitted nil)
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
-;;;; Name: package.cl
+;;;; Name: package.lisp
;;;; Purpose: Package definition for base (low-level) SQL interface
;;;; Programmers: Kevin M. Rosenberg based on
;;;; Original code by Pierre R. Mai
;;;;
;;;; $Id$
;;;;
-;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;; This file, part of CLSQL, is Copyright (c) 2002-2004 by Kevin M. Rosenberg
;;;; and Copyright (c) 1999-2001 by Pierre R. Mai
;;;;
;;;; CLSQL users are granted the rights to distribute and use this software
#:transaction-level
#:conn-pool
- ;; utils.cl
+ ;; utils.lisp
#:number-to-sql-string
#:float-to-sql-string
#:sql-escape-quotes
+
+ ;; time.lisp
+ #:bad-component
+ #:current-day
+ #:current-month
+ #:current-year
+ #:day-duration
+ #:db-timestring
+ #:decode-duration
+ #:decode-time
+ #:duration
+ #:duration+
+ #:duration<
+ #:duration<=
+ #:duration=
+ #:duration>
+ #:duration>=
+ #:duration-day
+ #:duration-hour
+ #:duration-minute
+ #:duration-month
+ #:duration-second
+ #:duration-year
+ #:duration-reduce
+ #:format-duration
+ #:format-time
+ #:get-time
+ #:interval-clear
+ #:interval-contained
+ #:interval-data
+ #:interval-edit
+ #:interval-end
+ #:interval-match
+ #:interval-push
+ #:interval-relation
+ #:interval-start
+ #:interval-type
+ #:make-duration
+ #:make-interval
+ #:make-time
+ #:merged-time
+ #:midnight
+ #:month-name
+ #:parse-date-time
+ #:parse-timestring
+ #:print-date
+ #:roll
+ #:roll-to
+ #:time
+ #:time+
+ #:time-
+ #:time-by-adding-duration
+ #:time-compare
+ #:time-difference
+ #:time-dow
+ #:time-element
+ #:time-max
+ #:time-min
+ #:time-mjd
+ #:time-msec
+ #:time-p
+ #:time-sec
+ #:time-well-formed
+ #:time-ymd
+ #:time<
+ #:time<=
+ #:time=
+ #:time>
+ #:time>=
+ #:timezone
+ #:universal-time
+ #:wall-time
+ #:wall-timestring
+ #:week-containing
+
+ ;; recording.lisp -- SQL I/O Recording
+ #:record-sql-comand
+ #:record-sql-result
+ #:add-sql-stream ; recording xx
+ #:delete-sql-stream ; recording xx
+ #:list-sql-streams ; recording xx
+ #:sql-recording-p ; recording xx
+ #:sql-stream ; recording xx
+ #:start-sql-recording ; recording xx
+ #:stop-sql-recording ; recording xx
+
+ ;; database.lisp -- Connection
+ #:*default-database-type* ; clsql-base xx
+ #:*default-database* ; classes xx
+ #:connect ; database xx
+ #:*connect-if-exists* ; database xx
+ #:connected-databases ; database xx
+ #:database ; database xx
+ #:database-name ; database xx
+ #:disconnect ; database xx
+ #:reconnect ; database
+ #:find-database ; database xx
+ #:status ; database xx
+ #:with-database
+ #:with-default-database
+
+ ;; basic-sql.lisp
+ #:query
+ #:execute-command
+ #:write-large-object
+ #:read-large-object
+ #:delete-large-object
+
+ ;; Transactions
+ #:with-transaction
+ #:commit-transaction
+ #:rollback-transaction
+ #:add-transaction-commit-hook
+ #:add-transaction-rollback-hook
+ #:commit ; transact xx
+ #:rollback ; transact xx
+ #:with-transaction ; transact xx .
+ #:start-transaction ; transact xx
+ #:in-transaction-p ; transact xx
+ #:database-start-transaction
+ #:database-abort-transaction
+ #:database-commit-transaction
+ #:transaction-level
+ #:transaction
+
))
(:documentation "This is the INTERNAL SQL-Interface package of CLSQL-BASE."))
(defpackage #:clsql-base
- (:import-from :clsql-base-sys . #1#)
+ (:import-from #:clsql-base-sys . #1#)
(:export . #1#)
(:documentation "This is the SQL-Interface package of CLSQL-BASE."))
);eval-when
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: pool.lisp
+;;;; Purpose: Support function for connection pool
+;;;; Programmers: Kevin M. Rosenberg, Marc Battyani
+;;;; Date Started: Apr 2002
+;;;;
+;;;; $Id: pool.lisp 7061 2003-09-07 06:34:45Z kevin $
+;;;;
+;;;; This file, part of CLSQL, is Copyright (c) 2002-2003 by Kevin M. Rosenberg
+;;;;
+;;;; CLSQL users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+(in-package #:clsql-base-sys)
+
+(defun make-process-lock (name)
+ #+allegro (mp:make-process-lock :name name)
+ #+scl (thread:make-lock name)
+ #+lispworks (mp:make-lock :name name)
+ #-(or allegro scl lispworks) (declare (ignore name))
+ #-(or allegro scl lispworks) nil)
+
+(defmacro with-process-lock ((lock desc) &body body)
+ #+scl `(thread:with-lock-held (,lock ,desc) ,@body)
+ #+(or allegro lispworks)
+ (declare (ignore desc))
+ #+(or allegro lispworks)
+ (let ((l (gensym)))
+ `(let ((,l ,lock))
+ #+allegro (mp:with-process-lock (,l) ,@body)
+ #+lispworks (mp:with-lock (,l) ,@body)))
+ #-(or scl allegro lispworks) (declare (ignore lock desc))
+ #-(or scl allegro lispworks) `(progn ,@body))
+
+(defvar *db-pool* (make-hash-table :test #'equal))
+(defvar *db-pool-lock* (make-process-lock "DB Pool lock"))
+
+(defclass conn-pool ()
+ ((connection-spec :accessor connection-spec :initarg :connection-spec)
+ (database-type :accessor database-type :initarg :database-type)
+ (free-connections :accessor free-connections
+ :initform (make-array 5 :fill-pointer 0 :adjustable t))
+ (all-connections :accessor all-connections
+ :initform (make-array 5 :fill-pointer 0 :adjustable t))
+ (lock :accessor conn-pool-lock
+ :initform (make-process-lock "Connection pool"))))
+
+(defun acquire-from-conn-pool (pool)
+ (or (with-process-lock ((conn-pool-lock pool) "Acquire from pool")
+ (and (plusp (length (free-connections pool)))
+ (vector-pop (free-connections pool))))
+ (let ((conn (connect (connection-spec pool)
+ :database-type (database-type pool)
+ :if-exists :new)))
+ (with-process-lock ((conn-pool-lock pool) "Acquire from pool")
+ (vector-push-extend conn (all-connections pool))
+ (setf (conn-pool conn) pool))
+ conn)))
+
+(defun release-to-conn-pool (conn)
+ (let ((pool (conn-pool conn)))
+ (with-process-lock ((conn-pool-lock pool) "Release to pool")
+ (vector-push-extend conn (free-connections pool)))))
+
+(defun clear-conn-pool (pool)
+ (with-process-lock ((conn-pool-lock pool) "Clear pool")
+ (loop for conn across (all-connections pool)
+ do (setf (conn-pool conn) nil)
+ (disconnect :database conn))
+ (setf (fill-pointer (free-connections pool)) 0)
+ (setf (fill-pointer (all-connections pool)) 0))
+ nil)
+
+(defun find-or-create-connection-pool (connection-spec database-type)
+ "Find connection pool in hash table, creates a new connection pool
+if not found"
+ (with-process-lock (*db-pool-lock* "Find-or-create connection")
+ (let* ((key (list connection-spec database-type))
+ (conn-pool (gethash key *db-pool*)))
+ (unless conn-pool
+ (setq conn-pool (make-instance 'conn-pool
+ :connection-spec connection-spec
+ :database-type database-type))
+ (setf (gethash key *db-pool*) conn-pool))
+ conn-pool)))
+
+(defun acquire-from-pool (connection-spec database-type &optional pool)
+ (unless (typep pool 'conn-pool)
+ (setf pool (find-or-create-connection-pool connection-spec database-type)))
+ (acquire-from-conn-pool pool))
+
+(defun release-to-pool (database)
+ (release-to-conn-pool database))
+
+(defun disconnect-pooled (&optional clear)
+ "Disconnects all connections in the pool."
+ (with-process-lock (*db-pool-lock* "Disconnect pooled")
+ (maphash
+ #'(lambda (key conn-pool)
+ (declare (ignore key))
+ (clear-conn-pool conn-pool))
+ *db-pool*)
+ (when clear (clrhash *db-pool*)))
+ t)
+
+;(defun pool-start-sql-recording (pool &key (types :command))
+; "Start all stream in the pool recording actions of TYPES"
+; (dolist (con (pool-connections pool))
+; (start-sql-recording :type types
+; :database (connection-database con))))
+
+;(defun pool-stop-sql-recording (pool &key (types :command))
+; "Start all stream in the pool recording actions of TYPES"
+; (dolist (con (pool-connections pool))
+; (stop-sql-recording :type types
+; :database (connection-database con))))
+
+;(defmacro with-database-connection (pool &body body)
+; `(let ((connection (obtain-connection ,pool))
+; (results nil))
+; (unwind-protect
+; (with-database ((connection-database connection))
+; (setq results (multiple-value-list (progn ,@body))))
+; (release-connection connection))
+; (values-list results)))
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; ======================================================================
+;;;; $Id: $
+;;;;
+;;;; Description ==========================================================
+;;;; ======================================================================
+;;;;
+;;;; CLSQL-USQL broadcast streams which can be used to monitor the
+;;;; flow of commands to, and results from, a database.
+;;;;
+;;;; ======================================================================
+
+(in-package #:clsql-base-sys)
+
+(defun start-sql-recording (&key (type :commands) (database *default-database*))
+ "Begin recording SQL command or result traffic. By default the
+broadcast stream is just *STANDARD-OUTPUT* but this can be modified
+using ADD-SQL-STREAM or DELETE-SQL-STREAM. TYPE determines whether SQL
+command or result traffic is recorded, or both. It must be either
+:commands, :results or :both, and defaults to :commands. DATABASE
+defaults to *default-database*."
+ (when (or (eq type :both) (eq type :commands))
+ (setf (command-recording-stream database)
+ (make-broadcast-stream *standard-output*)))
+ (when (or (eq type :both) (eq type :results))
+ (setf (result-recording-stream database)
+ (make-broadcast-stream *standard-output*)))
+ (values))
+
+(defun stop-sql-recording (&key (type :commands) (database *default-database*))
+ "Stops recording of SQL command or result traffic. TYPE determines
+whether to stop SQL command or result traffic, or both. It must be
+either :commands, :results or :both, defaulting to :commands. DATABASE
+defaults to *default-database*."
+ (when (or (eq type :both) (eq type :commands))
+ (setf (command-recording-stream database) nil))
+ (when (or (eq type :both) (eq type :results))
+ (setf (result-recording-stream database) nil))
+ (values))
+
+(defun sql-recording-p (&key (type :commands) (database *default-database*))
+ "Returns t if recording of TYPE of SQL interaction specified is
+enabled. TYPE must be either :commands, :results, :both or :either.
+DATABASE defaults to *default-database*."
+ (when (or (and (eq type :commands)
+ (command-recording-stream database))
+ (and (eq type :results)
+ (result-recording-stream database))
+ (and (eq type :both)
+ (result-recording-stream database)
+ (command-recording-stream database))
+ (and (eq type :either)
+ (or (result-recording-stream database)
+ (command-recording-stream database))))
+ t))
+
+(defun add-sql-stream (stream &key (type :commands)
+ (database *default-database*))
+ "Add the given STREAM as a component stream for the recording
+broadcast stream for the given SQL interaction TYPE. TYPE must be
+either :commands, :results, or :both, defaulting to :commands.
+DATABASE defaults to *default-database*."
+ (when (or (eq type :both) (eq type :commands))
+ (unless (member stream
+ (list-sql-streams :type :commands :database database))
+ (setf (command-recording-stream database)
+ (apply #'make-broadcast-stream
+ (cons stream (list-sql-streams :type :commands
+ :database database))))))
+ (when (or (eq type :both) (eq type :results))
+ (unless (member stream (list-sql-streams :type :results :database database))
+ (setf (result-recording-stream database)
+ (apply #'make-broadcast-stream
+ (cons stream (list-sql-streams :type :results
+ :database database))))))
+ stream)
+
+(defun delete-sql-stream (stream &key (type :commands)
+ (database *default-database*))
+ "Removes the given STREAM from the recording broadcast stream for
+the given TYPE of SQL interaction. TYPE must be either :commands,
+:results, or :both, defaulting to :commands. DATABASE defaults to
+*default-database*."
+ (when (or (eq type :both) (eq type :commands))
+ (setf (command-recording-stream database)
+ (apply #'make-broadcast-stream
+ (remove stream (list-sql-streams :type :commands
+ :database database)))))
+ (when (or (eq type :both) (eq type :results))
+ (setf (result-recording-stream database)
+ (apply #'make-broadcast-stream
+ (remove stream (list-sql-streams :type :results
+ :database database)))))
+ stream)
+
+(defun list-sql-streams (&key (type :commands) (database *default-database*))
+ "Returns the set of streams which the recording broadcast stream
+send SQL interactions of the given TYPE sends data. TYPE must be
+either :commands, :results, or :both, defaulting to :commands.
+DATABASE defaults to *default-database*."
+ (let ((crs (command-recording-stream database))
+ (rrs (result-recording-stream database)))
+ (cond
+ ((eq type :commands)
+ (when crs (broadcast-stream-streams crs)))
+ ((eq type :results)
+ (when rrs (broadcast-stream-streams rrs)))
+ ((eq type :both)
+ (append (when crs (broadcast-stream-streams crs))
+ (when rrs (broadcast-stream-streams rrs))))
+ (t
+ (error "Unknown recording type. ~A" type)))))
+
+(defun sql-stream (&key (type :commands) (database *default-database*))
+ "Returns the broadcast streams used for recording SQL commands or
+results traffic. TYPE must be either :commands or :results defaulting
+to :commands while DATABASE defaults to *default-database*."
+ (cond
+ ((eq type :commands)
+ (command-recording-stream database))
+ ((eq type :results)
+ (result-recording-stream database))
+ (t
+ (error "Unknown recording type. ~A" type))))
+
+(defun record-sql-command (expr database)
+ (if database
+ (with-slots (command-recording-stream)
+ database
+ (if command-recording-stream
+ (format command-recording-stream "~&;; ~A ~A => ~A~%"
+ (iso-timestring (get-time))
+ (database-name database)
+ expr)))))
+
+(defun record-sql-result (res database)
+ (if database
+ (with-slots (result-recording-stream)
+ database
+ (if result-recording-stream
+ (format result-recording-stream "~&;; ~A ~A <= ~A~%"
+ (iso-timestring (get-time))
+ (database-name database)
+ res)))))
+
+
+
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; ======================================================================
+;;;; $Id: $
+;;;; ======================================================================
+;;;;
+;;;; Description ==========================================================
+;;;; ======================================================================
+;;;;
+;;;; A variety of structures and function for creating and
+;;;; manipulating dates, times, durations and intervals for
+;;;; CLSQL-USQL.
+;;;;
+;;;; This file was originally part of ODCL and is Copyright (c) 2002 -
+;;;; 2003 onShore Development, Inc.
+;;;;
+;;;; ======================================================================
+
+
+(in-package #:clsql-base-sys)
+
+
+;; ------------------------------------------------------------
+;; Months
+
+(defvar *month-keywords*
+ '(:january :february :march :april :may :june :july :august :september
+ :october :november :december))
+
+(defvar *month-names*
+ '("" "January" "February" "March" "April" "May" "June" "July" "August"
+ "September" "October" "November" "December"))
+
+(defun month-name (month-index)
+ (nth month-index *month-names*))
+
+(defun ordinal-month (month-keyword)
+ "Return the zero-based month number for the given MONTH keyword."
+ (position month-keyword *month-keywords*))
+
+
+;; ------------------------------------------------------------
+;; Days
+
+(defvar *day-keywords*
+ '(:sunday :monday :tuesday :wednesday :thursday :friday :saturday))
+
+(defvar *day-names*
+ '("Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday"))
+
+(defun day-name (day-index)
+ (nth day-index *day-names*))
+
+(defun ordinal-day (day-keyword)
+ "Return the zero-based day number for the given DAY keyword."
+ (position day-keyword *day-keywords*))
+
+
+;; ------------------------------------------------------------
+;; time classes: wall-time, duration
+
+(eval-when (:compile-toplevel :load-toplevel)
+
+(defstruct (wall-time (:conc-name time-)
+ (:constructor %make-wall-time)
+ (:print-function %print-wall-time))
+ (mjd 0 :type fixnum)
+ (second 0 :type fixnum))
+
+(defun %print-wall-time (time stream depth)
+ (declare (ignore depth))
+ (format stream "#<WALL-TIME: ~a>" (format-time nil time)))
+
+(defstruct (duration (:constructor %make-duration)
+ (:print-function %print-duration))
+ (year 0 :type fixnum)
+ (month 0 :type fixnum)
+ (day 0 :type fixnum)
+ (hour 0 :type fixnum)
+ (second 0 :type fixnum)
+ (minute 0 :type fixnum))
+
+(defun %print-duration (duration stream depth)
+ (declare (ignore depth))
+ (format stream "#<DURATION: ~a>"
+ (format-duration nil duration :precision :second)))
+
+);eval-when
+
+
+;; ------------------------------------------------------------
+;; Constructors
+
+(defun make-time (&key (year 0) (month 1) (day 1) (hour 0) (minute 0)
+ (second 0) (offset 0))
+ (let ((mjd (gregorian-to-mjd month day year))
+ (sec (+ (* hour 60 60)
+ (* minute 60)
+ second (- offset))))
+ (multiple-value-bind (day-add raw-sec)
+ (floor sec (* 60 60 24))
+ (%make-wall-time :mjd (+ mjd day-add) :second raw-sec))))
+
+(defun copy-time (time)
+ (%make-wall-time :mjd (time-mjd time)
+ :second (time-second time)))
+
+(defun get-time ()
+ "Return a pair: (GREGORIAN DAY . TIME-OF-DAY)"
+ (multiple-value-bind (second minute hour day mon year)
+ (decode-universal-time (get-universal-time))
+ (make-time :year year :month mon :day day :hour hour :minute minute
+ :second second)))
+
+(defun make-duration (&key (year 0) (month 0) (day 0) (hour 0) (minute 0)
+ (second 0))
+ (multiple-value-bind (minute-add second-60)
+ (floor second 60)
+ (multiple-value-bind (hour-add minute-60)
+ (floor (+ minute minute-add) 60)
+ (multiple-value-bind (day-add hour-24)
+ (floor (+ hour hour-add) 24)
+ (%make-duration :year year :month month :day (+ day day-add)
+ :hour hour-24
+ :minute minute-60
+ :second second-60)))))
+
+
+;; ------------------------------------------------------------
+;; Accessors
+
+(defun time-hms (time)
+ (multiple-value-bind (hourminute second)
+ (floor (time-second time) 60)
+ (multiple-value-bind (hour minute)
+ (floor hourminute 60)
+ (values hour minute second))))
+
+(defun time-ymd (time)
+ (destructuring-bind (minute day year)
+ (mjd-to-gregorian (time-mjd time))
+ (values year minute day)))
+
+(defun time-dow (time)
+ "Return the 0 indexed Day of the week starting with Sunday"
+ (mod (+ 3 (time-mjd time)) 7))
+
+(defun decode-time (time)
+ "returns the decoded time as multiple values: second, minute, hour, day,
+month, year, integer day-of-week"
+ (multiple-value-bind (year month day)
+ (time-ymd time)
+ (multiple-value-bind (hour minute second)
+ (time-hms time)
+ (values second minute hour day month year (mod (+ (time-mjd time) 3) 7)))))
+
+;; duration specific
+(defun duration-reduce (duration precision)
+ (ecase precision
+ (:second
+ (+ (duration-second duration)
+ (* (duration-reduce duration :minute) 60)))
+ (:minute
+ (+ (duration-minute duration)
+ (* (duration-reduce duration :hour) 60)))
+ (:hour
+ (+ (duration-hour duration)
+ (* (duration-reduce duration :day) 24)))
+ (:day
+ (duration-day duration))))
+
+
+;; ------------------------------------------------------------
+;; Arithemetic and comparators
+
+(defun duration= (duration-a duration-b)
+ (= (duration-reduce duration-a :second)
+ (duration-reduce duration-b :second)))
+
+(defun duration< (duration-a duration-b)
+ (< (duration-reduce duration-a :second)
+ (duration-reduce duration-b :second)))
+
+(defun duration<= (duration-a duration-b)
+ (<= (duration-reduce duration-a :second)
+ (duration-reduce duration-b :second)))
+
+(defun duration>= (x y)
+ (duration<= y x))
+
+(defun duration> (x y)
+ (duration< y x))
+
+(defun %time< (x y)
+ (let ((mjd-x (time-mjd x))
+ (mjd-y (time-mjd y)))
+ (if (/= mjd-x mjd-y)
+ (< mjd-x mjd-y)
+ (< (time-second x) (time-second y)))))
+
+(defun %time>= (x y)
+ (if (/= (time-mjd x) (time-mjd y))
+ (>= (time-mjd x) (time-mjd y))
+ (>= (time-second x) (time-second y))))
+
+(defun %time<= (x y)
+ (if (/= (time-mjd x) (time-mjd y))
+ (<= (time-mjd x) (time-mjd y))
+ (<= (time-second x) (time-second y))))
+
+(defun %time> (x y)
+ (if (/= (time-mjd x) (time-mjd y))
+ (> (time-mjd x) (time-mjd y))
+ (> (time-second x) (time-second y))))
+
+(defun %time= (x y)
+ (and (= (time-mjd x) (time-mjd y))
+ (= (time-second x) (time-second y))))
+
+(defun time= (number &rest more-numbers)
+ "Returns T if all of its arguments are numerically equal, NIL otherwise."
+ (do ((nlist more-numbers (cdr nlist)))
+ ((atom nlist) t)
+ (declare (list nlist))
+ (if (not (%time= (car nlist) number)) (return nil))))
+
+(defun time/= (number &rest more-numbers)
+ "Returns T if no two of its arguments are numerically equal, NIL otherwise."
+ (do* ((head number (car nlist))
+ (nlist more-numbers (cdr nlist)))
+ ((atom nlist) t)
+ (declare (list nlist))
+ (unless (do* ((nl nlist (cdr nl)))
+ ((atom nl) t)
+ (declare (list nl))
+ (if (%time= head (car nl)) (return nil)))
+ (return nil))))
+
+(defun time< (number &rest more-numbers)
+ "Returns T if its arguments are in strictly increasing order, NIL otherwise."
+ (do* ((n number (car nlist))
+ (nlist more-numbers (cdr nlist)))
+ ((atom nlist) t)
+ (declare (list nlist))
+ (if (not (%time< n (car nlist))) (return nil))))
+
+(defun time> (number &rest more-numbers)
+ "Returns T if its arguments are in strictly decreasing order, NIL otherwise."
+ (do* ((n number (car nlist))
+ (nlist more-numbers (cdr nlist)))
+ ((atom nlist) t)
+ (declare (list nlist))
+ (if (not (%time> n (car nlist))) (return nil))))
+
+(defun time<= (number &rest more-numbers)
+ "Returns T if arguments are in strictly non-decreasing order, NIL otherwise."
+ (do* ((n number (car nlist))
+ (nlist more-numbers (cdr nlist)))
+ ((atom nlist) t)
+ (declare (list nlist))
+ (if (not (%time<= n (car nlist))) (return nil))))
+
+(defun time>= (number &rest more-numbers)
+ "Returns T if arguments are in strictly non-increasing order, NIL otherwise."
+ (do* ((n number (car nlist))
+ (nlist more-numbers (cdr nlist)))
+ ((atom nlist) t)
+ (declare (list nlist))
+ (if (not (%time>= n (car nlist))) (return nil))))
+
+(defun time-max (number &rest more-numbers)
+ "Returns the greatest of its arguments."
+ (do ((nlist more-numbers (cdr nlist))
+ (result number))
+ ((null nlist) (return result))
+ (declare (list nlist))
+ (if (%time> (car nlist) result) (setq result (car nlist)))))
+
+(defun time-min (number &rest more-numbers)
+ "Returns the least of its arguments."
+ (do ((nlist more-numbers (cdr nlist))
+ (result number))
+ ((null nlist) (return result))
+ (declare (list nlist))
+ (if (%time< (car nlist) result) (setq result (car nlist)))))
+
+(defun time-compare (time-a time-b)
+ (let ((mjd-a (time-mjd time-a))
+ (mjd-b (time-mjd time-b))
+ (sec-a (time-second time-a))
+ (sec-b (time-second time-b)))
+ (if (= mjd-a mjd-b)
+ (if (= sec-a sec-b)
+ :equal
+ (if (< sec-a sec-b)
+ :less-than
+ :greater-than))
+ (if (< mjd-a mjd-b)
+ :less-than
+ :greater-than))))
+
+
+;; ------------------------------------------------------------
+;; Formatting and output
+
+(defvar +decimal-printer+ #(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9))
+
+(defun db-timestring (time)
+ "return the string to store the given time in the database"
+ (declare (optimize (speed 3)))
+ (let ((output (copy-seq "'XXXX-XX-XX XX:XX:XX'")))
+ (flet ((inscribe-base-10 (output offset size decimal)
+ (declare (type fixnum offset size decimal)
+ (type (simple-vector 10) +decimal-printer+))
+ (dotimes (x size)
+ (declare (type fixnum x)
+ (optimize (safety 0)))
+ (multiple-value-bind (next this)
+ (floor decimal 10)
+ (setf (aref output (+ (- size x 1) offset))
+ (aref +decimal-printer+ this))
+ (setf decimal next)))))
+ (multiple-value-bind (second minute hour day month year)
+ (decode-time time)
+ (inscribe-base-10 output 1 4 year)
+ (inscribe-base-10 output 6 2 month)
+ (inscribe-base-10 output 9 2 day)
+ (inscribe-base-10 output 12 2 hour)
+ (inscribe-base-10 output 15 2 minute)
+ (inscribe-base-10 output 18 2 second)
+ output))))
+
+(defun iso-timestring (time)
+ "return the string to store the given time in the database"
+ (declare (optimize (speed 3)))
+ (let ((output (copy-seq "XXXX-XX-XX XX:XX:XX")))
+ (flet ((inscribe-base-10 (output offset size decimal)
+ (declare (type fixnum offset size decimal)
+ (type (simple-vector 10) +decimal-printer+))
+ (dotimes (x size)
+ (declare (type fixnum x)
+ (optimize (safety 0)))
+ (multiple-value-bind (next this)
+ (floor decimal 10)
+ (setf (aref output (+ (- size x 1) offset))
+ (aref +decimal-printer+ this))
+ (setf decimal next)))))
+ (multiple-value-bind (second minute hour day month year)
+ (decode-time time)
+ (inscribe-base-10 output 0 4 year)
+ (inscribe-base-10 output 5 2 month)
+ (inscribe-base-10 output 8 2 day)
+ (inscribe-base-10 output 11 2 hour)
+ (inscribe-base-10 output 14 2 minute)
+ (inscribe-base-10 output 17 2 second)
+ output))))
+
+
+;; ------------------------------------------------------------
+;; Intervals
+
+(defstruct interval
+ (start nil)
+ (end nil)
+ (contained nil)
+ (type nil)
+ (data nil))
+
+;; fix : should also return :contains / :contained
+
+(defun interval-relation (x y)
+ "Compare the relationship of node x to node y. Returns either
+:contained :contains :follows :overlaps or :precedes."
+ (let ((xst (interval-start x))
+ (xend (interval-end x))
+ (yst (interval-start y))
+ (yend (interval-end y)))
+ (case (time-compare xst yst)
+ (:equal
+ (case (time-compare xend yend)
+ (:less-than
+ :contained)
+ ((:equal :greater-than)
+ :contains)))
+ (:greater-than
+ (case (time-compare xst yend)
+ ((:equal :greater-than)
+ :follows)
+ (:less-than
+ (case (time-compare xend yend)
+ ((:less-than :equal)
+ :contained)
+ ((:greater-than)
+ :overlaps)))))
+ (:less-than
+ (case (time-compare xend yst)
+ ((:equal :less-than)
+ :precedes)
+ (:greater-than
+ (case (time-compare xend yend)
+ (:less-than
+ :overlaps)
+ ((:equal :greater-than)
+ :contains))))))))
+
+;; ------------------------------------------------------------
+;; interval lists
+
+(defun sort-interval-list (list)
+ (sort list (lambda (x y)
+ (case (interval-relation x y)
+ ((:precedes :contains) t)
+ ((:follows :overlaps :contained) nil)))))
+
+;; interval push will return its list of intervals in strict order.
+(defun interval-push (interval-list interval &optional container-rule)
+ (declare (ignore container-rule))
+ (let ((sorted-list (sort-interval-list interval-list)))
+ (dotimes (x (length sorted-list))
+ (let ((elt (nth x sorted-list)))
+ (case (interval-relation elt interval)
+ (:follows
+ (return-from interval-push (insert-at-index x sorted-list interval)))
+ (:contains
+ (return-from interval-push
+ (replace-at-index x sorted-list
+ (make-interval :start (interval-start elt)
+ :end (interval-end elt)
+ :type (interval-type elt)
+ :contained (interval-push (interval-contained elt) interval)
+ :data (interval-data elt)))))
+ ((:overlaps :contained)
+ (error "Overlap")))))
+ (append sorted-list (list interval))))
+
+;; interval lists
+
+(defun interval-match (list time)
+ "Return the index of the first interval in list containing time"
+ ;; this depends on ordering of intervals!
+ (dotimes (x (length list))
+ (let ((elt (nth x list)))
+ (when (and (time<= (interval-start elt) time)
+ (time< time (interval-end elt)))
+ (return-from interval-match x))
+ (when (time< time (interval-start elt))
+ (return-from interval-match nil)))))
+
+(defun interval-clear (list time)
+ ;(cmsg "List = ~s" list)
+ (dotimes (x (length list))
+ (let ((elt (nth x list)))
+ (when (and (time<= (interval-start elt) time)
+ (time< time (interval-end elt)))
+ (if (interval-match (interval-contained elt) time)
+ (return-from interval-clear
+ (replace-at-index x list
+ (make-interval :start (interval-start elt)
+ :end (interval-end elt)
+ :type (interval-type elt)
+ :contained (interval-clear (interval-contained elt) time)
+ :data (interval-data elt))))
+ (return-from interval-clear
+ (delete-at-index x list)))))))
+
+(defun interval-edit (list time start end &optional tag)
+ "Attempts to modify the most deeply nested interval in list which
+begins at time. If no changes are made, returns nil."
+ ;; function required sorted interval list
+ (let ((list (sort-interval-list list)))
+ (if (null list) nil
+ (dotimes (x (length list))
+ (let ((elt (nth x list)))
+ (when (and (time<= (interval-start elt) time)
+ (time< time (interval-end elt)))
+ (or (interval-edit (interval-contained elt) time start end tag)
+ (cond ((and (< 0 x)
+ (time< start (interval-end (nth (1- x) list))))
+ (error "Overlap of previous interval"))
+ ((and (< x (1- (length list)))
+ (time< (interval-start (nth (1+ x) list)) end))
+ (error "~S ~S ~S ~S Overlap of next interval" x (length list) (interval-start (nth (1+ x) list)) end ))
+ ((time= (interval-start elt) time)
+ (return-from interval-edit
+ (replace-at-index x list
+ (make-interval :start start
+ :end end
+ :type (interval-type elt)
+ :contained (restrict-intervals (interval-contained elt) start end)
+ :data (or tag (interval-data elt))))))))))))))
+
+(defun restrict-intervals (list start end &aux newlist)
+ (let ((test-interval (make-interval :start start :end end)))
+ (dolist (elt list)
+ (when (equal :contained
+ (interval-relation elt test-interval))
+ (push elt newlist)))
+ (nreverse newlist)))
+
+;;; utils from odcl/list.lisp
+
+(defun replace-at-index (idx list elt)
+ (cond ((= idx 0)
+ (cons elt (cdr list)))
+ ((= idx (1- (length list)))
+ (append (butlast list) (list elt)))
+ (t
+ (append (subseq list 0 idx)
+ (list elt)
+ (subseq list (1+ idx))))))
+
+(defun insert-at-index (idx list elt)
+ (cond ((= idx 0)
+ (cons elt list))
+ ((= idx (1- (length list)))
+ (append list (list elt)))
+ (t
+ (append (subseq list 0 idx)
+ (list elt)
+ (subseq list idx)))))
+
+(defun delete-at-index (idx list)
+ (cond ((= idx 0)
+ (cdr list))
+ ((= idx (1- (length list)))
+ (butlast list))
+ (t
+ (append (subseq list 0 idx)
+ (subseq list (1+ idx))))))
+
+
+;; ------------------------------------------------------------
+;; return MJD for Gregorian date
+
+(defun gregorian-to-mjd (month day year)
+ (let ((b 0)
+ (month-adj month)
+ (year-adj (if (< year 0)
+ (+ year 1)
+ year))
+ d
+ c)
+ (when (< month 3)
+ (incf month-adj 12)
+ (decf year-adj))
+ (unless (or (< year 1582)
+ (and (= year 1582)
+ (or (< month 10)
+ (and (= month 10)
+ (< day 15)))))
+ (let ((a (floor (/ year-adj 100))))
+ (setf b (+ (- 2 a) (floor (/ a 4))))))
+ (if (< year-adj 0)
+ (setf c (floor (- (* 365.25d0 year-adj) 679006.75d0)))
+ (setf c (floor (- (* 365.25d0 year-adj) 679006d0))))
+ (setf d (floor (* 30.6001 (+ 1 month-adj))))
+ ;; (cmsg "b ~s c ~s d ~s day ~s" b c d day)
+ (+ b c d day)))
+
+;; convert MJD to Gregorian date
+
+(defun mjd-to-gregorian (mjd)
+ (let (z r g a b c year month day)
+ (setf z (floor (+ mjd 678882)))
+ (setf r (- (+ mjd 678882) z))
+ (setf g (- z .25))
+ (setf a (floor (/ g 36524.25)))
+ (setf b (- a (floor (/ a 4))))
+ (setf year (floor (/ (+ b g) 365.25)))
+ (setf c (- (+ b z) (floor (* 365.25 year))))
+ (setf month (truncate (/ (+ (* 5 c) 456) 153)))
+ (setf day (+ (- c (truncate (/ (- (* 153 month) 457) 5))) r))
+ (when (> month 12)
+ (incf year)
+ (decf month 12))
+ (list month day year)))
+
+(defun duration+ (time &rest durations)
+ "Add each DURATION to TIME, returning a new wall-time value."
+ (let ((year (duration-year time))
+ (month (duration-month time))
+ (day (duration-day time))
+ (hour (duration-hour time))
+ (minute (duration-minute time))
+ (second (duration-second time)))
+ (dolist (duration durations)
+ (incf year (duration-year duration))
+ (incf month (duration-month duration))
+ (incf day (duration-day duration))
+ (incf hour (duration-hour duration))
+ (incf minute (duration-minute duration))
+ (incf second (duration-second duration)))
+ (make-duration :year year :month month :day day :hour hour :minute minute
+ :second second)))
+
+(defun duration- (duration &rest durations)
+ "Subtract each DURATION from TIME, returning a new duration value."
+ (let ((year (duration-year duration))
+ (month (duration-month duration))
+ (day (duration-day duration))
+ (hour (duration-hour duration))
+ (minute (duration-minute duration))
+ (second (duration-second duration)))
+ (dolist (duration durations)
+ (decf year (duration-year duration))
+ (decf month (duration-month duration))
+ (decf day (duration-day duration))
+ (decf hour (duration-hour duration))
+ (decf minute (duration-minute duration))
+ (decf second (duration-second duration)))
+ (make-duration :year year :month month :day day :hour hour :minute minute
+ :second second)))
+
+;; Date + Duration
+
+(defun time+ (time &rest durations)
+ "Add each DURATION to TIME, returning a new wall-time value."
+ (let ((new-time (copy-time time)))
+ (dolist (duration durations)
+ (roll new-time
+ :year (duration-year duration)
+ :month (duration-month duration)
+ :day (duration-day duration)
+ :hour (duration-hour duration)
+ :minute (duration-minute duration)
+ :second (duration-second duration)
+ :destructive t))
+ new-time))
+
+(defun time- (time &rest durations)
+ "Subtract each DURATION from TIME, returning a new wall-time value."
+ (let ((new-time (copy-time time)))
+ (dolist (duration durations)
+ (roll new-time
+ :year (- (duration-year duration))
+ :month (- (duration-month duration))
+ :day (- (duration-day duration))
+ :hour (- (duration-hour duration))
+ :minute (- (duration-minute duration))
+ :second (- (duration-second duration))
+ :destructive t))
+ new-time))
+
+(defun time-difference (time1 time2)
+ "Returns a DURATION representing the difference between TIME1 and
+TIME2."
+ (flet ((do-diff (time1 time2)
+
+ (let (day-diff sec-diff)
+ (setf day-diff (- (time-mjd time2)
+ (time-mjd time1)))
+ (if (> day-diff 0)
+ (progn (decf day-diff)
+ (setf sec-diff (+ (time-second time2)
+ (- (* 60 60 24)
+ (time-second time1)))))
+ (setf sec-diff (- (time-second time2)
+ (time-second time1))))
+ (make-duration :day day-diff
+ :second sec-diff))))
+ (if (time< time1 time2)
+ (do-diff time1 time2)
+ (do-diff time2 time1))))
+
+(defun format-time (stream time &key format
+ (date-separator "-")
+ (time-separator ":")
+ (internal-separator " "))
+ "produces on stream the timestring corresponding to the wall-time
+with the given options"
+ (multiple-value-bind (second minute hour day month year dow)
+ (decode-time time)
+ (case format
+ (:pretty
+ (format stream "~A ~A, ~A ~D, ~D"
+ (pretty-time hour minute)
+ (day-name dow)
+ (month-name month)
+ day
+ year))
+ (:short-pretty
+ (format stream "~A, ~D/~D/~D"
+ (pretty-time hour minute)
+ month day year))
+ (:iso
+ (let ((string (iso-timestring time)))
+ (if stream
+ (write-string string stream)
+ string)))
+ (t
+ (format stream "~2,'0D~A~2,'0D~A~2,'0D~A~2,'0D~A~2,'0D~A~2,'0D"
+ year date-separator month date-separator day
+ internal-separator hour time-separator minute time-separator
+ second)))))
+
+(defun pretty-time (hour minute)
+ (cond
+ ((eq hour 0)
+ (format nil "12:~2,'0D AM" minute))
+ ((eq hour 12)
+ (format nil "12:~2,'0D PM" minute))
+ ((< hour 12)
+ (format nil "~D:~2,'0D AM" hour minute))
+ ((and (> hour 12) (< hour 24))
+ (format nil "~D:~2,'0D PM" (- hour 12) minute))
+ (t
+ (error "pretty-time got bad hour"))))
+
+(defun leap-days-in-days (days)
+ ;; return the number of leap days between Mar 1 2000 and
+ ;; (Mar 1 2000) + days, where days can be negative
+ (if (< days 0)
+ (ceiling (/ (- days) (* 365 4)))
+ (floor (/ days (* 365 4)))))
+
+(defun current-year ()
+ (third (mjd-to-gregorian (time-mjd (get-time)))))
+
+(defun current-day ()
+ (second (mjd-to-gregorian (time-mjd (get-time)))))
+
+(defun current-month ()
+ (first (mjd-to-gregorian (time-mjd (get-time)))))
+
+(defun parse-date-time (string)
+ "parses date like 08/08/01, 8.8.2001, eg"
+ (when (> (length string) 1)
+ (let ((m (current-month))
+ (d (current-day))
+ (y (current-year)))
+ (let ((integers (mapcar #'parse-integer (hork-integers string))))
+ (case (length integers)
+ (1
+ (setf y (car integers)))
+ (2
+ (setf m (car integers))
+ (setf y (cadr integers)))
+ (3
+ (setf m (car integers))
+ (setf d (cadr integers))
+ (setf y (caddr integers)))
+ (t
+ (return-from parse-date-time))))
+ (when (< y 100)
+ (incf y 2000))
+ (make-time :year y :month m :day d))))
+
+(defun hork-integers (input)
+ (let ((output '())
+ (start 0))
+ (dotimes (x (length input))
+ (unless (<= 48 (char-code (aref input x)) 57)
+ (push (subseq input start x) output)
+ (setf start (1+ x))))
+ (nreverse (push (subseq input start) output))))
+
+(defun merged-time (day time-of-day)
+ (%make-wall-time :mjd (time-mjd day)
+ :second (time-second time-of-day)))
+
+(defun time-meridian (hours)
+ (cond ((= hours 0)
+ (values 12 "AM"))
+ ((= hours 12)
+ (values 12 "PM"))
+ ((< 12 hours)
+ (values (- hours 12) "PM"))
+ (t
+ (values hours "AM"))))
+
+(defun print-date (time &optional (style :daytime))
+ (multiple-value-bind (second minute hour day month year dow)
+ (decode-time time)
+ (declare (ignore second))
+ (multiple-value-bind (hours meridian)
+ (time-meridian hour)
+ (ecase style
+ (:time-of-day
+ ;; 2:00 PM
+ (format nil "~d:~2,'0d ~a" hours minute meridian))
+ (:long-day
+ ;; October 11th, 2000
+ (format nil "~a ~d, ~d" (month-name month) day year))
+ (:month
+ ;; October
+ (month-name month))
+ (:month-year
+ ;; October 2000
+ (format nil "~a ~d" (month-name month) year))
+ (:full
+ ;; 11:08 AM, November 22, 2002
+ (format nil "~d:~2,'0d ~a, ~a ~d, ~d"
+ hours minute meridian (month-name month) day year))
+ (:full+weekday
+ ;; 11:09 AM Friday, November 22, 2002
+ (format nil "~d:~2,'0d ~a ~a, ~a ~d, ~d"
+ hours minute meridian (nth dow *day-names*)
+ (month-name month) day year))
+ (:daytime
+ ;; 11:09 AM, 11/22/2002
+ (format-time nil time :format :short-pretty))
+ (:day
+ ;; 11/22/2002
+ (format nil "~d/~d/~d" month day year))))))
+
+(defun time-element (time element)
+ (multiple-value-bind (second minute hour day month year dow)
+ (decode-time time)
+ (ecase element
+ (:seconds
+ second)
+ (:minutes
+ minute)
+ (:hours
+ hour)
+ (:day-of-month
+ day)
+ (:integer-day-of-week
+ dow)
+ (:day-of-week
+ (nth dow *day-keywords*))
+ (:month
+ month)
+ (:year
+ year))))
+
+(defun format-duration (stream duration &key (precision :minute))
+ (let ((second (duration-second duration))
+ (minute (duration-minute duration))
+ (hour (duration-hour duration))
+ (day (duration-day duration))
+ (return (null stream))
+ (stream (or stream (make-string-output-stream))))
+ (ecase precision
+ (:day
+ (setf hour 0 second 0 minute 0))
+ (:hour
+ (setf second 0 minute 0))
+ (:minute
+ (setf second 0))
+ (:second
+ t))
+ (if (= 0 day hour minute)
+ (format stream "0 minutes")
+ (let ((sent? nil))
+ (when (< 0 day)
+ (format stream "~d day~p" day day)
+ (setf sent? t))
+ (when (< 0 hour)
+ (when sent?
+ (write-char #\Space stream))
+ (format stream "~d hour~p" hour hour)
+ (setf sent? t))
+ (when (< 0 minute)
+ (when sent?
+ (write-char #\Space stream))
+ (format stream "~d min~p" minute minute)
+ (setf sent? t))
+ (when (< 0 second)
+ (when sent?
+ (write-char #\Space stream))
+ (format stream "~d sec~p" second second))))
+ (when return
+ (get-output-stream-string stream))))
+
+(defgeneric midnight (self))
+(defmethod midnight ((self wall-time))
+ "truncate hours, minutes and seconds"
+ (%make-wall-time :mjd (time-mjd self)))
+
+(defun roll (date &key (year 0) (month 0) (day 0) (second 0) (hour 0)
+ (minute 0) (destructive nil))
+ (unless (= 0 year month)
+ (multiple-value-bind (year-orig month-orig day-orig)
+ (time-ymd date)
+ (setf date (make-time :year (+ year year-orig)
+ :month (+ month month-orig)
+ :day day-orig
+ :second (time-second date)))))
+ (let ((mjd (time-mjd date))
+ (sec (time-second date)))
+ (multiple-value-bind (mjd-new sec-new)
+ (floor (+ sec second
+ (* 60 minute)
+ (* 60 60 hour)) (* 60 60 24))
+ (if destructive
+ (progn
+ (setf (time-mjd date) (+ mjd mjd-new day)
+ (time-second date) sec-new)
+ date)
+ (%make-wall-time :mjd (+ mjd mjd-new day)
+ :second sec-new)))))
+
+(defun roll-to (date size position)
+ (ecase size
+ (:month
+ (ecase position
+ (:beginning
+ (roll date :day (+ 1
+ (- (time-element date :day-of-month)))))
+ (:end
+ (roll date :day (+ (days-in-month (time-element date :month)
+ (time-element date :year))
+ (- (time-element date :day-of-month)))))))))
+
+(defun week-containing (time)
+ (let* ((midn (midnight time))
+ (dow (time-element midn :integer-day-of-week)))
+ (list (roll midn :day (- dow))
+ (roll midn :day (- 7 dow)))))
+
+(defun leap-year? (year)
+ "t if YEAR is a leap yeap in the Gregorian calendar"
+ (and (= 0 (mod year 4))
+ (or (not (= 0 (mod year 100)))
+ (= 0 (mod year 400)))))
+
+(defun valid-month-p (month)
+ "t if MONTH exists in the Gregorian calendar"
+ (<= 1 month 12))
+
+(defun valid-gregorian-date-p (date)
+ "t if DATE (year month day) exists in the Gregorian calendar"
+ (let ((max-day (days-in-month (nth 1 date) (nth 0 date))))
+ (<= 1 (nth 2 date) max-day)))
+
+(defun days-in-month (month year &key (careful t))
+ "the number of days in MONTH of YEAR, observing Gregorian leap year
+rules"
+ (declare (type fixnum month year))
+ (when careful
+ (check-type month (satisfies valid-month-p)
+ "between 1 (January) and 12 (December)"))
+ (if (eql month 2) ; feb
+ (if (leap-year? year)
+ 29 28)
+ (let ((even (mod (1- month) 2)))
+ (if (< month 8) ; aug
+ (- 31 even)
+ (+ 30 even)))))
+
+(defun day-of-year (year month day &key (careful t))
+ "the day number within the year of the date DATE. For example,
+1987 1 1 returns 1"
+ (declare (type fixnum year month day))
+ (when careful
+ (let ((date (list year month day)))
+ (check-type date (satisfies valid-gregorian-date-p)
+ "a valid Gregorian date")))
+ (let ((doy (+ day (* 31 (1- month)))))
+ (declare (type fixnum doy))
+ (when (< 2 month)
+ (setq doy (- doy (floor (+ 23 (* 4 month)) 10)))
+ (when (leap-year? year)
+ (incf doy)))
+ doy))
+
+
+;; ------------------------------------------------------------
+;; Parsing iso-8601 timestrings
+
+(define-condition iso-8601-syntax-error (error)
+ ((bad-component;; year, month whatever
+ :initarg :bad-component
+ :reader bad-component)))
+
+(defun parse-timestring (timestring &key (start 0) end junk-allowed)
+ "parse a timestring and return the corresponding wall-time. If the
+timestring starts with P, read a duration; otherwise read an ISO 8601
+formatted date string."
+ (declare (ignore junk-allowed)) ;; FIXME
+ (let ((string (subseq timestring start end)))
+ (if (char= (aref string 0) #\P)
+ (parse-iso-8601-duration string)
+ (parse-iso-8601-time string))))
+
+(defvar *iso-8601-duration-delimiters*
+ '((#\D . :days)
+ (#\H . :hours)
+ (#\M . :minutes)
+ (#\S . :seconds)))
+
+(defun iso-8601-delimiter (elt)
+ (cdr (assoc elt *iso-8601-duration-delimiters*)))
+
+(defun iso-8601-duration-subseq (string start)
+ (let* ((pos (position-if #'iso-8601-delimiter string :start start))
+ (number (when pos (parse-integer (subseq string start pos)
+ :junk-allowed t))))
+ (when number
+ (values number
+ (1+ pos)
+ (iso-8601-delimiter (aref string pos))))))
+
+(defun parse-iso-8601-duration (string)
+ "return a wall-time from a duration string"
+ (block parse
+ (let ((days 0) (secs 0) (hours 0) (minutes 0) (index 1))
+ (loop
+ (multiple-value-bind (duration next-index duration-type)
+ (iso-8601-duration-subseq string index)
+ (case duration-type
+ (:hours
+ (incf hours duration))
+ (:minutes
+ (incf minutes duration))
+ (:seconds
+ (incf secs duration))
+ (:days
+ (incf days duration))
+ (t
+ (return-from parse (make-duration :day days :hour hours
+ :minute minutes :second secs))))
+ (setq index next-index))))))
+
+;; e.g. 2000-11-11 00:00:00-06
+
+(defun parse-iso-8601-time (string)
+ "return the wall-time corresponding to the given ISO 8601 datestring"
+ (multiple-value-bind (year month day hour minute second offset)
+ (syntax-parse-iso-8601 string)
+ (make-time :year year
+ :month month
+ :day day
+ :hour hour
+ :minute minute
+ :second second
+ :offset offset)))
+
+
+(defun syntax-parse-iso-8601 (string)
+ (let (year month day hour minute second gmt-sec-offset)
+ (handler-case
+ (progn
+ (setf year (parse-integer (subseq string 0 4))
+ month (parse-integer (subseq string 5 7))
+ day (parse-integer (subseq string 8 10))
+ hour (if (<= 13 (length string))
+ (parse-integer (subseq string 11 13))
+ 0)
+ minute (if (<= 16 (length string))
+ (parse-integer (subseq string 14 16))
+ 0)
+ second (if (<= 19 (length string))
+ (parse-integer (subseq string 17 19))
+ 0)
+ gmt-sec-offset (if (<= 22 (length string))
+ (* 60 60
+ (parse-integer (subseq string 19 22)))
+ 0))
+ (unless (< 0 year)
+ (error 'iso-8601-syntax-error
+ :bad-component '(year . 0)))
+ (unless (< 0 month)
+ (error 'iso-8601-syntax-error
+ :bad-component '(month . 0)))
+ (unless (< 0 day)
+ (error 'iso-8601-syntax-error
+ :bad-component '(month . 0)))
+ (values year month day hour minute second gmt-sec-offset))
+ (simple-error ()
+ (error 'iso-8601-syntax-error
+ :bad-component
+ (car (find-if (lambda (pair) (null (cdr pair)))
+ `((year . ,year) (month . ,month)
+ (day . ,day) (hour ,hour)
+ (minute ,minute) (second ,second)
+ (timezone ,gmt-sec-offset)))))))))
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;;
+;;;; $Id: transactions.lisp 7061 2003-09-07 06:34:45Z kevin $
+
+(in-package #:clsql-base-sys)
+
+(defclass transaction ()
+ ((commit-hooks :initform () :accessor commit-hooks)
+ (rollback-hooks :initform () :accessor rollback-hooks)
+ (status :initform nil :accessor transaction-status))) ; nil or :committed
+
+(defun commit-transaction (database)
+ (when (and (transaction database)
+ (not (transaction-status (transaction database))))
+ (setf (transaction-status (transaction database)) :committed)))
+
+(defun add-transaction-commit-hook (database commit-hook)
+ (when (transaction database)
+ (push commit-hook (commit-hooks (transaction database)))))
+
+(defun add-transaction-rollback-hook (database rollback-hook)
+ (when (transaction database)
+ (push rollback-hook (rollback-hooks (transaction database)))))
+
+(defmethod database-start-transaction ((database closed-database))
+ (signal-closed-database-error database))
+
+(defmethod database-start-transaction (database)
+ (unless database (error 'clsql-nodb-error))
+ (unless (transaction database)
+ (setf (transaction database) (make-instance 'transaction)))
+ (when (= (incf (transaction-level database) 1))
+ (let ((transaction (transaction database)))
+ (setf (commit-hooks transaction) nil
+ (rollback-hooks transaction) nil
+ (transaction-status transaction) nil)
+ (execute-command "BEGIN" :database database))))
+
+(defmethod database-commit-transaction ((database closed-database))
+ (signal-closed-database-error database))
+
+(defmethod database-commit-transaction (database)
+ (if (> (transaction-level database) 0)
+ (when (zerop (decf (transaction-level database)))
+ (execute-command "COMMIT" :database database)
+ (map nil #'funcall (commit-hooks (transaction database))))
+ (warn 'clsql-simple-warning
+ :format-control "Cannot commit transaction against ~A because there is no transaction in progress."
+ :format-arguments (list database))))
+
+(defmethod database-abort-transaction ((database closed-database))
+ (signal-closed-database-error database))
+
+(defmethod database-abort-transaction (database)
+ (if (> (transaction-level database) 0)
+ (when (zerop (decf (transaction-level database)))
+ (unwind-protect
+ (execute-command "ROLLBACK" :database database)
+ (map nil #'funcall (rollback-hooks (transaction database)))))
+ (warn 'clsql-simple-warning
+ :format-control "Cannot abort transaction against ~A because there is no transaction in progress."
+ :format-arguments (list database))))
+
+
+(defmacro with-transaction ((&key (database *default-database*)) &rest body)
+ "Executes BODY within a transaction for DATABASE (which defaults to
+*DEFAULT-DATABASE*). The transaction is committed if the body finishes
+successfully (without aborting or throwing), otherwise the database is
+rolled back."
+ (let ((db (gensym "db-")))
+ `(let ((,db ,database))
+ (unwind-protect
+ (progn
+ (database-start-transaction ,db)
+ ,@body
+ (commit-transaction ,db))
+ (if (eq (transaction-status (transaction ,db)) :committed)
+ (database-commit-transaction ,db)
+ (database-abort-transaction ,db))))))
+
+(defun commit (&key (database *default-database*))
+ "Commits changes made to DATABASE which defaults to *DEFAULT-DATABASE*."
+ (database-commit-transaction database))
+
+(defun rollback (&key (database *default-database*))
+ "Rolls back changes made in DATABASE, which defaults to
+*DEFAULT-DATABASE* since the last commit, that is changes made since
+the last commit are not recorded."
+ (database-abort-transaction database))
+
+(defun start-transaction (&key (database *default-database*))
+ "Starts a transaction block on DATABASE which defaults to
+*default-database* and which continues until ROLLBACK or COMMIT are
+called."
+ (unless (in-transaction-p :database database)
+ (database-start-transaction database)))
+
+(defun in-transaction-p (&key (database *default-database*))
+ "A predicate to test whether we are currently within the scope of a
+transaction in DATABASE."
+ (and database (transaction database) (= (transaction-level database) 1)))
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
-;;;; Name: utils.cl
+;;;; Name: utils.lisp
;;;; Purpose: SQL utility functions
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Mar 2002
;;;;
;;;; $Id$
;;;;
-;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;; This file, part of CLSQL, is Copyright (c) 2002-2004 by Kevin M. Rosenberg
;;;;
;;;; CLSQL users are granted the rights to distribute and use this software
;;;; as governed by the terms of the Lisp Lesser GNU Public License
;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;; *************************************************************************
-(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
-(in-package :clsql-base-sys)
+(in-package #:clsql-base-sys)
(defun number-to-sql-string (num)
(etypecase num
;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;; *************************************************************************
+(eval-when (:compile-toplevel)
+ (declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))))
+
(defpackage #:clsql-base-system (:use #:asdf #:cl))
(in-package #:clsql-base-system)
(:file "classes" :depends-on ("package"))
(:file "conditions" :depends-on ("classes"))
(:file "db-interface" :depends-on ("conditions"))
- (:file "initialize" :depends-on ("db-interface"))))))
+ (:file "initialize" :depends-on ("db-interface"))
+ (:file "loop-extension" :depends-on ("db-interface"))
+ (:file "time" :depends-on ("package"))
+ (:file "database" :depends-on ("initialize"))
+ (:file "recording" :depends-on ("time" "database"))
+ (:file "basic-sql" :depends-on ("database"))
+ (:file "pool" :depends-on ("basic-sql"))
+ (:file "transaction" :depends-on ("basic-sql"))
+ ))))
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; ======================================================================
+;;;; File: clsql-usql-tests.asd
+;;;; Author: Marcus Pearce <m.t.pearce@city.ac.uk>
+;;;; Created: 30/03/2004
+;;;; Updated: <04/04/2004 12:34:41 marcusp>
+;;;; ======================================================================
+;;;;
+;;;; Description ==========================================================
+;;;; ======================================================================
+;;;;
+;;;; ASDF system definition for CLSQL-USQL test suite.
+;;;;
+;;;; ======================================================================
+
+(in-package #:cl-user)
+
+(asdf:defsystem :clsql-usql-tests
+ :name "CLSQL-USQL Tests"
+ :author ""
+ :maintainer ""
+ :version ""
+ :licence ""
+ :description "A regression test suite for CLSQL-USQL."
+ :components
+ ((:module usql-tests
+ :components ((:file "package")
+ (:file "test-init")
+ (:file "test-connection")
+ (:file "test-fddl")
+ (:file "test-fdml")
+ (:file "test-ooddl")
+ (:file "test-oodml")
+ (:file "test-syntax"))))
+ :depends-on (:clsql-usql :rt))
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; ======================================================================
+;;;; File: usql.asd
+;;;; Author: Marcus Pearce <m.t.pearce@city.ac.uk>
+;;;; Created: 30/03/2004
+;;;; Updated: <04/04/2004 11:58:21 marcusp>
+;;;; ======================================================================
+;;;;
+;;;; Description ==========================================================
+;;;; ======================================================================
+;;;;
+;;;; ASDF system definition for CLSQL-USQL.
+;;;;
+;;;; ======================================================================
+
+(asdf:defsystem #:clsql-usql
+ :name "CLSQL-USQL"
+ :author ""
+ :maintainer ""
+ :version ""
+ :licence ""
+ :description "A high level Common Lisp interface to SQL RDBMS."
+ :long-description "A high level Common Lisp interface to SQL RDBMS
+based on the Xanalys CommonSQL interface for Lispworks. It depends on
+the low-level database interfaces provided by CLSQL and includes both
+a functional and an object oriented interface."
+ :components
+ ((:module usql
+ :components
+ ((:module :patches
+ :pathname ""
+ :components (#+(or cmu sbcl) (:file "pcl-patch")))
+ (:module :package
+ :pathname ""
+ :components ((:file "package"))
+ :depends-on (:patches))
+ (:module :core
+ :pathname ""
+ :components ((:file "classes")
+ (:file "operations" :depends-on ("classes"))
+ (:file "syntax"))
+ :depends-on (:package))
+ (:module :functional
+ :pathname ""
+ :components ((:file "sql")
+ (:file "table"))
+ :depends-on (:core))
+ (:module :object
+ :pathname ""
+ :components ((:file "metaclasses")
+ (:file "objects" :depends-on ("metaclasses")))
+ :depends-on (:functional)))))
+ :depends-on (:clsql-base))
+
((:module :sql
:components
((:file "package")
- (:file "pool" :depends-on ("package"))
- (:file "loop-extension")
- (:file "sql" :depends-on ("pool"))
- (:file "transactions" :depends-on ("sql"))
+ (:file "sql" :depends-on ("package"))
(:file "functional" :depends-on ("sql"))
- (:file "usql" :depends-on ("sql")))))
+ (:file "usql" :depends-on ("sql"))
+ )))
:depends-on (:clsql-base)
)
+cl-sql (2.1.0-1) unstable; urgency=low
+
+ * New upstream
+
+ -- Kevin M. Rosenberg <kmr@debian.org> Mon, 5 Apr 2004 14:30:41 -0600
+
cl-sql (2.0.0-2) unstable; urgency=low
* Change from libmysqlclient10 to libmysqlclient
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
-;;;; Name: functional.cl
+;;;; Name: functional.lisp
;;;; Purpose: Functional interface
;;;; Programmer: Pierre R. Mai
;;;;
;;;; 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
;;;; *************************************************************************
-(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
-(in-package :clsql-sys)
+(in-package #:clsql-sys)
;;;; This file implements the more advanced functions of the
where)
:database database))))
-(defmacro with-database ((db-var connection-spec &rest connect-args) &body body)
- "Evaluate the body in an environment, where `db-var' is bound to the
-database connection given by `connection-spec' and `connect-args'.
-The connection is automatically closed or released to the pool on exit from the body."
- (let ((result (gensym "result-")))
- (unless db-var (setf db-var '*default-database*))
- `(let ((,db-var (connect ,connection-spec ,@connect-args))
- (,result nil))
- (unwind-protect
- (let ((,db-var ,db-var))
- (setf ,result (progn ,@body)))
- (disconnect :database ,db-var))
- ,result)))
\ No newline at end of file
+++ /dev/null
-;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
-;;;; *************************************************************************
-;;;; FILE IDENTIFICATION
-;;;;
-;;;; Name: loop-extension.lisp
-;;;; Purpose: Extensions to the Loop macro for CMUCL
-;;;; Programmer: Pierre R. Mai
-;;;;
-;;;; Copyright (c) 1999-2001 Pierre R. Mai
-;;;;
-;;;; $Id$
-;;;;
-;;;; The functions in this file were orignally distributed in the
-;;;; MaiSQL package in the file sql/sql.cl
-;;;; *************************************************************************
-
-(in-package #:cl-user)
-
-;;;; MIT-LOOP extension
-
-#+(or cmu scl)
-(defun loop-record-iteration-path (variable data-type prep-phrases)
- (let ((in-phrase nil)
- (from-phrase nil))
- (loop for (prep . rest) in prep-phrases
- do
- (case prep
- ((:in :of)
- (when in-phrase
- (ansi-loop::loop-error
- "Duplicate OF or IN iteration path: ~S." (cons prep rest)))
- (setq in-phrase rest))
- ((:from)
- (when from-phrase
- (ansi-loop::loop-error
- "Duplicate FROM iteration path: ~S." (cons prep rest)))
- (setq from-phrase rest))
- (t
- (ansi-loop::loop-error
- "Unknown preposition: ~S." prep))))
- (unless in-phrase
- (ansi-loop::loop-error "Missing OF or IN iteration path."))
- (unless from-phrase
- (setq from-phrase '(*default-database*)))
- (cond
- ((consp variable)
- (let ((query-var (ansi-loop::loop-gentemp 'loop-record-))
- (db-var (ansi-loop::loop-gentemp 'loop-record-database-))
- (result-set-var (ansi-loop::loop-gentemp
- 'loop-record-result-set-))
- (step-var (ansi-loop::loop-gentemp 'loop-record-step-)))
- (push `(when ,result-set-var
- (database-dump-result-set ,result-set-var ,db-var))
- ansi-loop::*loop-epilogue*)
- `(((,variable nil ,data-type) (,query-var ,(first in-phrase))
- (,db-var ,(first from-phrase))
- (,result-set-var nil)
- (,step-var nil))
- ((multiple-value-bind (%rs %cols)
- (database-query-result-set ,query-var ,db-var)
- (setq ,result-set-var %rs ,step-var (make-list %cols))))
- ()
- ()
- (not (database-store-next-row ,result-set-var ,db-var ,step-var))
- (,variable ,step-var)
- (not ,result-set-var)
- ()
- (not (database-store-next-row ,result-set-var ,db-var ,step-var))
- (,variable ,step-var))))
- (t
- (let ((query-var (ansi-loop::loop-gentemp 'loop-record-))
- (db-var (ansi-loop::loop-gentemp 'loop-record-database-))
- (result-set-var (ansi-loop::loop-gentemp
- 'loop-record-result-set-)))
- (push `(when ,result-set-var
- (database-dump-result-set ,result-set-var ,db-var))
- ansi-loop::*loop-epilogue*)
- `(((,variable nil ,data-type) (,query-var ,(first in-phrase))
- (,db-var ,(first from-phrase))
- (,result-set-var nil))
- ((multiple-value-bind (%rs %cols)
- (database-query-result-set ,query-var ,db-var)
- (setq ,result-set-var %rs ,variable (make-list %cols))))
- ()
- ()
- (not (database-store-next-row ,result-set-var ,db-var ,variable))
- ()
- (not ,result-set-var)
- ()
- (not (database-store-next-row ,result-set-var ,db-var ,variable))
- ()))))))
-
-#+(or cmu scl)
-(ansi-loop::add-loop-path '(record records tuple tuples)
- 'loop-record-iteration-path
- ansi-loop::*loop-ansi-universe*
- :preposition-groups '((:of :in) (:from))
- :inclusive-permitted nil)
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
-;;;; Name: package.cl
+;;;; Name: package.lisp
;;;; Purpose: Package definition for CLSQL (high-level) interface
;;;; Programmers: Kevin M. Rosenberg based on
;;;; Original code by Pierre R. Mai
;;;;
;;;; $Id$
;;;;
-;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;; This file, part of CLSQL, is Copyright (c) 2002-2004 by Kevin M. Rosenberg
;;;; and Copyright (c) 1999-2001 by Pierre R. Mai
;;;;
;;;; CLSQL users are granted the rights to distribute and use this software
))
(:export
;; sql.cl
- #:*connect-if-exists*
- #:connected-databases
- #:*default-database*
- #:find-database
- #:connect
- #:disconnect
- #:query
- #:execute-command
#:map-query
#:do-query
#:for-each-row
#:update-records
#:with-database
- ;; For High-level UncommonSQL compatibility
- #:sql-ident
- #:list-tables
- #:list-attributes
- #:attribute-type
- #:create-sequence
- #:drop-sequence
- #:sequence-next
-
- ;; Pooled connections
- #:disconnect-pooled
- #:find-or-create-connection-pool
-
- ;; Transactions
- #:with-transaction
- #:commit-transaction
- #:rollback-transaction
- #:add-transaction-commit-hook
- #:add-transaction-rollback-hook
-
;; Large objects (Marc B)
#:create-large-object
#:write-large-object
#:read-large-object
#:delete-large-object
-
+
.
#1#
)
+++ /dev/null
-;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
-;;;; *************************************************************************
-;;;; FILE IDENTIFICATION
-;;;;
-;;;; Name: pool.lisp
-;;;; Purpose: Support function for connection pool
-;;;; Programmers: Kevin M. Rosenberg, Marc Battyani
-;;;; Date Started: Apr 2002
-;;;;
-;;;; $Id$
-;;;;
-;;;; This file, part of CLSQL, is Copyright (c) 2002-2003 by Kevin M. Rosenberg
-;;;;
-;;;; CLSQL users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the Lisp Lesser GNU Public License
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
-;;;; *************************************************************************
-
-(in-package clsql-sys)
-
-(defun make-process-lock (name)
- #+allegro (mp:make-process-lock :name name)
- #+scl (thread:make-lock name)
- #+lispworks (mp:make-lock :name name)
- #-(or allegro scl lispworks) (declare (ignore name))
- #-(or allegro scl lispworks) nil)
-
-(defmacro with-process-lock ((lock desc) &body body)
- #+scl `(thread:with-lock-held (,lock ,desc) ,@body)
- #+(or allegro lispworks)
- (declare (ignore desc))
- #+(or allegro lispworks)
- (let ((l (gensym)))
- `(let ((,l ,lock))
- #+allegro (mp:with-process-lock (,l) ,@body)
- #+lispworks (mp:with-lock (,l) ,@body)))
- #-(or scl allegro lispworks) (declare (ignore lock desc))
- #-(or scl allegro lispworks) `(progn ,@body))
-
-(defvar *db-pool* (make-hash-table :test #'equal))
-(defvar *db-pool-lock* (make-process-lock "DB Pool lock"))
-
-(defclass conn-pool ()
- ((connection-spec :accessor connection-spec :initarg :connection-spec)
- (database-type :accessor database-type :initarg :database-type)
- (free-connections :accessor free-connections
- :initform (make-array 5 :fill-pointer 0 :adjustable t))
- (all-connections :accessor all-connections
- :initform (make-array 5 :fill-pointer 0 :adjustable t))
- (lock :accessor conn-pool-lock
- :initform (make-process-lock "Connection pool"))))
-
-(defun acquire-from-conn-pool (pool)
- (or (with-process-lock ((conn-pool-lock pool) "Acquire from pool")
- (and (plusp (length (free-connections pool)))
- (vector-pop (free-connections pool))))
- (let ((conn (connect (connection-spec pool)
- :database-type (database-type pool)
- :if-exists :new)))
- (with-process-lock ((conn-pool-lock pool) "Acquire from pool")
- (vector-push-extend conn (all-connections pool))
- (setf (conn-pool conn) pool))
- conn)))
-
-(defun release-to-conn-pool (conn)
- (let ((pool (conn-pool conn)))
- (with-process-lock ((conn-pool-lock pool) "Release to pool")
- (vector-push-extend conn (free-connections pool)))))
-
-(defun clear-conn-pool (pool)
- (with-process-lock ((conn-pool-lock pool) "Clear pool")
- (loop for conn across (all-connections pool)
- do (setf (conn-pool conn) nil)
- (disconnect :database conn))
- (setf (fill-pointer (free-connections pool)) 0)
- (setf (fill-pointer (all-connections pool)) 0))
- nil)
-
-(defun find-or-create-connection-pool (connection-spec database-type)
- "Find connection pool in hash table, creates a new connection pool if not found"
- (with-process-lock (*db-pool-lock* "Find-or-create connection")
- (let* ((key (list connection-spec database-type))
- (conn-pool (gethash key *db-pool*)))
- (unless conn-pool
- (setq conn-pool (make-instance 'conn-pool
- :connection-spec connection-spec
- :database-type database-type))
- (setf (gethash key *db-pool*) conn-pool))
- conn-pool)))
-
-(defun acquire-from-pool (connection-spec database-type &optional pool)
- (unless (typep pool 'conn-pool)
- (setf pool (find-or-create-connection-pool connection-spec database-type)))
- (acquire-from-conn-pool pool))
-
-(defun release-to-pool (database)
- (release-to-conn-pool database))
-
-(defun disconnect-pooled (&optional clear)
- "Disconnects all connections in the pool"
- (with-process-lock (*db-pool-lock* "Disconnect pooled")
- (maphash
- #'(lambda (key conn-pool)
- (declare (ignore key))
- (clear-conn-pool conn-pool))
- *db-pool*)
- (when clear (clrhash *db-pool*)))
- t)
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
-;;;; Name: sql.cl
+;;;; Name: sql.lisp
;;;; Purpose: High-level SQL interface
;;;; Authors: Kevin M. Rosenberg based on code by Pierre R. Mai
;;;; Date Started: Feb 2002
;;;;
;;;; $Id$
;;;;
-;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;; This file, part of CLSQL, is Copyright (c) 2002-2004 by Kevin M. Rosenberg
;;;; and Copyright (c) 1999-2001 by Pierre R. Mai
;;;;
;;;; CLSQL users are granted the rights to distribute and use this software
;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;; *************************************************************************
-(eval-when (:compile-toplevel)
- (declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))))
-
(in-package #:clsql-sys)
-;;; Database handling
-
-(defvar *connect-if-exists* :error
- "Default value for the if-exists parameter of connect calls.")
-
-(defvar *connected-databases* nil
- "List of active database objects.")
-
-(defun connected-databases ()
- "Return the list of active database objects."
- *connected-databases*)
-
-(defvar *default-database* nil
- "Specifies the default database to be used.")
-
-(defun find-database (database &optional (errorp t))
- (etypecase database
- (database
- ;; Return the database object itself
- database)
- (string
- (or (find database (connected-databases)
- :key #'database-name
- :test #'string=)
- (when errorp
- (cerror "Return nil."
- 'clsql-simple-error
- :format-control "There exists no database called ~A."
- :format-arguments (list database)))))))
-
-(defun connect (connection-spec
- &key (if-exists *connect-if-exists*)
- (database-type *default-database-type*)
- (pool nil))
- "Connects to a database of the given database-type, using the type-specific
-connection-spec.
-If pool is t the connection will be taken from the general pool,
-if pool is a conn-pool object the connection will be taken from this pool.
-"
- (if pool
- (acquire-from-pool connection-spec database-type pool)
- (let* ((db-name (database-name-from-spec connection-spec database-type))
- (old-db (unless (eq if-exists :new) (find-database db-name nil)))
- (result nil))
- (if old-db
- (case if-exists
-; (:new
-; (setq result
-; (database-connect connection-spec database-type)))
- (:warn-new
- (setq result
- (database-connect connection-spec database-type))
- (warn 'clsql-exists-warning :old-db old-db :new-db result))
- (:error
- (restart-case
- (error 'clsql-exists-error :old-db old-db)
- (create-new ()
- :report "Create a new connection."
- (setq result
- (database-connect connection-spec database-type)))
- (use-old ()
- :report "Use the existing connection."
- (setq result old-db))))
- (:warn-old
- (setq result old-db)
- (warn 'clsql-exists-warning :old-db old-db :new-db old-db))
- (:old
- (setq result old-db)))
- (setq result
- (database-connect connection-spec database-type)))
- (when result
- (pushnew result *connected-databases*)
- (setq *default-database* result)
- result))))
-
-
-(defun disconnect (&key (database *default-database*))
- "Closes the connection to database. Resets *default-database* if that
-database was disconnected and only one other connection exists.
-if the database is from a pool it will be released to this pool."
- (if (conn-pool database)
- (release-to-pool database)
- (when (database-disconnect database)
- (setq *connected-databases* (delete database *connected-databases*))
- (when (eq database *default-database*)
- (setq *default-database* (car *connected-databases*)))
- (change-class database 'closed-database)
- t)))
-
-;;; Basic operations on databases
-
-(defgeneric query (expression &key database types))
-(defmethod query (query-expression &key (database *default-database*)
- types)
- "Execute the SQL query expression query-expression on the given database.
-Returns a list of lists of values of the result of that expression."
- (database-query query-expression database types))
-
-
-(defgeneric execute-command (expression &key database))
-(defmethod execute-command (sql-expression &key (database *default-database*))
- "Execute the SQL command expression sql-expression on the given database.
-Returns true on success or nil on failure."
- (database-execute-command sql-expression database))
-
-
-
(defun map-query (output-type-spec function query-expression
&key (database *default-database*)
(types nil))
,@body))
(database-dump-result-set ,result-set ,db)))))))
-;;; Marc Battyani : Large objects support
-
-(defun create-large-object (&key (database *default-database*))
- "Creates a new large object in the database and returns the object identifier"
- (database-create-large-object database))
-
-(defun write-large-object (object-id data &key (database *default-database*))
- "Writes data to the large object"
- (database-write-large-object object-id data database))
-
-(defun read-large-object (object-id &key (database *default-database*))
- "Reads the large object content"
- (database-read-large-object object-id database))
-
-(defun delete-large-object (object-id &key (database *default-database*))
- "Deletes the large object in the database"
- (database-delete-large-object object-id database))
-
;;; Row processing macro
(loop for tuple in (query ,q)
collect (destructuring-bind ,bind-fields tuple
,@body))))))
+
+;;; Marc Battyani : Large objects support
+
+(defun create-large-object (&key (database *default-database*))
+ "Creates a new large object in the database and returns the object identifier"
+ (database-create-large-object database))
+
+(defun write-large-object (object-id data &key (database *default-database*))
+ "Writes data to the large object"
+ (database-write-large-object object-id data database))
+
+(defun read-large-object (object-id &key (database *default-database*))
+ "Reads the large object content"
+ (database-read-large-object object-id database))
+
+(defun delete-large-object (object-id &key (database *default-database*))
+ "Deletes the large object in the database"
+ (database-delete-large-object object-id database))
+
+
+++ /dev/null
-;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
-;;;; *************************************************************************
-;;;; FILE IDENTIFICATION
-;;;;
-;;;; Name: transactions.cl
-;;;; Purpose: Transaction support
-;;;; Programmers: Marc Battyani
-;;;; Date Started: Apr 2002
-;;;;
-;;;; $Id$
-;;;;
-;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
-;;;;
-;;;; CLSQL users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the Lisp Lesser GNU Public License
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
-;;;; *************************************************************************
-
-(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
-(in-package :clsql-sys)
-
-;; I removed the USQL transaction stuff to put a smaller, lighter one (MB)
-
-(defclass transaction ()
- ((commit-hooks :initform () :accessor commit-hooks)
- (rollback-hooks :initform () :accessor rollback-hooks)
- (status :initform nil :accessor status))) ;can be nil :rolled-back or :commited
-
-(defgeneric database-start-transaction (database))
-(defmethod database-start-transaction ((database closed-database))
- (error 'clsql-closed-database-error database))
-
-(defmethod database-start-transaction (database)
- (unless (transaction database)
- (setf (transaction database) (make-instance 'transaction)))
- (when (= (incf (transaction-level database)) 1)
- (let ((transaction (transaction database)))
- (setf (commit-hooks transaction) nil
- (rollback-hooks transaction) nil
- (status transaction) nil)
- (execute-command "BEGIN" :database database))))
-
-(defgeneric database-end-transaction (database))
-(defmethod database-end-transaction ((database closed-database))
- (error 'clsql-closed-database-error database))
-
-(defmethod database-end-transaction (database)
- (if (> (transaction-level database) 0)
- (when (zerop (decf (transaction-level database)))
- (let ((transaction (transaction database)))
- (if (eq (status transaction) :commited)
- (progn
- (execute-command "COMMIT" :database database)
- (map nil #'funcall (commit-hooks transaction)))
- (unwind-protect ;status is not :commited
- (execute-command "ROLLBACK" :database database)
- (map nil #'funcall (rollback-hooks transaction))))))
- (warn "Continue without commit."
- 'clsql-simple-error
- :format-control "Cannot commit transaction against ~A because there is no transaction in progress."
- :format-arguments (list database))))
-
-(defun rollback-transaction (database)
- (when (and (transaction database)(not (status (transaction database))))
- (setf (status (transaction database)) :rolled-back)))
-
-(defun commit-transaction (database)
- (when (and (transaction database)(not (status (transaction database))))
- (setf (status (transaction database)) :commited)))
-
-(defun add-transaction-commit-hook (database commit-hook)
- (when (transaction database)
- (push commit-hook (commit-hooks (transaction database)))))
-
-(defun add-transaction-rollback-hook (database rollback-hook)
- (when (transaction database)
- (push rollback-hook (rollback-hooks (transaction database)))))
-
-(defmacro with-transaction ((&key (database '*default-database*)) &rest body)
- (let ((db (gensym "db-")))
- `(let ((,db ,database))
- (unwind-protect
- (progn
- (database-start-transaction ,db)
- ,@body
- (commit-transaction ,db))
- (database-end-transaction ,db)))))
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
-;;;; Name: usql.cl
+;;;; Name: usql.lisp
;;;; Purpose: High-level interface to SQL driver routines needed for
;;;; UncommonSQL
;;;; Programmers: Kevin M. Rosenberg and onShore Development Inc
;;;;
;;;; $Id$
;;;;
-;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;; This file, part of CLSQL, is Copyright (c) 2002-2004 by Kevin M. Rosenberg
;;;; and onShore Development Inc
;;;;
;;;; CLSQL users are granted the rights to distribute and use this software
;;; Minimal high-level routines to enable low-level interface for USQL
-(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
-(in-package :clsql-sys)
+(in-package #:clsql-sys)
-(defun list-tables (&key (database *default-database*)
- (system-tables nil))
+(defun list-tables (&key (database *default-database*))
"List all tables in *default-database*, or if the :database keyword arg
is given, the specified database. If the keyword arg :system-tables
is true, then it will not filter out non-user tables. Table names are
given back as a list of strings."
- (database-list-tables database :system-tables system-tables))
+ (database-list-tables database))
(defun list-attributes (table &key (database *default-database*))
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; ======================================================================
+;;;; File: package.lisp
+;;;; Author: Marcus Pearce <m.t.pearce@city.ac.uk>
+;;;; Created: 30/03/2004
+;;;; Updated: <04/04/2004 12:00:14 marcusp>
+;;;; ======================================================================
+;;;;
+;;;; Description ==========================================================
+;;;; ======================================================================
+;;;;
+;;;; Package definition for CLSQL-USQL test suite.
+;;;;
+;;;; ======================================================================
+
+
+(in-package :cl-user)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+
+(defpackage :clsql-usql-tests
+ (:nicknames :usql-tests)
+ (:use :clsql-usql :common-lisp :rtest)
+ (:export :test-usql :test-initialise-database :test-connect-to-database)
+ (:documentation "Regression tests for CLSQL-USQL."))
+
+); eval-when
+
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; ======================================================================
+;;;; File: test-connection.lisp
+;;;; Author: Marcus Pearce <m.t.pearce@city.ac.uk>
+;;;; Created: 30/03/2004
+;;;; Updated: <04/04/2004 11:53:49 marcusp>
+;;;; ======================================================================
+;;;;
+;;;; Description ==========================================================
+;;;; ======================================================================
+;;;;
+;;;; Tests for CLSQL-USQL database connections.
+;;;;
+;;;; ======================================================================
+
+(in-package :clsql-usql-tests)
+
+
+(deftest :connection/1
+ (let ((database (usql:find-database
+ (usql:database-name usql:*default-database*)
+ :db-type (usql:database-type usql:*default-database*))))
+ (eql (usql:database-type database) *test-database-type*))
+ t)
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; ======================================================================
+;;;; File: test-fddl.lisp
+;;;; Author: Marcus Pearce <m.t.pearce@city.ac.uk>
+;;;; Created: 30/03/2004
+;;;; Updated: <04/04/2004 11:53:29 marcusp>
+;;;; ======================================================================
+;;;;
+;;;; Description ==========================================================
+;;;; ======================================================================
+;;;;
+;;;; Tests for the CLSQL-USQL Functional Data Definition Language
+;;;; (FDDL).
+;;;;
+;;;; ======================================================================
+
+(in-package :clsql-usql-tests)
+
+#.(usql:locally-enable-sql-reader-syntax)
+
+;; list current tables
+(deftest :fddl/table/1
+ (apply #'values
+ (sort (mapcar #'string-downcase
+ (usql:list-tables :owner *test-database-user*))
+ #'string>))
+ "usql_object_v" "employee" "company")
+
+;; create a table, test for its existence, drop it and test again
+(deftest :fddl/table/2
+ (progn (usql:create-table [foo]
+ '(([id] integer)
+ ([height] float)
+ ([name] (string 24))
+ ([comments] longchar)))
+ (values
+ (usql:table-exists-p [foo] :owner *test-database-user*)
+ (progn
+ (usql:drop-table [foo] :if-does-not-exist :ignore)
+ (usql:table-exists-p [foo] :owner *test-database-user*))))
+ t nil)
+
+;; create a table, list its attributes and drop it
+(deftest :fddl/table/3
+ (apply #'values
+ (progn (usql:create-table [foo]
+ '(([id] integer)
+ ([height] float)
+ ([name] (char 255))
+ ([comments] longchar)))
+ (prog1
+ (sort (mapcar #'string-downcase
+ (usql:list-attributes [foo]))
+ #'string<)
+ (usql:drop-table [foo] :if-does-not-exist :ignore))))
+ "comments" "height" "id" "name")
+
+(deftest :fddl/attributes/1
+ (apply #'values
+ (sort
+ (mapcar #'string-downcase
+ (usql:list-attributes [employee]
+ :owner *test-database-user*))
+ #'string<))
+ "birthday" "companyid" "email" "emplid" "first_name" "groupid" "height"
+ "last_name" "managerid" "married")
+
+(deftest :fddl/attributes/2
+ (apply #'values
+ (sort
+ (mapcar #'(lambda (a) (string-downcase (car a)))
+ (usql:list-attribute-types [employee]
+ :owner *test-database-user*))
+ #'string<))
+ "birthday" "companyid" "email" "emplid" "first_name" "groupid" "height"
+ "last_name" "managerid" "married")
+
+;; create a view, test for existence, drop it and test again
+(deftest :fddl/view/1
+ (progn (usql:create-view [lenins-group]
+ ;;not in sqlite
+ ;;:column-list '([forename] [surname] [email])
+ :as [select [first-name] [last-name] [email]
+ :from [employee]
+ :where [= [managerid] 1]])
+ (values
+ (usql:view-exists-p [lenins-group] :owner *test-database-user*)
+ (progn
+ (usql:drop-view [lenins-group] :if-does-not-exist :ignore)
+ (usql:view-exists-p [lenins-group] :owner *test-database-user*))))
+ t nil)
+
+;; create a view, list its attributes and drop it
+(deftest :fddl/view/2
+ (progn (usql:create-view [lenins-group]
+ ;;not in sqlite
+ ;;:column-list '([forename] [surname] [email])
+ :as [select [first-name] [last-name] [email]
+ :from [employee]
+ :where [= [managerid] 1]])
+ (prog1
+ (sort (mapcar #'string-downcase
+ (usql:list-attributes [lenins-group]))
+ #'string<)
+ (usql:drop-view [lenins-group] :if-does-not-exist :ignore)))
+ ("email" "first_name" "last_name"))
+
+;; create a view, select stuff from it and drop it
+(deftest :fddl/view/3
+ (progn (usql:create-view [lenins-group]
+ :as [select [first-name] [last-name] [email]
+ :from [employee]
+ :where [= [managerid] 1]])
+ (let ((result
+ (list
+ ;; Shouldn't exist
+ (usql:select [first-name] [last-name] [email]
+ :from [lenins-group]
+ :where [= [last-name] "Lenin"])
+ ;; Should exist
+ (car (usql:select [first-name] [last-name] [email]
+ :from [lenins-group]
+ :where [= [last-name] "Stalin"])))))
+ (usql:drop-view [lenins-group] :if-does-not-exist :ignore)
+ (apply #'values result)))
+ nil ("Josef" "Stalin" "stalin@soviet.org"))
+
+;; not in sqlite
+(deftest :fddl/view/4
+ (if (eql *test-database-type* :sqlite)
+ (values nil '(("Josef" "Stalin" "stalin@soviet.org")))
+ (progn (usql:create-view [lenins-group]
+ :column-list '([forename] [surname] [email])
+ :as [select [first-name] [last-name] [email]
+ :from [employee]
+ :where [= [managerid] 1]])
+ (let ((result
+ (list
+ ;; Shouldn't exist
+ (usql:select [forename] [surname] [email]
+ :from [lenins-group]
+ :where [= [surname] "Lenin"])
+ ;; Should exist
+ (car (usql:select [forename] [surname] [email]
+ :from [lenins-group]
+ :where [= [surname] "Stalin"])))))
+ (usql:drop-view [lenins-group] :if-does-not-exist :ignore)
+ (apply #'values result))))
+ nil ("Josef" "Stalin" "stalin@soviet.org"))
+
+;; create an index, test for existence, drop it and test again
+(deftest :fddl/index/1
+ (progn (usql:create-index [bar] :on [employee] :attributes
+ '([first-name] [last-name] [email]) :unique t)
+ (values
+ (usql:index-exists-p [bar] :owner *test-database-user*)
+ (progn
+ (case *test-database-type*
+ (:mysql
+ (usql:drop-index [bar] :on [employee]
+ :if-does-not-exist :ignore))
+ (t
+ (usql:drop-index [bar]:if-does-not-exist :ignore)))
+ (usql:view-exists-p [bar] :owner *test-database-user*))))
+ t nil)
+
+;; create indexes with names as strings, symbols and in square brackets
+(deftest :fddl/index/2
+ (let ((names '("foo" foo [foo]))
+ (result '()))
+ (dolist (name names)
+ (usql:create-index name :on [employee] :attributes '([emplid]))
+ (push (usql:index-exists-p name :owner *test-database-user*) result)
+ (case *test-database-type*
+ (:mysql
+ (usql:drop-index name :on [employee] :if-does-not-exist :ignore))
+ (t (usql:drop-index name :if-does-not-exist :ignore))))
+ (apply #'values result))
+ t t t)
+
+;; create an sequence, test for existence, drop it and test again
+(deftest :fddl/sequence/1
+ (progn (usql:create-sequence [foo])
+ (values
+ (usql:sequence-exists-p [foo] :owner *test-database-user*)
+ (progn
+ (usql:drop-sequence [foo] :if-does-not-exist :ignore)
+ (usql:sequence-exists-p [foo] :owner *test-database-user*))))
+ t nil)
+
+;; create and increment a sequence
+(deftest :fddl/sequence/2
+ (let ((val1 nil))
+ (usql:create-sequence [foo])
+ (setf val1 (usql:sequence-next [foo]))
+ (prog1
+ (< val1 (usql:sequence-next [foo]))
+ (usql:drop-sequence [foo] :if-does-not-exist :ignore)))
+ t)
+
+;; explicitly set the value of a sequence
+(deftest :fddl/sequence/3
+ (progn
+ (usql:create-sequence [foo])
+ (usql:set-sequence-position [foo] 5)
+ (prog1
+ (usql:sequence-next [foo])
+ (usql:drop-sequence [foo] :if-does-not-exist :ignore)))
+ 6)
+
+#.(usql:restore-sql-reader-syntax-state)
\ No newline at end of file
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; ======================================================================
+;;;; File: test-fdml.lisp
+;;;; Author: Marcus Pearce <m.t.pearce@city.ac.uk>
+;;;; Created: 30/03/2004
+;;;; Updated: <04/04/2004 11:52:39 marcusp>
+;;;; ======================================================================
+;;;;
+;;;; Description ==========================================================
+;;;; ======================================================================
+;;;;
+;;;; Tests for the CLSQL-USQL Functional Data Manipulation Language
+;;;; (FDML).
+;;;;
+;;;; ======================================================================
+
+(in-package :clsql-usql-tests)
+
+#.(usql:locally-enable-sql-reader-syntax)
+
+;; inserts a record using all values only and then deletes it
+(deftest :fdml/insert/1
+ (progn
+ (usql:insert-records :into [employee]
+ :values `(11 1 "Yuri" "Gagarin" "gagarin@soviet.org"
+ 1 1 1.85 t ,(usql:get-time)))
+ (values
+ (usql:select [first-name] [last-name] [email]
+ :from [employee] :where [= [emplid] 11])
+ (progn (usql:delete-records :from [employee] :where [= [emplid] 11])
+ (usql:select [*] :from [employee] :where [= [emplid] 11]))))
+ (("Yuri" "Gagarin" "gagarin@soviet.org")) nil)
+
+;; inserts a record using attributes and values and then deletes it
+(deftest :fdml/insert/2
+ (progn
+ (usql:insert-records :into [employee]
+ :attributes '(emplid groupid first_name last_name
+ email companyid managerid)
+ :values '(11 1 "Yuri" "Gagarin" "gagarin@soviet.org"
+ 1 1))
+ (values
+ (usql:select [first-name] [last-name] [email] :from [employee]
+ :where [= [emplid] 11])
+ (progn (usql:delete-records :from [employee] :where [= [emplid] 11])
+ (usql:select [*] :from [employee] :where [= [emplid] 11]))))
+ (("Yuri" "Gagarin" "gagarin@soviet.org")) nil)
+
+;; inserts a record using av-pairs and then deletes it
+(deftest :fdml/insert/3
+ (progn
+ (usql:insert-records :into [employee]
+ :av-pairs'((emplid 11) (groupid 1)
+ (first_name "Yuri")
+ (last_name "Gagarin")
+ (email "gagarin@soviet.org")
+ (companyid 1) (managerid 1)))
+ (values
+ (usql:select [first-name] [last-name] [email] :from [employee]
+ :where [= [emplid] 11])
+ (progn (usql:delete-records :from [employee] :where [= [emplid] 11])
+ (usql:select [first-name] [last-name] [email] :from [employee]
+ :where [= [emplid] 11]))))
+ (("Yuri" "Gagarin" "gagarin@soviet.org")) nil)
+
+;; inserts a records using a query from another table
+(deftest :fdml/insert/4
+ (progn
+ (usql:create-table [employee2] '(([forename] string)
+ ([surname] string)
+ ([email] string)))
+ (usql:insert-records :into [employee2]
+ :query [select [first-name] [last-name] [email]
+ :from [employee]]
+ :attributes '(forename surname email))
+ (prog1
+ (equal (usql:select [*] :from [employee2])
+ (usql:select [first-name] [last-name] [email]
+ :from [employee]))
+ (usql:drop-table [employee2] :if-does-not-exist :ignore)))
+ t)
+
+;; updates a record using attributes and values and then deletes it
+(deftest :fdml/update/1
+ (progn
+ (usql:update-records [employee]
+ :attributes '(first_name last_name email)
+ :values '("Yuri" "Gagarin" "gagarin@soviet.org")
+ :where [= [emplid] 1])
+ (values
+ (usql:select [first-name] [last-name] [email] :from [employee]
+ :where [= [emplid] 1])
+ (progn
+ (usql:update-records [employee]
+ :av-pairs'((first_name "Vladamir")
+ (last_name "Lenin")
+ (email "lenin@soviet.org"))
+ :where [= [emplid] 1])
+ (usql:select [first-name] [last-name] [email] :from [employee]
+ :where [= [emplid] 1]))))
+ (("Yuri" "Gagarin" "gagarin@soviet.org"))
+ (("Vladamir" "Lenin" "lenin@soviet.org")))
+
+;; updates a record using av-pairs and then deletes it
+(deftest :fdml/update/2
+ (progn
+ (usql:update-records [employee]
+ :av-pairs'((first_name "Yuri")
+ (last_name "Gagarin")
+ (email "gagarin@soviet.org"))
+ :where [= [emplid] 1])
+ (values
+ (usql:select [first-name] [last-name] [email] :from [employee]
+ :where [= [emplid] 1])
+ (progn
+ (usql:update-records [employee]
+ :av-pairs'((first_name "Vladamir")
+ (last_name "Lenin")
+ (email "lenin@soviet.org"))
+ :where [= [emplid] 1])
+ (usql:select [first-name] [last-name] [email]
+ :from [employee] :where [= [emplid] 1]))))
+ (("Yuri" "Gagarin" "gagarin@soviet.org"))
+ (("Vladamir" "Lenin" "lenin@soviet.org")))
+
+
+(deftest :fdml/query/1
+ (usql:query "SELECT COUNT(*) FROM EMPLOYEE WHERE (EMAIL LIKE '%org')")
+ (("10")))
+
+(deftest :fdml/query/2
+ (usql:query
+ "SELECT FIRST_NAME,LAST_NAME FROM EMPLOYEE WHERE (EMPLID <= 5) ORDER BY LAST_NAME")
+ (("Leonid" "Brezhnev") ("Nikita" "Kruschev") ("Vladamir" "Lenin")
+ ("Josef" "Stalin") ("Leon" "Trotsky")))
+
+
+(deftest :fdml/execute-command/1
+ (values
+ (usql:table-exists-p [foo] :owner *test-database-user*)
+ (progn
+ (usql:execute-command "create table foo (bar integer)")
+ (usql:table-exists-p [foo] :owner *test-database-user*))
+ (progn
+ (usql:execute-command "drop table foo")
+ (usql:table-exists-p [foo] :owner *test-database-user*)))
+ nil t nil)
+
+
+;; compare min, max and average hieghts in inches (they're quite short
+;; these guys!) -- only works with pgsql
+(deftest :fdml/select/1
+ (if (member *test-database-type* '(:postgresql-socket :postgresql))
+ (let ((max (usql:select [function "floor"
+ [/ [* [max [height]] 100] 2.54]]
+ :from [employee]
+ :flatp t))
+ (min (usql:select [function "floor"
+ [/ [* [min [height]] 100] 2.54]]
+ :from [employee]
+ :flatp t))
+ (avg (usql:select [function "floor"
+ [avg [/ [* [height] 100] 2.54]]]
+ :from [employee]
+ :flatp t)))
+ (apply #'< (mapcar #'parse-integer (append min avg max))))
+ t)
+ t)
+
+(deftest :fdml/select/2
+ (usql:select [first-name] :from [employee] :flatp t :distinct t
+ :order-by [first-name])
+ ("Boris" "Josef" "Konstantin" "Leon" "Leonid" "Mikhail" "Nikita" "Vladamir"
+ "Yuri"))
+
+(deftest :fdml/select/3
+ (usql:select [first-name] [count [*]] :from [employee]
+ :group-by [first-name]
+ :order-by [first-name])
+ (("Boris" "1") ("Josef" "1") ("Konstantin" "1") ("Leon" "1") ("Leonid" "1")
+ ("Mikhail" "1") ("Nikita" "1") ("Vladamir" "2") ("Yuri" "1")))
+
+(deftest :fdml/select/4
+ (usql:select [last-name] :from [employee] :where [like [email] "%org"]
+ :order-by [last-name]
+ :flatp t)
+ ("Andropov" "Brezhnev" "Chernenko" "Gorbachev" "Kruschev" "Lenin" "Putin"
+ "Stalin" "Trotsky" "Yeltsin"))
+
+(deftest :fdml/select/5
+ (usql:select [email] :from [employee] :flatp t
+ :where [in [employee emplid]
+ [select [managerid] :from [employee]]])
+ ("lenin@soviet.org"))
+
+(deftest :fdml/select/6
+ (if (member *test-database-type* '(:postgresql-socket :postgresql))
+ (mapcar #'parse-integer
+ (usql:select [function "trunc" [height]] :from [employee]
+ :flatp t))
+ (mapcar #'(lambda (s) (truncate (parse-integer s :junk-allowed t)))
+ (usql:select [height] :from [employee] :flatp t)))
+ (1 1 1 1 1 1 1 1 1 1))
+
+(deftest :fdml/select/7
+ (sql:select [max [emplid]] :from [employee] :flatp t)
+ ("10"))
+
+(deftest :fdml/select/8
+ (sql:select [min [emplid]] :from [employee] :flatp t)
+ ("1"))
+
+(deftest :fdml/select/9
+ (subseq (car (sql:select [avg [emplid]] :from [employee] :flatp t)) 0 3)
+ "5.5")
+
+(deftest :fdml/select/10
+ (sql:select [last-name] :from [employee]
+ :where [not [in [emplid]
+ [select [managerid] :from [company]]]]
+ :flatp t
+ :order-by [last-name])
+ ("Andropov" "Brezhnev" "Chernenko" "Gorbachev" "Kruschev" "Putin" "Stalin"
+ "Trotsky" "Yeltsin"))
+
+(deftest :fdml/select/11
+ (usql:select [last-name] :from [employee] :where [married] :flatp t
+ :order-by [emplid])
+ ("Lenin" "Stalin" "Trotsky"))
+
+(deftest :fdml/select/12
+ (let ((v 1))
+ (usql:select [last-name] :from [employee] :where [= [emplid] v]))
+ (("Lenin")))
+
+;(deftest :fdml/select/11
+; (sql:select [emplid] :from [employee]
+; :where [= [emplid] [any [select [companyid] :from [company]]]]
+; :flatp t)
+; ("1"))
+
+(deftest :fdml/do-query/1
+ (let ((result '()))
+ (usql:do-query ((name) [select [last-name] :from [employee]
+ :order-by [last-name]])
+ (push name result))
+ result)
+ ("Yeltsin" "Trotsky" "Stalin" "Putin" "Lenin" "Kruschev" "Gorbachev"
+ "Chernenko" "Brezhnev" "Andropov"))
+
+(deftest :fdml/map-query/1
+ (usql:map-query 'list #'identity
+ [select [last-name] :from [employee] :flatp t
+ :order-by [last-name]])
+ ("Andropov" "Brezhnev" "Chernenko" "Gorbachev" "Kruschev" "Lenin" "Putin"
+ "Stalin" "Trotsky" "Yeltsin"))
+
+(deftest :fdml/map-query/2
+ (usql:map-query 'vector #'identity
+ [select [last-name] :from [employee] :flatp t
+ :order-by [last-name]])
+ #("Andropov" "Brezhnev" "Chernenko" "Gorbachev" "Kruschev" "Lenin" "Putin"
+ "Stalin" "Trotsky" "Yeltsin"))
+
+(deftest :fdml/loop/1
+ (loop for (forename surname)
+ being each tuple in
+ [select [first-name] [last-name] :from [employee] :order-by [last-name]]
+ collect (concatenate 'string forename " " surname))
+ ("Yuri Andropov" "Leonid Brezhnev" "Konstantin Chernenko" "Mikhail Gorbachev"
+ "Nikita Kruschev" "Vladamir Lenin" "Vladamir Putin"
+ "Josef Stalin" "Leon Trotsky" "Boris Yeltsin"))
+
+;; starts a transaction deletes a record and then rolls back the deletion
+(deftest :fdml/transaction/1
+ (let ((results '()))
+ ;; test if we are in a transaction
+ (push (usql:in-transaction-p) results)
+ ;;start a transaction
+ (usql:start-transaction)
+ ;; test if we are in a transaction
+ (push (usql:in-transaction-p) results)
+ ;;Putin has got to go
+ (unless (eql *test-database-type* :mysql)
+ (usql:delete-records :from [employee] :where [= [last-name] "Putin"]))
+ ;;Should be nil
+ (push
+ (usql:select [*] :from [employee] :where [= [last-name] "Putin"])
+ results)
+ ;;Oh no, he's still there
+ (usql:rollback)
+ ;; test that we are out of the transaction
+ (push (usql:in-transaction-p) results)
+ ;; Check that we got him back alright
+ (push (usql:select [email] :from [employee] :where [= [last-name] "Putin"]
+ :flatp t)
+ results)
+ (apply #'values (nreverse results)))
+ nil t nil nil ("putin@soviet.org"))
+
+;; starts a transaction, updates a record and then rolls back the update
+(deftest :fdml/transaction/2
+ (let ((results '()))
+ ;; test if we are in a transaction
+ (push (usql:in-transaction-p) results)
+ ;;start a transaction
+ (usql:start-transaction)
+ ;; test if we are in a transaction
+ (push (usql:in-transaction-p) results)
+ ;;Putin has got to go
+ (unless (eql *test-database-type* :mysql)
+ (usql:update-records [employee]
+ :av-pairs '((email "putin-nospam@soviet.org"))
+ :where [= [last-name] "Putin"]))
+ ;;Should be new value
+ (push (usql:select [email] :from [employee]
+ :where [= [last-name] "Putin"]
+ :flatp t)
+ results)
+ ;;Oh no, he's still there
+ (usql:rollback)
+ ;; test that we are out of the transaction
+ (push (usql:in-transaction-p) results)
+ ;; Check that we got him back alright
+ (push (usql:select [email] :from [employee] :where [= [last-name] "Putin"]
+ :flatp t)
+ results)
+ (apply #'values (nreverse results)))
+ nil t ("putin-nospam@soviet.org") nil ("putin@soviet.org"))
+
+;; runs an update within a transaction and checks it is committed
+(deftest :fdml/transaction/3
+ (let ((results '()))
+ ;; check status
+ (push (usql:in-transaction-p) results)
+ ;; update records
+ (push
+ (usql:with-transaction ()
+ (usql:update-records [employee]
+ :av-pairs '((email "lenin-nospam@soviet.org"))
+ :where [= [emplid] 1]))
+ results)
+ ;; check status
+ (push (usql:in-transaction-p) results)
+ ;; check that was committed
+ (push (usql:select [email] :from [employee] :where [= [emplid] 1]
+ :flatp t)
+ results)
+ ;; undo the changes
+ (push
+ (usql:with-transaction ()
+ (usql:update-records [employee]
+ :av-pairs '((email "lenin@soviet.org"))
+ :where [= [emplid] 1]))
+ results)
+ ;; and check status
+ (push (usql:in-transaction-p) results)
+ ;; check that was committed
+ (push (usql:select [email] :from [employee] :where [= [emplid] 1]
+ :flatp t)
+ results)
+ (apply #'values (nreverse results)))
+ nil :COMMITTED nil ("lenin-nospam@soviet.org") :COMMITTED
+ nil ("lenin@soviet.org"))
+
+;; runs a valid update and an invalid one within a transaction and checks
+;; that the valid update is rolled back when the invalid one fails.
+(deftest :fdml/transaction/4
+ (let ((results '()))
+ ;; check status
+ (push (usql:in-transaction-p) results)
+ (unless (eql *test-database-type* :mysql)
+ (handler-case
+ (usql:with-transaction ()
+ ;; valid update
+ (usql:update-records [employee]
+ :av-pairs '((email "lenin-nospam@soviet.org"))
+ :where [= [emplid] 1])
+ ;; invalid update which generates an error
+ (usql:update-records [employee]
+ :av-pairs
+ '((emale "lenin-nospam@soviet.org"))
+ :where [= [emplid] 1]))
+ (usql:clsql-sql-error ()
+ (progn
+ ;; check status
+ (push (usql:in-transaction-p) results)
+ ;; and check nothing done
+ (push (usql:select [email] :from [employee] :where [= [emplid] 1]
+ :flatp t)
+ results)
+ (apply #'values (nreverse results)))))))
+ nil nil ("lenin@soviet.org"))
+
+#.(usql:restore-sql-reader-syntax-state)
\ No newline at end of file
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; ======================================================================
+;;;; File: test-init.lisp
+;;;; Author: Marcus Pearce <m.t.pearce@city.ac.uk>
+;;;; Created: 30/03/2004
+;;;; Updated: <04/04/2004 12:14:38 marcusp>
+;;;; ======================================================================
+;;;;
+;;;; Description ==========================================================
+;;;; ======================================================================
+;;;;
+;;;; Initialisation utilities for running regression tests on CLSQL-USQL.
+;;;;
+;;;; ======================================================================
+
+(in-package :clsql-usql-tests)
+
+(defvar *test-database-type* nil)
+(defvar *test-database-server* "")
+(defvar *test-database-name* "")
+(defvar *test-database-user* "")
+(defvar *test-database-password* "")
+
+(defclass thing ()
+ ((extraterrestrial :initform nil :initarg :extraterrestrial)))
+
+(def-view-class person (thing)
+ ((height :db-kind :base :accessor height :type float :nulls-ok t
+ :initarg :height)
+ (married :db-kind :base :accessor married :type boolean :nulls-ok t
+ :initarg :married)
+ (birthday :nulls-ok t :type wall-time :initarg :birthday)
+ (hobby :db-kind :virtual :initarg :hobby :initform nil)))
+
+(def-view-class employee (person)
+ ((emplid
+ :db-kind :key
+ :db-constraints :not-null
+ :nulls-ok nil
+ :type integer
+ :initarg :emplid)
+ (groupid
+ :db-kind :key
+ :db-constraints :not-null
+ :nulls-ok nil
+ :type integer
+ :initarg :groupid)
+ (first-name
+ :accessor first-name
+ :type (string 30)
+ :initarg :first-name)
+ (last-name
+ :accessor last-name
+ :type (string 30)
+ :initarg :last-name)
+ (email
+ :accessor employee-email
+ :type (string 100)
+ :nulls-ok t
+ :initarg :email)
+ (companyid
+ :type integer)
+ (company
+ :accessor employee-company
+ :db-kind :join
+ :db-info (:join-class company
+ :home-key companyid
+ :foreign-key companyid
+ :set nil))
+ (managerid
+ :type integer
+ :nulls-ok t)
+ (manager
+ :accessor employee-manager
+ :db-kind :join
+ :db-info (:join-class employee
+ :home-key managerid
+ :foreign-key emplid
+ :set nil)))
+ (:base-table employee))
+
+(def-view-class company ()
+ ((companyid
+ :db-type :key
+ :db-constraints :not-null
+ :type integer
+ :initarg :companyid)
+ (groupid
+ :db-type :key
+ :db-constraints :not-null
+ :type integer
+ :initarg :groupid)
+ (name
+ :type (string 100)
+ :initarg :name)
+ (presidentid
+ :type integer)
+ (president
+ :reader president
+ :db-kind :join
+ :db-info (:join-class employee
+ :home-key presidentid
+ :foreign-key emplid
+ :set nil))
+ (employees
+ :reader company-employees
+ :db-kind :join
+ :db-info (:join-class employee
+ :home-key (companyid groupid)
+ :foreign-key (companyid groupid)
+ :set t)))
+ (:base-table company))
+
+(defparameter company1 (make-instance 'company
+ :companyid 1
+ :groupid 1
+ :name "Widgets Inc."))
+
+(defparameter employee1 (make-instance 'employee
+ :emplid 1
+ :groupid 1
+ :married t
+ :height (1+ (random 1.00))
+ :birthday (usql:get-time)
+ :first-name "Vladamir"
+ :last-name "Lenin"
+ :email "lenin@soviet.org"))
+
+(defparameter employee2 (make-instance 'employee
+ :emplid 2
+ :groupid 1
+ :height (1+ (random 1.00))
+ :married t
+ :birthday (usql:get-time)
+ :first-name "Josef"
+ :last-name "Stalin"
+ :email "stalin@soviet.org"))
+
+(defparameter employee3 (make-instance 'employee
+ :emplid 3
+ :groupid 1
+ :height (1+ (random 1.00))
+ :married t
+ :birthday (usql:get-time)
+ :first-name "Leon"
+ :last-name "Trotsky"
+ :email "trotsky@soviet.org"))
+
+(defparameter employee4 (make-instance 'employee
+ :emplid 4
+ :groupid 1
+ :height (1+ (random 1.00))
+ :married nil
+ :birthday (usql:get-time)
+ :first-name "Nikita"
+ :last-name "Kruschev"
+ :email "kruschev@soviet.org"))
+
+(defparameter employee5 (make-instance 'employee
+ :emplid 5
+ :groupid 1
+ :married nil
+ :height (1+ (random 1.00))
+ :birthday (usql:get-time)
+ :first-name "Leonid"
+ :last-name "Brezhnev"
+ :email "brezhnev@soviet.org"))
+
+(defparameter employee6 (make-instance 'employee
+ :emplid 6
+ :groupid 1
+ :married nil
+ :height (1+ (random 1.00))
+ :birthday (usql:get-time)
+ :first-name "Yuri"
+ :last-name "Andropov"
+ :email "andropov@soviet.org"))
+
+(defparameter employee7 (make-instance 'employee
+ :emplid 7
+ :groupid 1
+ :height (1+ (random 1.00))
+ :married nil
+ :birthday (usql:get-time)
+ :first-name "Konstantin"
+ :last-name "Chernenko"
+ :email "chernenko@soviet.org"))
+
+(defparameter employee8 (make-instance 'employee
+ :emplid 8
+ :groupid 1
+ :height (1+ (random 1.00))
+ :married nil
+ :birthday (usql:get-time)
+ :first-name "Mikhail"
+ :last-name "Gorbachev"
+ :email "gorbachev@soviet.org"))
+
+(defparameter employee9 (make-instance 'employee
+ :emplid 9
+ :groupid 1
+ :married nil
+ :height (1+ (random 1.00))
+ :birthday (usql:get-time)
+ :first-name "Boris"
+ :last-name "Yeltsin"
+ :email "yeltsin@soviet.org"))
+
+(defparameter employee10 (make-instance 'employee
+ :emplid 10
+ :groupid 1
+ :married nil
+ :height (1+ (random 1.00))
+ :birthday (usql:get-time)
+ :first-name "Vladamir"
+ :last-name "Putin"
+ :email "putin@soviet.org"))
+
+(defun test-database-connection-spec ()
+ (let ((dbserver *test-database-server*)
+ (dbname *test-database-name*)
+ (dbpassword *test-database-password*)
+ (dbtype *test-database-type*)
+ (username *test-database-user*))
+ (case dbtype
+ (:postgresql
+ `("" ,dbname ,username ,dbpassword))
+ (:postgresql-socket
+ `(,dbserver ,dbname ,username ,dbpassword))
+ (:mysql
+ `("" ,dbname ,username ,dbpassword))
+ (:sqlite
+ `(,dbname))
+ (:oracle
+ `(,username ,dbpassword ,dbname))
+ (t
+ (error "Unrecognized database type: ~A" dbtype)))))
+
+(defun test-connect-to-database (database-type)
+ (setf *test-database-type* database-type)
+ ;; Connect to the database
+ (usql:connect (test-database-connection-spec)
+ :database-type database-type
+ :make-default t
+ :if-exists :old))
+
+(defun test-initialise-database ()
+ ;; Delete the instance records
+ (ignore-errors
+ (usql:delete-instance-records company1)
+ (usql:delete-instance-records employee1)
+ (usql:delete-instance-records employee2)
+ (usql:delete-instance-records employee3)
+ (usql:delete-instance-records employee4)
+ (usql:delete-instance-records employee5)
+ (usql:delete-instance-records employee6)
+ (usql:delete-instance-records employee7)
+ (usql:delete-instance-records employee8)
+ (usql:delete-instance-records employee9)
+ (usql:delete-instance-records employee10)
+ ;; Drop the required tables if they exist
+ (usql:drop-view-from-class 'employee)
+ (usql:drop-view-from-class 'company))
+ ;; Create the tables for our view classes
+ (usql:create-view-from-class 'employee)
+ (usql:create-view-from-class 'company)
+ ;; Lenin manages everyone
+ (usql:add-to-relation employee2 'manager employee1)
+ (usql:add-to-relation employee3 'manager employee1)
+ (usql:add-to-relation employee4 'manager employee1)
+ (usql:add-to-relation employee5 'manager employee1)
+ (usql:add-to-relation employee6 'manager employee1)
+ (usql:add-to-relation employee7 'manager employee1)
+ (usql:add-to-relation employee8 'manager employee1)
+ (usql:add-to-relation employee9 'manager employee1)
+ (usql:add-to-relation employee10 'manager employee1)
+ ;; Everyone works for Widgets Inc.
+ (usql:add-to-relation company1 'employees employee1)
+ (usql:add-to-relation company1 'employees employee2)
+ (usql:add-to-relation company1 'employees employee3)
+ (usql:add-to-relation company1 'employees employee4)
+ (usql:add-to-relation company1 'employees employee5)
+ (usql:add-to-relation company1 'employees employee6)
+ (usql:add-to-relation company1 'employees employee7)
+ (usql:add-to-relation company1 'employees employee8)
+ (usql:add-to-relation company1 'employees employee9)
+ (usql:add-to-relation company1 'employees employee10)
+ ;; Lenin is president of Widgets Inc.
+ (usql:add-to-relation company1 'president employee1)
+ ;; store these instances
+ (usql:update-records-from-instance employee1)
+ (usql:update-records-from-instance employee2)
+ (usql:update-records-from-instance employee3)
+ (usql:update-records-from-instance employee4)
+ (usql:update-records-from-instance employee5)
+ (usql:update-records-from-instance employee6)
+ (usql:update-records-from-instance employee7)
+ (usql:update-records-from-instance employee8)
+ (usql:update-records-from-instance employee9)
+ (usql:update-records-from-instance employee10)
+ (usql:update-records-from-instance company1))
+
+(defun test-usql (backend)
+ (format t "~&Running CLSQL-USQL tests with ~A backend.~%" backend)
+ (test-connect-to-database backend)
+ (test-initialise-database)
+ (rtest:do-tests))
+
+
+
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; ======================================================================
+;;;; File: test-ooddl.lisp
+;;;; Author: Marcus Pearce <m.t.pearce@city.ac.uk>
+;;;; Created: 30/03/2004
+;;;; Updated: <04/04/2004 11:52:11 marcusp>
+;;;; ======================================================================
+;;;;
+;;;; Description ==========================================================
+;;;; ======================================================================
+;;;;
+;;;; Tests for the CLSQL-USQL Object Oriented Data Definition Language
+;;;; (OODDL).
+;;;;
+;;;; ======================================================================
+
+
+(in-package :clsql-usql-tests)
+
+#.(usql:locally-enable-sql-reader-syntax)
+
+;; Ensure slots inherited from standard-classes are :virtual
+(deftest :ooddl/metaclass/1
+ (values
+ (usql-sys::view-class-slot-db-kind
+ (usql-sys::slotdef-for-slot-with-class 'extraterrestrial
+ (find-class 'person)))
+ (usql-sys::view-class-slot-db-kind
+ (usql-sys::slotdef-for-slot-with-class 'hobby (find-class 'person))))
+ :virtual :virtual)
+
+;; Ensure all slots in view-class are view-class-effective-slot-definition
+(deftest :ooddl/metaclass/2
+ (values
+ (every #'(lambda (slotd)
+ (typep slotd 'usql-sys::view-class-effective-slot-definition))
+ (usql-sys::class-slots (find-class 'person)))
+ (every #'(lambda (slotd)
+ (typep slotd 'usql-sys::view-class-effective-slot-definition))
+ (usql-sys::class-slots (find-class 'employee)))
+ (every #'(lambda (slotd)
+ (typep slotd 'usql-sys::view-class-effective-slot-definition))
+ (usql-sys::class-slots (find-class 'company))))
+ t t t)
+
+(deftest :ooddl/join/1
+ (mapcar #'(lambda (e)
+ (slot-value e 'companyid))
+ (company-employees company1))
+ (1 1 1 1 1 1 1 1 1 1))
+
+(deftest :ooddl/join/2
+ (slot-value (president company1) 'last-name)
+ "Lenin")
+
+(deftest :ooddl/join/3
+ (slot-value (employee-manager employee2) 'last-name)
+ "Lenin")
+
+(deftest :ooddl/time/1
+ (let* ((now (usql:get-time)))
+ (when (member *test-database-type* '(:postgresql :postgresql-socket))
+ (usql:execute-command "set datestyle to 'iso'"))
+ (usql:update-records [employee] :av-pairs `((birthday ,now))
+ :where [= [emplid] 1])
+ (let ((dbobj (car (usql:select 'employee :where [= [birthday] now]))))
+ (values
+ (slot-value dbobj 'last-name)
+ (usql:time= (slot-value dbobj 'birthday) now))))
+ "Lenin" t)
+
+(deftest :ooddl/time/2
+ (let* ((now (usql:get-time))
+ (fail-index -1))
+ (when (member *test-database-type* '(:postgresql :postgresql-socket))
+ (usql:execute-command "set datestyle to 'iso'"))
+ (dotimes (x 40)
+ (usql:update-records [employee] :av-pairs `((birthday ,now))
+ :where [= [emplid] 1])
+ (let ((dbobj (car (usql:select 'employee :where [= [birthday] now]))))
+ (unless (usql:time= (slot-value dbobj 'birthday) now)
+ (setf fail-index x))
+ (setf now (usql:roll now :day (* 10 x)))))
+ fail-index)
+ -1)
+
+#.(usql:restore-sql-reader-syntax-state)
\ No newline at end of file
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; ======================================================================
+;;;; File: test-oodml.lisp
+;;;; Author: Marcus Pearce <m.t.pearce@city.ac.uk>
+;;;; Created: 01/04/2004
+;;;; Updated: <04/04/2004 11:51:23 marcusp>
+;;;; ======================================================================
+;;;;
+;;;; Description ==========================================================
+;;;; ======================================================================
+;;;;
+;;;; Tests for the CLSQL-USQL Object Oriented Data Definition Language
+;;;; (OODML).
+;;;;
+;;;; ======================================================================
+
+(in-package :clsql-usql-tests)
+
+#.(usql:locally-enable-sql-reader-syntax)
+
+(deftest :oodml/select/1
+ (mapcar #'(lambda (e) (slot-value e 'last-name))
+ (usql:select 'employee :order-by [last-name]))
+ ("Andropov" "Brezhnev" "Chernenko" "Gorbachev" "Kruschev" "Lenin" "Putin"
+ "Stalin" "Trotsky" "Yeltsin"))
+
+(deftest :oodml/select/2
+ (mapcar #'(lambda (e) (slot-value e 'name))
+ (usql:select 'company))
+ ("Widgets Inc."))
+
+(deftest :oodml/select/3
+ (mapcar #'(lambda (e) (slot-value e 'companyid))
+ (usql:select 'employee
+ :where [and [= [slot-value 'employee 'companyid]
+ [slot-value 'company 'companyid]]
+ [= [slot-value 'company 'name]
+ "Widgets Inc."]]))
+ (1 1 1 1 1 1 1 1 1 1))
+
+(deftest :oodml/select/4
+ (mapcar #'(lambda (e)
+ (concatenate 'string (slot-value e 'first-name)
+ " "
+ (slot-value e 'last-name)))
+ (usql:select 'employee :where [= [slot-value 'employee 'first-name]
+ "Vladamir"]
+ :order-by [last-name]))
+ ("Vladamir Lenin" "Vladamir Putin"))
+
+;; sqlite fails this because it is typeless
+(deftest :oodml/select/5
+ (length (sql:select 'employee :where [married]))
+ 3)
+
+;; tests update-records-from-instance
+(deftest :oodml/update-records/1
+ (values
+ (progn
+ (let ((lenin (car (usql:select 'employee
+ :where [= [slot-value 'employee 'emplid]
+ 1]))))
+ (concatenate 'string
+ (first-name lenin)
+ " "
+ (last-name lenin)
+ ": "
+ (employee-email lenin))))
+ (progn
+ (setf (slot-value employee1 'first-name) "Dimitriy"
+ (slot-value employee1 'last-name) "Ivanovich"
+ (slot-value employee1 'email) "ivanovich@soviet.org")
+ (usql:update-records-from-instance employee1)
+ (let ((lenin (car (usql:select 'employee
+ :where [= [slot-value 'employee 'emplid]
+ 1]))))
+ (concatenate 'string
+ (first-name lenin)
+ " "
+ (last-name lenin)
+ ": "
+ (employee-email lenin))))
+ (progn
+ (setf (slot-value employee1 'first-name) "Vladamir"
+ (slot-value employee1 'last-name) "Lenin"
+ (slot-value employee1 'email) "lenin@soviet.org")
+ (usql:update-records-from-instance employee1)
+ (let ((lenin (car (usql:select 'employee
+ :where [= [slot-value 'employee 'emplid]
+ 1]))))
+ (concatenate 'string
+ (first-name lenin)
+ " "
+ (last-name lenin)
+ ": "
+ (employee-email lenin)))))
+ "Vladamir Lenin: lenin@soviet.org"
+ "Dimitriy Ivanovich: ivanovich@soviet.org"
+ "Vladamir Lenin: lenin@soviet.org")
+
+;; tests update-record-from-slot
+(deftest :oodml/update-records/2
+ (values
+ (employee-email
+ (car (usql:select 'employee
+ :where [= [slot-value 'employee 'emplid] 1])))
+ (progn
+ (setf (slot-value employee1 'email) "lenin-nospam@soviet.org")
+ (usql:update-record-from-slot employee1 'email)
+ (employee-email
+ (car (usql:select 'employee
+ :where [= [slot-value 'employee 'emplid] 1]))))
+ (progn
+ (setf (slot-value employee1 'email) "lenin@soviet.org")
+ (usql:update-record-from-slot employee1 'email)
+ (employee-email
+ (car (usql:select 'employee
+ :where [= [slot-value 'employee 'emplid] 1])))))
+ "lenin@soviet.org" "lenin-nospam@soviet.org" "lenin@soviet.org")
+
+;; tests update-record-from-slots
+(deftest :oodml/update-records/3
+ (values
+ (let ((lenin (car (usql:select 'employee
+ :where [= [slot-value 'employee 'emplid]
+ 1]))))
+ (concatenate 'string
+ (first-name lenin)
+ " "
+ (last-name lenin)
+ ": "
+ (employee-email lenin)))
+ (progn
+ (setf (slot-value employee1 'first-name) "Dimitriy"
+ (slot-value employee1 'last-name) "Ivanovich"
+ (slot-value employee1 'email) "ivanovich@soviet.org")
+ (usql:update-record-from-slots employee1 '(first-name last-name email))
+ (let ((lenin (car (usql:select 'employee
+ :where [= [slot-value 'employee 'emplid]
+ 1]))))
+ (concatenate 'string
+ (first-name lenin)
+ " "
+ (last-name lenin)
+ ": "
+ (employee-email lenin))))
+ (progn
+ (setf (slot-value employee1 'first-name) "Vladamir"
+ (slot-value employee1 'last-name) "Lenin"
+ (slot-value employee1 'email) "lenin@soviet.org")
+ (usql:update-record-from-slots employee1 '(first-name last-name email))
+ (let ((lenin (car (usql:select 'employee
+ :where [= [slot-value 'employee 'emplid]
+ 1]))))
+ (concatenate 'string
+ (first-name lenin)
+ " "
+ (last-name lenin)
+ ": "
+ (employee-email lenin)))))
+ "Vladamir Lenin: lenin@soviet.org"
+ "Dimitriy Ivanovich: ivanovich@soviet.org"
+ "Vladamir Lenin: lenin@soviet.org")
+
+;; tests update-instance-from-records
+(deftest :oodml/update-instance/1
+ (values
+ (concatenate 'string
+ (slot-value employee1 'first-name)
+ " "
+ (slot-value employee1 'last-name)
+ ": "
+ (slot-value employee1 'email))
+ (progn
+ (usql:update-records [employee]
+ :av-pairs '(([first-name] "Ivan")
+ ([last-name] "Petrov")
+ ([email] "petrov@soviet.org"))
+ :where [= [emplid] 1])
+ (usql:update-instance-from-records employee1)
+ (concatenate 'string
+ (slot-value employee1 'first-name)
+ " "
+ (slot-value employee1 'last-name)
+ ": "
+ (slot-value employee1 'email)))
+ (progn
+ (usql:update-records [employee]
+ :av-pairs '(([first-name] "Vladamir")
+ ([last-name] "Lenin")
+ ([email] "lenin@soviet.org"))
+ :where [= [emplid] 1])
+ (usql:update-instance-from-records employee1)
+ (concatenate 'string
+ (slot-value employee1 'first-name)
+ " "
+ (slot-value employee1 'last-name)
+ ": "
+ (slot-value employee1 'email))))
+ "Vladamir Lenin: lenin@soviet.org"
+ "Ivan Petrov: petrov@soviet.org"
+ "Vladamir Lenin: lenin@soviet.org")
+
+;; tests update-slot-from-record
+(deftest :oodml/update-instance/2
+ (values
+ (slot-value employee1 'email)
+ (progn
+ (usql:update-records [employee]
+ :av-pairs '(([email] "lenin-nospam@soviet.org"))
+ :where [= [emplid] 1])
+ (usql:update-slot-from-record employee1 'email)
+ (slot-value employee1 'email))
+ (progn
+ (usql:update-records [employee]
+ :av-pairs '(([email] "lenin@soviet.org"))
+ :where [= [emplid] 1])
+ (usql:update-slot-from-record employee1 'email)
+ (slot-value employee1 'email)))
+ "lenin@soviet.org" "lenin-nospam@soviet.org" "lenin@soviet.org")
+
+
+;(deftest :oodml/iteration/1
+; (usql:do-query ((e) [select 'usql-tests::employee :where [married]
+; :order-by [emplid]])
+; (slot-value e last-name))
+; ("Lenin" "Stalin" "Trotsky"))
+
+;(deftest :oodml/iteration/2
+; (usql:map-query 'list #'last-name [select 'employee :where [married]
+; :order-by [emplid]])
+; ("Lenin" "Stalin" "Trotsky"))
+
+;(deftest :oodml/iteration/3
+; (loop for (e) being the tuples in
+; [select 'employee :where [married] :order-by [emplid]]
+; collect (slot-value e 'last-name))
+; ("Lenin" "Stalin" "Trotsky"))
+
+
+#.(usql:restore-sql-reader-syntax-state)
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; ======================================================================
+;;;; File: test-syntax.lisp
+;;;; Author: Marcus Pearce <m.t.pearce@city.ac.uk>
+;;;; Created: 30/03/2004
+;;;; Updated: <04/04/2004 11:51:40 marcusp>
+;;;; ======================================================================
+;;;;
+;;;; Description ==========================================================
+;;;; ======================================================================
+;;;;
+;;;; Tests for the CLSQL-USQL Symbolic SQL syntax.
+;;;;
+;;;; ======================================================================
+
+(in-package :clsql-usql-tests)
+
+#.(usql:locally-enable-sql-reader-syntax)
+
+
+(deftest :syntax/generic/1
+ (usql:sql "foo")
+ "'foo'")
+
+(deftest :syntax/generic/2
+ (usql:sql 23)
+ "23")
+
+(deftest :syntax/generic/3
+ (usql:sql 'bar)
+ "BAR")
+
+(deftest :syntax/generic/4
+ (usql:sql '("ten" 10 ten))
+ "('ten',10,TEN)")
+
+(deftest :syntax/generic/5
+ (usql:sql ["SELECT FOO,BAR FROM BAZ"])
+ "SELECT FOO,BAR FROM BAZ")
+
+
+(deftest :syntax/ident/1
+ (usql:sql [foo])
+ "FOO")
+
+(deftest :syntax/ident/2
+ (usql:sql [foo bar])
+ "FOO.BAR")
+
+;; not sure about this one
+(deftest :syntax/ident/3
+ (usql:sql ["foo" bar])
+ "foo.BAR")
+
+;(deftest :syntax/ident/4
+; (usql:sql [foo "bar"])
+; "FOO \"bar\"")
+
+(deftest :syntax/ident/5
+ (usql:sql [foo :integer])
+ "FOO INTEGER")
+
+(deftest :syntax/ident/6
+ (usql:sql [foo bar :integer])
+ "FOO.BAR INTEGER")
+
+;; not sure about this one
+(deftest :syntax/ident/7
+ (usql:sql ["foo" bar :integer])
+ "foo.BAR INTEGER")
+
+
+(deftest :syntax/value/1
+ (usql:sql [any '(3 4)])
+ "(ANY ((3,4)))")
+
+(deftest :syntax/value/2
+ (usql:sql [* 2 3])
+ "(2 * 3)")
+
+
+(deftest :syntax/relational/1
+ (usql:sql [> [baz] [beep]])
+ "(BAZ > BEEP)")
+
+(deftest :syntax/relational/2
+ (let ((x 10))
+ (usql:sql [> [foo] x]))
+ "(FOO > 10)")
+
+
+(deftest :syntax/function/1
+ (usql:sql [function "COS" [age]])
+ "COS(AGE)")
+
+(deftest :syntax/function/2
+ (usql:sql [function "TO_DATE" "02/06/99" "mm/DD/RR"])
+ "TO_DATE('02/06/99','mm/DD/RR')")
+
+(deftest :syntax/query/1
+ (usql:sql [select [person_id] [surname] :from [person]])
+ "SELECT PERSON_ID,SURNAME FROM PERSON")
+
+(deftest :syntax/query/2
+ (usql:sql [select [foo] [bar *]
+ :from '([baz] [bar])
+ :where [or [= [foo] 3]
+ [> [baz.quux] 10]]])
+ "SELECT FOO,BAR.* FROM BAZ,BAR WHERE ((FOO = 3) OR (BAZ.QUUX > 10))")
+
+(deftest :syntax/query/3
+ (usql:sql [select [foo bar] [baz]
+ :from '([foo] [quux])
+ :where [or [> [baz] 3]
+ [like [foo bar] "SU%"]]])
+ "SELECT FOO.BAR,BAZ FROM FOO,QUUX WHERE ((BAZ > 3) OR (FOO.BAR LIKE 'SU%'))")
+
+(deftest :syntax/query/4
+ (usql:sql [select [count [*]] :from [emp]])
+ "SELECT COUNT(*) FROM EMP")
+
+
+(deftest :syntax/expression1
+ (usql:sql
+ (usql:sql-operation
+ 'select
+ (usql:sql-expression :table 'foo :attribute 'bar)
+ (usql:sql-expression :attribute 'baz)
+ :from (list
+ (usql:sql-expression :table 'foo)
+ (usql:sql-expression :table 'quux))
+ :where
+ (usql:sql-operation 'or
+ (usql:sql-operation
+ '>
+ (usql:sql-expression :attribute 'baz)
+ 3)
+ (usql:sql-operation
+ 'like
+ (usql:sql-expression :table 'foo
+ :attribute 'bar)
+ "SU%"))))
+ "SELECT FOO.BAR,BAZ FROM FOO,QUUX WHERE ((BAZ > 3) OR (FOO.BAR LIKE 'SU%'))")
+
+(deftest :syntax/expression/2
+ (usql:sql
+ (apply (usql:sql-operator 'and)
+ (loop for table in '(thistime nexttime sometime never)
+ for count from 42
+ collect
+ [function "BETWEEN"
+ (usql:sql-expression :table table
+ :attribute 'bar)
+ (usql:sql-operation '* [hip] [hop])
+ count]
+ collect
+ [like (usql:sql-expression :table table
+ :attribute 'baz)
+ (usql:sql table)])))
+ "(BETWEEN(THISTIME.BAR,(HIP * HOP),42) AND (THISTIME.BAZ LIKE 'THISTIME') AND BETWEEN(NEXTTIME.BAR,(HIP * HOP),43) AND (NEXTTIME.BAZ LIKE 'NEXTTIME') AND BETWEEN(SOMETIME.BAR,(HIP * HOP),44) AND (SOMETIME.BAZ LIKE 'SOMETIME') AND BETWEEN(NEVER.BAR,(HIP * HOP),45) AND (NEVER.BAZ LIKE 'NEVER'))")
+
+#.(usql:restore-sql-reader-syntax-state)
\ No newline at end of file
--- /dev/null
+This is a list of those individuals who have contributed in some way
+or other to Uncommonsql. The sources of the attributions are CVS
+annotation, patch submission, and original authorship, write us if
+we've missed anybody.
+
+Jesse Bouwman
+
+Craig Brozefsky
+
+Sean Champ
+
+Matthew Danish
+
+Adam Di Carlo
+
+Lyn Headley
+
+John Krug
+
+Pierre Mai (original author)
+
+Christopher J. Vogt
--- /dev/null
+This document contains the copyright notices distributed with:
+
+ o UncommonSQL
+ o CLSQL
+ o MaiSQL
+
+from which this software was derived.
+
+
+UncommonSQL ================================================================
+============================================================================
+
+Copyright (c) 1999 - 2003 onShore Development, Inc.
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions
+are met:
+1. Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+2. Redistributions in binary form must reproduce the above copyright
+ notice, this list of conditions and the following disclaimer in the
+ documentation and/or other materials provided with the distribution.
+3. The name of the author may not be used to endorse or promote products
+ derived from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR
+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
+OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
+IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT,
+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
+NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
+THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+
+CLSQL ======================================================================
+============================================================================
+
+CLSQL is written and Copyright (c) 2002 by Kevin M. Rosenberg and is
+based on the MaiSQL package written and Copyright (c) 1999-2001 by
+Pierre R. Mai.
+
+CLSQL is licensed under the terms of the Lisp Lesser GNU
+Public License (http://opensource.franz.com/preamble.html), known as
+the LLGPL. The LLGPL consists of a preamble (see above URL) and the
+LGPL. Where these conflict, the preamble takes precedence.
+CLSQL is referenced in the preamble as the "LIBRARY."
+
+CLSQL is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+
+MaiSQL =====================================================================
+============================================================================
+
+ Copyright (C) 1999-2001 Pierre R. Mai
+
+ Permission is hereby granted, free of charge, to any person obtaining
+ a copy of this software and associated documentation files (the
+ "Software"), to deal in the Software without restriction, including
+ without limitation the rights to use, copy, modify, merge, publish,
+ distribute, sublicense, and/or sell copies of the Software, and to
+ permit persons to whom the Software is furnished to do so, subject to
+ the following conditions:
+
+ The above copyright notice and this permission notice shall be
+ included in all copies or substantial portions of the Software.
+
+ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
+ IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY CLAIM, DAMAGES OR
+ OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE,
+ ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
+ OTHER DEALINGS IN THE SOFTWARE.
+
+ Except as contained in this notice, the name of the author shall
+ not be used in advertising or otherwise to promote the sale, use or
+ other dealings in this Software without prior written authorization
+ from the author.
--- /dev/null
+INTRODUCTIION
+
+CLSQL-USQL is a high level SQL interface for Common Lisp which is
+based on the CommonSQL package from Xanalys. It was originally
+developed at Onshore Development, Inc. based on Pierre Mai's MaiSQL
+package. It now incorporates some of the code developed for CLSQL. See
+the files CONTRIBUTORS and COPYING for more details.
+
+CLSQL-USQL depends on the low-level database interfaces provided by
+CLSQL and includes both a functional and an object oriented
+interface to SQL RDBMS.
+
+DOCUMENTATION
+
+A CLSQL-USQL tutorial can be found in the directory doc/
+
+Also see the CommonSQL documentation avaialble on the Lispworks website:
+
+Xanalys LispWorks User Guide - The CommonSQL Package
+http://www.lispworks.com/reference/lw43/LWUG/html/lwuser-167.htm
+
+Xanalys LispWorks Reference Manual -- The SQL Package
+http://www.lispworks.com/reference/lw43/LWRM/html/lwref-383.htm
+
+CommonSQL Tutorial by Nick Levine
+http://www.ravenbrook.com/doc/2002/09/13/common-sql/
+
+
+PREREQUISITES
+
+ o COMMON LISP: currently CMUCL, SBCL, Lispworks
+ o RDBMS: currently Postgresql, Mysql, Sqlite
+ o ASDF (from http://cvs.sourceforge.net/viewcvs.py/cclan/asdf/)
+ o CLSQL-2.0.0 or later (from http://clsql.b9.com)
+ o RT for running the test suite (from http://files.b9.com/rt/rt.tar.gz)
+
+
+INSTALLATION
+
+Just load clsql-usql.asd or put it somewhere where ASDF can find it
+and call:
+
+(asdf:oos 'asdf:load-op :clsql-usql)
+
+You'll then need to load a CLSQL backend before you can do anything.
+
+To run the regression tests load clsql-usql-tests.asd or put it
+somewhere where ASDF can find it, edit the file tests/test-init.lisp
+and set the following variables to appropriate values:
+
+ *test-database-server*
+ *test-database-name*
+ *test-database-user*
+ *test-database-password*
+
+And then call:
+
+(asdf:oos 'asdf:load-op :clsql-usql-tests)
+(usql-tests:test-usql BACKEND)
+
+where BACKEND is the CLSQL database interface to use (currently one of
+:postgresql, :postgresql-socket, :sqlite or :mysql).
+
+
--- /dev/null
+
+GENERAL
+
+* test on (and port to) sbcl, lispworks, acl, scl, mcl and openmcl;
+* implement remaining functions for CLSQL AODBC backend;
+* port UncommonSQL ODBC and Oracle backends to CLSQL.
+
+
+COMMONSQL SPEC
+
+* Missing:
+
+ RECONNECT
+ CACHE-TABLE-QUERIES
+ *CACHE-TABLE-QUERIES-DEFAULT*
+ *DEFAULT-UPDATE-OBJECTS-MAX-LEN*
+ UPDATE-OBJECT-JOINS
+ INSTANCE-REFRESHED
+
+
+* Incompatible
+
+
+ >> Initialisation and connection
+
+ CONNECT
+ o should accept string as connection spec
+
+ DISCONNECT
+ o should accept string as connection spec
+
+ INITIALIZE-DATABASE-TYPE
+ o should initialise appropriate backend
+
+ STATUS
+ o what is the behaviour in CommonSQL (esp :full parameter)?
+
+
+ >> The functional sql interface
+
+ SELECT
+ o should accept keyword arg :refresh and call INSTANCE-REFRESHED
+ o should return (values result-list field-names)
+ o should coerce values returned as strings to appropriate lisp type
+
+ QUERY
+ o should return (values result-list field-names)
+ o should coerce values returned as strings to appropriate lisp type
+
+ LIST-ATTRIBUTE-TYPES
+ o should return list of (attribute datatype precision scale nullable)
+
+ LOOP
+ o the extension is currently CMUCL specific
+
+
+ >> The object-oriented sql interface
+
+ DEF-VIEW-CLASS
+ o get :target-slot working
+ o implement :retrieval :immediate
+
+ LIST-CLASSES
+ o keyword arg :root-class should do something (portable)
+
+ DO-QUERY,MAP-QUERY,LOOP
+ o should work with object queries as well as functional ones
+
+
+ >> Symbolic SQL syntax
+
+ o Complete sql expressions (see operations.lisp)
+
+ substr
+ some
+ order-by
+ times
+ nvl
+ null
+ distinct
+ except
+ intersect
+ between
+ userenv
+
+ o variables (e.g., table identifiers) should be instantiated at runtime
+
+
+
+NOTES ABOUT THE BACKENDS
+
+MYSQL
+
+drop-index: requires a table to be specified with the :from keyword parameter
+transactions: don't seem to work
+views: mysql does not support views
+queries: nested subqueries do not seem to work
+
+SQLITE
+
+create-view: column-list parameter not supported
--- /dev/null
+
+(defmethod database-query (query-expression (database closed-database) types)
+ (declare (ignore query-expression types))
+ (signal-closed-database-error database))
+
+(defmethod database-query (query-expression (database t) types)
+ (declare (ignore query-expression types))
+ (signal-no-database-error))
+
+(defmethod database-execute-command (sql-expression (database closed-database))
+ (declare (ignore sql-expression))
+ (signal-closed-database-error database))
+
+(defmethod database-execute-command (sql-expression (database t))
+ (declare (ignore sql-expression))
+ (signal-no-database-error))
+
+(defgeneric execute-command (expression &key database)
+ (:documentation
+ "Executes the SQL command specified by EXPRESSION for the database
+specified by DATABASE, which has a default value of
+*DEFAULT-DATABASE*. The argument EXPRESSION may be any SQL statement
+other than a query. To run a stored procedure, pass an appropriate
+string. The call to the procedure needs to be wrapped in a BEGIN END
+pair."))
+
+(defmethod execute-command ((sql-expression string)
+ &key (database *default-database*))
+ (record-sql-command sql-expression database)
+ (let ((res (database-execute-command sql-expression database)))
+ (record-sql-result res database))
+ (values))
--- /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 *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 " "))))))))
+
--- /dev/null
+* REGRESSION TEST SUITE GOALS
+
+The intent of this test suite is to provide sufficient coverage for
+the system to support the following:
+
+** Refactoring and Redesign of particular subsystems
+
+Refactoring and redesign efforts are normally restricted to a single
+subsystem, or perhaps to interdependent subsystems. In such cases, a
+set of regression tests which excercise the existing interface of the
+rest of USQL to the changing subsystems should be in place and passing
+before the coding starts.
+
+** Ensuring portability and Supporting new ports.
+
+The more coverage the test suite provides the easier portability is to
+maintain, particularly if we have instances of the test suite running
+against the head on the supporting lisp environment/OS/hardware/DBMS
+combinations. Since no individual within the project has the ability
+to run all of those combinations themselves, we are dependent upon some
+informal coordination between the mintainers of the various ports.
+
+** Adding new RDBMS backends
+
+The entire USQL DBMS interface needs to be excercised by the test
+suite, such that a new RDBMS backend that passes all the tests can be
+reasonably assured of working with the USQL layers above that. These
+tests should also serve as impromptu documentation for the details of
+that interface and what it expects frothe RDBMS driver layers.
+
+** Bug identification and QA
+
+As new bugs are identified, they should have a regression test written
+which excercises them. This is to ensue that we donot start
+backtracking. These tests by theselves are also very valuable for
+developers, so even if you cannot fix a bug yourself, providing a
+testto excercise it greatly reduces the amount of timea developer must
+spend finding the bug prior to fixing it.
+
+
+* TEST DESIGN ISSUES
+
+** Multiple RDBMS Issues
+
+USQL supports several RDBMS backends, and it should be possible to run
+every test against all of them. However, there are some features
+which we want tests for but which are not implemented on several of
+the backends.
+
+** Test Hygiene
+
+Tests should be able to be run multiple times against the same
+database. It is also important that they clean up after themselves
+when they create tables, sequences or other pesistent entities in the
+RDBMS backends, because often there are limits to the number of those
+thatcan exist at one time, and it also makes debuging thru the SQL
+monitors difficult when there aretons of unused tables lying around.
+
+If test need to load large datasets, they should have a mechanism to
+ensure the dataset is loaded just once, and not with every test run.
+
+Lastly, because there are various idiosyncracies with RDBMSs, please
+ensure that you run the entire test suite once when you write your
+tests, to ensure that your test does not leave some state behind which
+causes other tests to fail.
+
+** Test Run Configuration
+
+The file test-init.lisp defines several variables which can be used to
+control the connection dictionary of the database against which tests
+will be run.
+
+
+* DATABASE CONNECTIONS/LIFECYCLE
+
+** CreateDB
+ *** Without existing DB
+ *** With existing DB and use old
+ *** With existing DB and use new
+ *** Error if existing DB
+
+** Data Definition
+ *** Create Tables/Sequences/Indexes -- Should cover creation of
+ tables with all supported types of fields.
+ *** Delete Tables/Sequences/Indexes
+ *** Inspection of Tables and attributes, including types
+
+** Data Manipulation
+ *** Update
+ *** Insert
+ *** Delete
+ *** Query
+
+** Functional Interface
+ *** Creation/Modification of SQL expressions
+ *** Querying
+
+** Embedded SQL syntax
+ *** Excercise all sql operators
+
+** Object Interface
+ *** View class definition
+ *** Object creation/manipulation/deletion
+ *** Inter-object Relations
+
+** Editing Contexts
+ *** Object Create/Modification/Deletion in a context -- partly covered already
+ *** Interaction of multiple contexts
+ *** Schema manipulation within a context
+ *** Rollback and error handling within a context
\ No newline at end of file
--- /dev/null
+
+(in-package :cl-user)
+
+;; You must set these variables to appropriate values.
+(defvar *tutorial-database-type* nil
+ "Possible values are :postgresql,:postgresql-socket :mysql or :sqlite")
+(defvar *tutorial-database-name* ""
+ "The name of the database we will work in.")
+(defvar *tutorial-database-user* ""
+ "The name of the database user we will work as.")
+(defvar *tutorial-database-server* ""
+ "The name of the database server if required")
+(defvar *tutorial-database-password* ""
+ "The password if required")
+
+(sql:def-view-class employee ()
+ ((emplid
+ :db-kind :key
+ :db-constraints :not-null
+ :nulls-ok nil
+ :type integer
+ :initarg :emplid)
+ (first-name
+ :accessor first-name
+ :type (string 30)
+ :initarg :first-name)
+ (last-name
+ :accessor last-name
+ :type (string 30)
+ :initarg :last-name)
+ (email
+ :accessor employee-email
+ :type (string 100)
+ :nulls-ok t
+ :initarg :email)
+ (companyid
+ :type integer)
+ (company
+ :accessor employee-company
+ :db-kind :join
+ :db-info (:join-class company
+ :home-key companyid
+ :foreign-key companyid
+ :set nil))
+ (managerid
+ :type integer
+ :nulls-ok t)
+ (manager
+ :accessor employee-manager
+ :db-kind :join
+ :db-info (:join-class employee
+ :home-key managerid
+ :foreign-key emplid
+ :set nil)))
+ (:base-table employee))
+
+(sql:def-view-class company ()
+ ((companyid
+ :db-type :key
+ :db-constraints :not-null
+ :type integer
+ :initarg :companyid)
+ (name
+ :type (string 100)
+ :initarg :name)
+ (presidentid
+ :type integer)
+ (president
+ :reader president
+ :db-kind :join
+ :db-info (:join-class employee
+ :home-key presidentid
+ :foreign-key emplid
+ :set nil))
+ (employees
+ :reader company-employees
+ :db-kind :join
+ :db-info (:join-class employee
+ :home-key companyid
+ :foreign-key companyid
+ :set t)))
+ (:base-table company))
+
+;; Connect to the database (see the CLSQL documentation for vendor
+;; specific connection specs).
+(sql:connect `(,*tutorial-database-server*
+ ,*tutorial-database-name*
+ ,*tutorial-database-user*
+ ,*tutorial-database-password*)
+ :database-type *tutorial-database-type*)
+
+;; Record the sql going out, helps us learn what is going
+;; on behind the scenes
+(sql:start-sql-recording)
+
+;; Create the tables for our view classes
+;; First we drop them, ignoring any errors
+(ignore-errors
+ (sql:drop-view-from-class 'employee)
+ (sql:drop-view-from-class 'company))
+
+(sql:create-view-from-class 'employee)
+(sql:create-view-from-class 'company)
+
+
+;; Create some instances of our view classes
+(defvar employee1 (make-instance 'employee
+ :emplid 1
+ :first-name "Vladamir"
+ :last-name "Lenin"
+ :email "lenin@soviet.org"))
+
+(defvar company1 (make-instance 'company
+ :companyid 1
+ :name "Widgets Inc."))
+
+
+(defvar employee2 (make-instance 'employee
+ :emplid 2
+ :first-name "Josef"
+ :last-name "Stalin"
+ :email "stalin@soviet.org"))
+
+;; Lenin manages Stalin (for now)
+(sql:add-to-relation employee2 'manager employee1)
+
+;; Lenin and Stalin both work for Widgets Inc.
+(sql:add-to-relation company1 'employees employee1)
+(sql:add-to-relation company1 'employees employee2)
+
+;; Lenin is president of Widgets Inc.
+(sql:add-to-relation company1 'president employee1)
+
+(sql:update-records-from-instance employee1)
+(sql:update-records-from-instance employee2)
+(sql:update-records-from-instance company1)
+
+;; lets us use the functional
+;; sql interface
+(sql:locally-enable-sql-reader-syntax)
+
+
+(format t "The email address of ~A ~A is ~A"
+ (first-name employee1)
+ (last-name employee1)
+ (employee-email employee1))
+
+(setf (employee-email employee1) "lenin-nospam@soviets.org")
+
+;; Update the database
+(sql:update-records-from-instance employee1)
+
+(let ((new-lenin (car
+ (sql:select 'employee
+ :where [= [slot-value 'employee 'emplid] 1]))))
+ (format t "His new email is ~A"
+ (employee-email new-lenin)))
+
+
+;; Some queries
+
+;; all employees
+(sql:select 'employee)
+;; all companies
+(sql:select 'company)
+
+;; employees named Lenin
+(sql:select 'employee :where [= [slot-value 'employee 'last-name]
+ "Lenin"])
+
+(sql:select 'company :where [= [slot-value 'company 'name]
+ "Widgets Inc."])
+
+;; Employees of Widget's Inc.
+(sql:select 'employee
+ :where [and [= [slot-value 'employee 'companyid]
+ [slot-value 'company 'companyid]]
+ [= [slot-value 'company 'name]
+ "Widgets Inc."]])
+
+;; Same thing, except that we are using the employee
+;; relation in the company view class to do the join for us,
+;; saving us the work of writing out the SQL!
+(company-employees company1)
+
+;; President of Widgets Inc.
+(president company1)
+
+;; Manager of Josef Stalin
+(employee-manager employee2)
--- /dev/null
+INTRODUCTION
+
+The goal of this tutorial is to guide a new developer thru the process
+of creating a set of USQL classes providing a Object-Oriented
+interface to persistent data stored in an SQL database. We will
+assume that the reader is familiar with how SQL works, how relations
+(tables) should be structured, and has created at least one SQL
+application previously. We will also assume a minor level of
+experience with Common Lisp.
+
+UncommonSQL (USQL) provides two different interfaces to SQL databases,
+a Functional interface, and an Object-Oriented interface. The
+Functional interface consists of a special syntax for embedded SQL
+expressions in Lisp, and provides lisp functions for SQL operations
+like SELECT and UPDATE. The OO interface provides a way for mapping
+Common Lisp Objects System (CLOS) objects into databases and includes
+functions for inserting new objects, querying objects, and removing
+objects. Most applications will use a combination of the two.
+
+USQL is based on the CommonSQL package from Xanalys, so the
+documentation that Xanalys makes available online is useful for USQL
+as well. It is suggested that developers new to USQL check their
+documentation out, as any differences between CommonSQL and USQL are
+minor. Xanalys makes the following documents available:
+
+Xanalys LispWorks User Guide - The CommonSQL Package
+http://www.lispworks.com/reference/lw43/LWUG/html/lwuser-167.htm
+
+Xanalys LispWorks Reference Manual -- The SQL Package
+http://www.lispworks.com/reference/lw43/LWRM/html/lwref-383.htm
+
+CommonSQL Tutorial by Nick Levine
+http://www.ravenbrook.com/doc/2002/09/13/common-sql/
+
+
+DATA MODELING WITH UNCOMMONSQL
+
+Before we can create, query and manipulate USQL objects, we need to
+define our data model. To borrow from Philip Greenspun[1]:
+
+When data modeling, you are telling the RDBMS the following:
+
+ * What elements of the data you will store
+ * How large each element can be
+ * What kind of information each element can contain
+ * What elements may be left blank
+ * Which elements are constrained to a fixed range
+ * Whether and how various tables are to be linked
+
+With SQL database one would do this by defining a set of relations, or
+tables, followed by a set of queries for joining the tables together
+in order to construct complex records. However, with USQL we do this
+by defining a set of CLOS classes, specifying how they will be turned
+into tables, and how they can be joined to one another via relations
+between their attributes. The SQL tables, as well as the queries for
+joining them together are created for us automatically, saving us from
+dealing with some of the tedium of SQL.
+
+Let us start with a simple example of two SQL tables, and the
+relations between them.
+
+CREATE TABLE EMPLOYEE (
+ emplid NOT NULL number(38),
+ first_name NOT NULL varchar2(30),
+ last_name NOT NULL varchar2(30),
+ emall varchar2(100),
+ companyid NOT NULL number(38),
+ managerid number(38)
+)
+
+CREATE TABLE COMPANY (
+ companyid NOT NULL number(38),
+ name NOT NULL varchar2(100),
+ presidentid NOT NULL number(38)
+)
+
+This is of course the canonical SQL tutorial example, "The Org Chart".
+
+In USQL, we would have two "view classes" (a fancy word for a class
+mapped into a database). They would be defined as follows:
+
+(sql:def-view-class employee ()
+ ((emplid
+ :db-kind :key
+ :db-constraints :not-null
+ :type integer
+ :initarg :emplid)
+ (first-name
+ :accessor first-name
+ :type (string 30)
+ :initarg :first-name)
+ (last-name
+ :accessor last-name
+ :type (string 30)
+ :initarg :last-name)
+ (email
+ :accessor employee-email
+ :type (string 100)
+ :nulls-ok t
+ :initarg :email)
+ (companyid
+ :type integer)
+ (managerid
+ :type integer
+ :nulls-ok t))
+ (:base-table employee))
+
+(sql:def-view-class company ()
+ ((companyid
+ :db-type :key
+ :db-constraints :not-null
+ :type integer
+ :initarg :companyid)
+ (name
+ :type (string 100)
+ :initarg :name)
+ (presidentid
+ :type integer))
+ (:base-table company))
+
+
+The DEF-VIEW-CLASS macro is just like the normal CLOS DEFCLASS macro,
+except that it handles several slot options that DEFCLASS doesn't.
+These slot options have to do with the mapping of the slot into the
+database. We only use a few of the slot options in the above example,
+but there are several others.
+
+ :column -- The name of the SQL column this slot is stored in.
+ Defaults to the slot name. If the slot name is not a valid SQL
+ identifier, it is escaped, so foo-bar becomes foo_bar.
+
+ :db-kind -- The kind of DB mapping which is performed for this
+ slot. :BASE indicates the slot maps to an ordinary column of the
+ DB view. :KEY indicates that this slot corresponds to part of the
+ unique keys for this view, :JOIN indicates a join slot
+ representing a relation to another view and :virtual indicates
+ that this slot is an ordinary CLOS slot. Defaults to :base.
+
+ :db-reader -- If a string, then when reading values from the DB, the
+ string will be used for a format string, with the only value being
+ the value from the database. The resulting string will be used as
+ the slot value. If a function then it will take one argument, the
+ value from the database, and return the value that should be put
+ into the slot.
+
+ :db-writer -- If a string, then when reading values from the slot
+ for the DB, the string will be used for a format string, with the
+ only value being the value of the slot. The resulting string will
+ be used as the column value in the DB. If a function then it will
+ take one argument, the value of the slot, and return the value
+ that should be put into the database.
+
+ :db-type -- A string which will be used as the type specifier for
+ this slots column definition in the database.
+
+ :nulls-ok -- If t, all sql NULL values retrieved from the database
+ become nil; if nil, all NULL values retrieved are converted by
+ DATABASE-NULL-VALUE
+
+ :db-info -- A join specification.
+
+In our example each table as a primary key attribute, which is
+required to be unique. We indicate that a slot is part of the primary
+key (USQL supports multi-field primary keys) by specifying the
+:db-kind :key slot option.
+
+The SQL type of a slot when it is mapped into the database is
+determined by the :type slot option. The argument for the :type
+option is a Common Lisp datatype. The USQL framework will determine
+the appropriate mapping depending on the database system the table is
+being created in. If we really wanted to determine what SQL type was
+used for a slot, we could specify a :db-type option like "NUMBER(38)"
+and we would be guaranteed that the slot would be stored n the DB as a
+NUMBER(38). This is not recomended because it could makes your view
+class unportable across database systems.
+
+DEF-VIEW-CLASS also supports some class options, like :base-table.
+The :base-table option specifies what the table name for the view
+class will be when it is mapped into the database.
+
+
+CLASS RELATIONS
+
+In an SQL only application, the EMPLOYEE and COMPANY tables can be
+queried to determine things like, "Who is Vladamir's manager?", What
+company does Josef work for?", and "What employees work for Widgets
+Inc.". This is done by joining tables with an SQL query.
+
+Who works for Widgets Inc.?
+
+SELECT first_name, last_name FROM employee, company
+ WHERE employee.companyid = company.companyid
+ AND company.company_name = "Widgets Inc."
+
+Who is Vladamir's manager
+
+SELECT managerid FROM employee
+ WHERE employee.first_name = "Vladamir"
+ AND employee.last_name = "Lenin"
+
+What company does Josef work for?
+
+SELECT company_name FROM company, employee
+ WHERE employee.first_name = "Josef"
+ AND employee.last-name = "Stalin"
+ AND employee.companyid = company.companyid
+
+With USQL however we do not need to write out such queries because our
+view classes can maintain the relations between employees and
+companies, and employees to their managers for us. We can then access
+these relations like we would any other attribute of an employee or
+company object. In order to do this we define some join slots for our
+view classes.
+
+What company does an employee work for? If we add the following slot
+definition to the employee class we can then ask for it's COMPANY slot
+and get the appropriate result.
+
+ ;; In the employee slot list
+ (company
+ :accessor employee-company
+ :db-kind :join
+ :db-info (:join-class company
+ :home-key companyid
+ :foreign-key companyid
+ :set nil))
+
+Who are the employees of a given company? And who is the president of
+it? We add the following slot definition to the company view class and
+we can then ask for it's EMPLOYEES slot and get the right result.
+
+ ;; In the company slot list
+ (employees
+ :reader company-employees
+ :db-kind :join
+ :db-info (:join-class employee
+ :home-key companyid
+ :foreign-key companyid
+ :set t))
+
+ (president
+ :reader president
+ :db-kind :join
+ :db-info (:join-class employee
+ :home-key presidentid
+ :foreign-key emplid
+ :set nil))
+
+And lastly, to define the relation between an employee and their
+manager.
+
+ ;; In the employee slot list
+ (manager
+ :accessor employee-manager
+ :db-kind :join
+ :db-info (:join-class employee
+ :home-key managerid
+ :foreign-key emplid
+ :set nil))
+
+USQL join slots can represent one-to-one, one-to-many, and
+many-to-many relations. Above we only have one-to-one and one-to-many
+relations, later we will explain how to model many-to-many relations.
+First, let's go over the slot definitions and the available options.
+
+In order for a slot to be a join, we must specify that it's :db-kind
+:join, as opposed to :base or :key. Once we do that, we still need to
+tell USQL how to create the join statements for the relation. This is
+what the :db-info option does. It is a list of keywords and values.
+The available keywords are:
+
+ :join-class -- The view class to which we want to join. It can be
+ another view class, or the same view class as our object.
+
+ :home-key -- The slot(s) in the immediate object whose value will
+ be compared to the foreign-key slot(s) in the join-class in order
+ to join the two tables. It can be a single slot-name, or it can
+ be a list of slot names.
+
+ :foreign-key -- The slot(s) in the join-class which will be compared
+ to the value(s) of the home-key.
+
+ :set -- A boolean which if false, indicates that this is a
+ one-to-one relation, only one object will be returned. If true,
+ than this is a one-to-many relation, a list of objects will be
+ returned when we ask for this slots value.
+
+There are other :join-info options available in USQL, but we will save
+those till we get to the many-to-many relation examples.
+
+
+OBJECT CREATION
+
+Now that we have our model laid out, we should create some object.
+Let us assume that we have a database connect set up already. We
+first need to create our tables in the database:
+
+Note: the file usql-tutorial.lisp contains view class definitions
+which you can load into your list at this point in order to play along
+at home.
+
+(sql:create-view-from-class 'employee)
+(sql:create-view-from-class 'company)
+
+Then we will create our objects. We create them just like you would
+any other CLOS object:
+
+(defvar employee1 (make-instance 'employee
+ :emplid 1
+ :first-name "Vladamir"
+ :last-name "Lenin"
+ :email "lenin@soviet.org"))
+
+(defvar company1 (make-instance 'company
+ :companyid 1
+ :name "Widgets Inc."))
+
+
+(defvar employee2 (make-instance 'employee
+ :emplid 2
+ :first-name "Josef"
+ :last-name "Stalin"
+ :email "stalin@soviet.org"))
+
+In order to insert an objects into the database we use the
+UPDATE-RECORDS-FROM-INSTANCE function as follows:
+
+(sql:update-records-from-instance employee1)
+(sql:update-records-from-instance employee2)
+(sql:update-records-from-instance company1)
+
+Now we can set up some of the relations between employees and
+companies, and their managers. The ADD-TO-RELATION method provides us
+with an easy way of doing that. It will update both the relation
+slot, as well as the home-key and foreign-key slots in both objects in
+the relation.
+
+;; Lenin manages Stalin (for now)
+(sql:add-to-relation employee2 'manager employee1)
+
+;; Lenin and Stalin both work for Widgets Inc.
+(sql:add-to-relation company1 'employees employee1)
+(sql:add-to-relation company1 'employees employee2)
+
+;; Lenin is president of Widgets Inc.
+(sql:add-to-relation company1 'president employee1)
+
+After you make any changes to an object, you have to specifically tell
+USQL to update the SQL database. The UPDATE-RECORDS-FROM-INSTANCE
+method will write all of the changes you have made to the object into
+the database.
+
+Since USQL objects re just normal CLOS objects, we can manipulate
+their slots just like any other object. For instance, let's say that
+Lenin changes his email because he was getting too much SPAM fro the
+German Socialists.
+
+;; Print Lenin's current email address, change it and save it to the
+;; database. Get a new object representing Lenin from the database
+;; and print the email
+
+;; This lets us use the functional USQL interface with [] syntax
+(sql:locally-enable-sql-reader-syntax)
+
+(format t "The email address of ~A ~A is ~A"
+ (first-name employee1)
+ (last-name employee1)
+ (employee-email employee1))
+
+(setf (employee-email employee1) "lenin-nospam@soviets.org")
+
+;; Update the database
+(sql:update-records-from-instance employee1)
+
+(let ((new-lenin (car (sql:select 'employee
+ :where [= [slot-value 'employee 'emplid] 1]))))
+ (format t "His new email is ~A"
+ (employee-email new-lenin)))
+
+Everything except for the last LET expression is already familiar to
+us by now. To understand the call to SQL:SELECT we need to discuss
+the Functional SQL interface and it's integration with the Object
+Oriented interface of USQL.
+
+
+FINDING OBJECTS
+
+Now that we have our objects in the database, how do we get them out
+when we need to work with them? USQL provides a Functional interface
+to SQL, which consists of a special Lisp reader macro and some
+functions. The special syntax allows us to embed SQL in lisp
+expressions, and lisp expressions in SQL, with ease.
+
+Once we have turned on the syntax with the expression:
+
+(sql:locally-enable-sql-reader-syntax)
+
+we can start entering fragments of SQL into our lisp reader. We will
+get back objects which represent the lisp expressions. These objects
+will later be compiled into SQL expressions that are optimized for the
+database backed we are connected to. This means that we have a
+database independent SQL syntax. Here are some examples:
+
+;; an attribute or table name
+[foo] => #<MAISQL-SYS::SQL-IDENT-ATTRIBUTE FOO>
+
+;; a attribute identifier with table qualifier
+[foo bar] => #<MAISQL-SYS::SQL-IDENT-ATTRIBUTE FOO.BAR>
+
+;; a attribute identifier with table qualifier
+[= "Lenin" [first_name]] =>
+ #<MAISQL-SYS::SQL-RELATIONAL-EXP ('Lenin' = FIRST_NAME)>
+
+[< [emplid] 3] =>
+ #<MAISQL-SYS::SQL-RELATIONAL-EXP (EMPLID < 3)>
+
+[and [< [emplid] 2] [= [first_name] "Lenin"]] =>
+ #<MAISQL-SYS::SQL-RELATIONAL-EXP ((EMPLID < 2) AND
+ (FIRST_NAME = 'Lenin'))>
+
+
+;; If we want to reference a slot in an object we can us the
+;; SLOT-VALUE sql extension
+[= [slot-value 'employee 'emplid] 1] =>
+ #<MAISQL-SYS::SQL-RELATIONAL-EXP (EMPLOYEE.EMPLID = 1)>
+
+[= [slot-value 'employee 'emplid]
+ [slot-value 'company 'presidentid]] =>
+ #<MAISQL-SYS::SQL-RELATIONAL-EXP (EMPLOYEE.EMPLID = COMPANY.PRESIDENTID)>
+
+The SLOT-VALUE operator is important because it let's us query objects
+in a way that is robust to any changes in the object->table mapping,
+like column name changes, or table name changes. So when you are
+querying objects, be sure to use the SLOT-VALUE SQL extension.
+
+Since we can now formulate SQL relational expression which can be used
+as qualifiers, like we put after the WHERE keyword in SQL statements,
+we can start querying our objects. USQL provides a function SELECT
+which can return use complete objects from the database which conform
+to a qualifier, can be sorted, and various other SQL operations.
+
+The first argument to SELECT is a class name. it also has a set of
+keyword arguments which are covered in the documentation. For now we
+will concern ourselves only with the :where keyword. Select returns a
+list of objects, or nil if it can't find any. It's important to
+remember that it always returns a list, so even if you are expecting
+only one result, you should remember to extract it from the list you
+get from SELECT.
+
+;; all employees
+(sql:select 'employee)
+;; all companies
+(sql:select 'company)
+
+;; employees named Lenin
+(sql:select 'employee :where [= [slot-value 'employee 'last-name]
+ "Lenin"])
+
+(sql:select 'company :where [= [slot-value 'company 'name]
+ "Widgets Inc."])
+
+;; Employees of Widget's Inc.
+(sql:select 'employee
+ :where [and [= [slot-value 'employee 'companyid]
+ [slot-value 'company 'companyid]]
+ [= [slot-value 'company 'name]
+ "Widgets Inc."]])
+
+;; Same thing, except that we are using the employee
+;; relation in the company view class to do the join for us,
+;; saving us the work of writing out the SQL!
+(company-employees company1)
+
+;; President of Widgets Inc.
+(president company1)
+
+;; Manager of Josef Stalin
+(employee-manager employee2)
+
+
+DELETING OBJECTS
+
+Now that we know how to create objects in our database, manipulate
+them and query them (including using our predefined relations to save
+us the trouble writing alot of SQL) we should learn how to clean up
+after ourself. It's quite simple really. The function
+DELETE-INSTANCE-RECORDS will remove an object from the database.
+However, when we remove an object we are responsible for making sure
+that the database is left in a correct state.
+
+For example, if we remove a company record, we need to either remove
+all of it's employees or we need to move them to another company.
+Likewise if we remove an employee, we should make sure to update any
+other employees who had them as a manager.
+
+
+CONCLUSION
+
+There are alot more nooks and crannies to USQL, some of which are
+covered n the Xanalys documents we refered to earlier, some are not.
+The best documentation at this time is still the source code for USQL
+itself and the inline documentation for it's various function.
+
+
+
+[1] Philip Greenspun's "SQL For Web Nerds" - Data Modeling
+ http://www.arsdigita.com/books/sql/data-modeling.html
+
+
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; ======================================================================
+;;;; File: metaclasses.lisp
+;;;; Updated: <04/04/2004 12:08:11 marcusp>
+;;;; ======================================================================
+;;;;
+;;;; Description ==========================================================
+;;;; ======================================================================
+;;;;
+;;;; CLSQL-USQL metaclass for standard-db-objects created in the OODDL.
+;;;;
+;;;; ======================================================================
+
+(in-package :clsql-usql-sys)
+
+
+;; ------------------------------------------------------------
+;; metaclass: view-class
+
+(defclass standard-db-class (standard-class)
+ ((view-table
+ :accessor view-table
+ :initarg :view-table)
+ (definition
+ :accessor object-definition
+ :initarg :definition
+ :initform nil)
+ (version
+ :accessor object-version
+ :initarg :version
+ :initform 0)
+ (key-slots
+ :accessor key-slots
+ :initform nil)
+ (class-qualifier
+ :accessor view-class-qualifier
+ :initarg :qualifier
+ :initform nil))
+ (:documentation "VIEW-CLASS metaclass."))
+
+#+lispworks
+(defmacro push-on-end (value location)
+ `(setf ,location (nconc ,location (list ,value))))
+
+;; As Heiko Kirscke (author of PLOB!) would say: !@##^@%! Lispworks!
+#+lispworks
+(defconstant +extra-slot-options+ '(:column :db-kind :db-reader :nulls-ok
+ :db-writer :db-type :db-info))
+
+#+lispworks
+(define-setf-expander assoc (key alist &environment env)
+ (multiple-value-bind (temps vals stores store-form access-form)
+ (get-setf-expansion alist env)
+ (let ((new-value (gensym "NEW-VALUE-"))
+ (keyed (gensym "KEYED-"))
+ (accessed (gensym "ACCESSED-"))
+ (store-new-value (car stores)))
+ (values (cons keyed temps)
+ (cons key vals)
+ `(,new-value)
+ `(let* ((,accessed ,access-form)
+ (,store-new-value (assoc ,keyed ,accessed)))
+ (if ,store-new-value
+ (rplacd ,store-new-value ,new-value)
+ (progn
+ (setq ,store-new-value
+ (acons ,keyed ,new-value ,accessed))
+ ,store-form))
+ ,new-value)
+ `(assoc ,new-value ,access-form)))))
+
+#+lispworks
+(defmethod clos::canonicalize-defclass-slot :around
+ ((prototype standard-db-class) slot)
+ "\\lw\\ signals an error on unknown slot options; so this method
+removes any extra allowed options before calling the default method
+and returns the canonicalized extra options concatenated to the result
+of the default method. The extra allowed options are the value of the
+\\fcite{+extra-slot-options+}."
+ (let ((extra-slot-options ())
+ (rest-options ())
+ (result ()))
+ (do ((olist (cdr slot) (cddr olist)))
+ ((null olist))
+ (let ((option (car olist)))
+ (cond
+ ((find option +extra-slot-options+)
+ ;;(push (cons option (cadr olist)) extra-slot-options))
+ (setf (assoc option extra-slot-options) (cadr olist)))
+ (t
+ (push (cadr olist) rest-options)
+ (push (car olist) rest-options)))))
+ (setf result (call-next-method prototype (cons (car slot) rest-options)))
+ (dolist (option extra-slot-options)
+ (push-on-end (car option) result)
+ (push-on-end `(quote ,(cdr option)) result))
+ result))
+
+#+lispworks
+(defconstant +extra-class-options+ '(:base-table :version :schemas))
+
+#+lispworks
+(defmethod clos::canonicalize-class-options :around
+ ((prototype standard-db-class) class-options)
+ "\\lw\\ signals an error on unknown class options; so this method
+removes any extra allowed options before calling the default method
+and returns the canonicalized extra options concatenated to the result
+of the default method. The extra allowed options are the value of the
+\\fcite{+extra-class-options+}."
+ (let ((extra-class-options nil)
+ (rest-options ())
+ (result ()))
+ (dolist (o class-options)
+ (let ((option (car o)))
+ (cond
+ ((find option +extra-class-options+)
+ ;;(push (cons option (cadr o)) extra-class-options))
+ (setf (assoc option extra-class-options) (cadr o)))
+ (t
+ (push o rest-options)))))
+ (setf result (call-next-method prototype rest-options))
+ (dolist (option extra-class-options)
+ (push-on-end (car option) result)
+ (push-on-end `(quote ,(cdr option)) result))
+ result))
+
+
+(defmethod validate-superclass ((class standard-class)
+ (superclass standard-db-class))
+ t)
+
+(defmethod validate-superclass ((class standard-db-class)
+ (superclass standard-class))
+ t)
+
+
+(defun table-name-from-arg (arg)
+ (cond ((symbolp arg)
+ arg)
+ ((typep arg 'sql-ident)
+ (slot-value arg 'name))
+ ((stringp arg)
+ (intern (string-upcase arg)))))
+
+(defun column-name-from-arg (arg)
+ (cond ((symbolp arg)
+ arg)
+ ((typep arg 'sql-ident)
+ (slot-value arg 'name))
+ ((stringp arg)
+ (intern (string-upcase arg)))))
+
+
+(defun remove-keyword-arg (arglist akey)
+ (let ((mylist arglist)
+ (newlist ()))
+ (labels ((pop-arg (alist)
+ (let ((arg (pop alist))
+ (val (pop alist)))
+ (unless (equal arg akey)
+ (setf newlist (append (list arg val) newlist)))
+ (when alist (pop-arg alist)))))
+ (pop-arg mylist))
+ newlist))
+
+(defmethod initialize-instance :around ((class standard-db-class)
+ &rest all-keys
+ &key direct-superclasses base-table
+ schemas version qualifier
+ &allow-other-keys)
+ (let ((root-class (find-class 'standard-db-object nil))
+ (vmc (find-class 'standard-db-class)))
+ (setf (view-class-qualifier class)
+ (car qualifier))
+ (if root-class
+ (if (member-if #'(lambda (super)
+ (eq (class-of super) vmc)) direct-superclasses)
+ (call-next-method)
+ (apply #'call-next-method
+ class
+ :direct-superclasses (append (list root-class)
+ direct-superclasses)
+ (remove-keyword-arg all-keys :direct-superclasses)))
+ (call-next-method))
+ (setf (view-table class)
+ (table-name-from-arg (sql-escape (or (and base-table
+ (if (listp base-table)
+ (car base-table)
+ base-table))
+ (class-name class)))))
+ (setf (object-version class) version)
+ (mapc (lambda (schema)
+ (pushnew (class-name class) (gethash schema *object-schemas*)))
+ (if (listp schemas) schemas (list schemas)))
+ (register-metaclass class (nth (1+ (position :direct-slots all-keys))
+ all-keys))))
+
+(defmethod reinitialize-instance :around ((class standard-db-class)
+ &rest all-keys
+ &key base-table schemas version
+ direct-superclasses qualifier
+ &allow-other-keys)
+ (let ((root-class (find-class 'standard-db-object nil))
+ (vmc (find-class 'standard-db-class)))
+ (setf (view-table class)
+ (table-name-from-arg (sql-escape (or (and base-table
+ (if (listp base-table)
+ (car base-table)
+ base-table))
+ (class-name class)))))
+ (setf (view-class-qualifier class)
+ (car qualifier))
+ (if (and root-class (not (equal class root-class)))
+ (if (member-if #'(lambda (super)
+ (eq (class-of super) vmc)) direct-superclasses)
+ (call-next-method)
+ (apply #'call-next-method
+ class
+ :direct-superclasses (append (list root-class)
+ direct-superclasses)
+ (remove-keyword-arg all-keys :direct-superclasses)))
+ (call-next-method)))
+ (setf (object-version class) version)
+ (mapc (lambda (schema)
+ (pushnew (class-name class) (gethash schema *object-schemas*)))
+ (if (listp schemas) schemas (list schemas)))
+ (register-metaclass class (nth (1+ (position :direct-slots all-keys))
+ all-keys)))
+
+
+(defun get-keywords (keys list)
+ (flet ((extract (key)
+ (let ((pos (position key list)))
+ (when pos
+ (nth (1+ pos) list)))))
+ (mapcar #'extract keys)))
+
+(defun describe-db-layout (class)
+ (flet ((not-db-col (col)
+ (not (member (nth 2 col) '(nil :base :key))))
+ (frob-slot (slot)
+ (let ((type (slot-value slot 'type)))
+ (if (eq type t)
+ (setq type nil))
+ (list (slot-value slot 'name)
+ type
+ (slot-value slot 'db-kind)
+ (and (slot-boundp slot 'column)
+ (slot-value slot 'column))))))
+ (let ((all-slots (mapcar #'frob-slot (class-slots class))))
+ (setq all-slots (remove-if #'not-db-col all-slots))
+ (setq all-slots (stable-sort all-slots #'string< :key #'car))
+ ;;(mapcar #'dink-type all-slots)
+ all-slots)))
+
+(defun register-metaclass (class slots)
+ (labels ((not-db-col (col)
+ (not (member (nth 2 col) '(nil :base :key))))
+ (frob-slot (slot)
+ (get-keywords '(:name :type :db-kind :column) slot)))
+ (let ((all-slots (mapcar #'frob-slot slots)))
+ (setq all-slots (remove-if #'not-db-col all-slots))
+ (setq all-slots (stable-sort all-slots #'string< :key #'car))
+ (setf (object-definition class) all-slots
+ (key-slots class) (remove-if-not (lambda (slot)
+ (eql (slot-value slot 'db-kind)
+ :key))
+ (class-slots class))))))
+
+;; return the deepest view-class ancestor for a given view class
+
+(defun base-db-class (classname)
+ (let* ((class (find-class classname))
+ (db-class (find-class 'standard-db-object)))
+ (loop
+ (let ((cds (class-direct-superclasses class)))
+ (cond ((null cds)
+ (error "not a db class"))
+ ((member db-class cds)
+ (return (class-name class))))
+ (setq class (car cds))))))
+
+(defun db-ancestors (classname)
+ (let ((class (find-class classname))
+ (db-class (find-class 'standard-db-object)))
+ (labels ((ancestors (class)
+ (let ((scs (class-direct-superclasses class)))
+ (if (member db-class scs)
+ (list class)
+ (append (list class) (mapcar #'ancestors scs))))))
+ (ancestors class))))
+
+(defclass view-class-slot-definition-mixin ()
+ ((column
+ :accessor view-class-slot-column
+ :initarg :column
+ :documentation
+ "The name of the SQL column this slot is stored in. Defaults to
+the slot name.")
+ (db-kind
+ :accessor view-class-slot-db-kind
+ :initarg :db-kind
+ :initform :base
+ :type keyword
+ :documentation
+ "The kind of DB mapping which is performed for this slot. :base
+indicates the slot maps to an ordinary column of the DB view. :key
+indicates that this slot corresponds to part of the unique keys for
+this view, :join indicates ... and :virtual indicates that this slot
+is an ordinary CLOS slot. Defaults to :base.")
+ (db-reader
+ :accessor view-class-slot-db-reader
+ :initarg :db-reader
+ :initform nil
+ :documentation
+ "If a string, then when reading values from the DB, the string
+will be used for a format string, with the only value being the value
+from the database. The resulting string will be used as the slot
+value. If a function then it will take one argument, the value from
+the database, and return the value that should be put into the slot.")
+ (db-writer
+ :accessor view-class-slot-db-writer
+ :initarg :db-writer
+ :initform nil
+ :documentation
+ "If a string, then when reading values from the slot for the DB,
+the string will be used for a format string, with the only value being
+the value of the slot. The resulting string will be used as the
+column value in the DB. If a function then it will take one argument,
+the value of the slot, and return the value that should be put into
+the database.")
+ (db-type
+ :accessor view-class-slot-db-type
+ :initarg :db-type
+ :initform nil
+ :documentation
+ "A string which will be used as the type specifier for this slots
+column definition in the database.")
+ (db-constraints
+ :accessor view-class-slot-db-constraints
+ :initarg :db-constraints
+ :initform nil
+ :documentation
+ "A single constraint or list of constraints for this column")
+ (nulls-ok
+ :accessor view-class-slot-nulls-ok
+ :initarg :nulls-ok
+ :initform nil
+ :documentation
+ "If t, all sql NULL values retrieved from the database become nil; if nil,
+all NULL values retrieved are converted by DATABASE-NULL-VALUE")
+ (db-info
+ :accessor view-class-slot-db-info
+ :initarg :db-info
+ :documentation "Description of the join.")))
+
+(defparameter *db-info-lambda-list*
+ '(&key join-class
+ home-key
+ foreign-key
+ (key-join nil)
+ (target-slot nil)
+ (retrieval :immmediate)
+ (set nil)))
+
+(defun parse-db-info (db-info-list)
+ (destructuring-bind
+ (&key join-class home-key key-join foreign-key (delete-rule nil)
+ (target-slot nil) (retrieval :deferred) (set nil))
+ db-info-list
+ (let ((ih (make-hash-table :size 6)))
+ (if join-class
+ (setf (gethash :join-class ih) join-class)
+ (error "Must specify :join-class in :db-info"))
+ (if home-key
+ (setf (gethash :home-key ih) home-key)
+ (error "Must specify :home-key in :db-info"))
+ (when delete-rule
+ (setf (gethash :delete-rule ih) delete-rule))
+ (if foreign-key
+ (setf (gethash :foreign-key ih) foreign-key)
+ (error "Must specify :foreign-key in :db-info"))
+ (when key-join
+ (setf (gethash :key-join ih) t))
+ (when target-slot
+ (setf (gethash :target-slot ih) target-slot))
+ (when set
+ (setf (gethash :set ih) set))
+ (when retrieval
+ (progn
+ (setf (gethash :retrieval ih) retrieval)
+ (if (eql retrieval :immediate)
+ (setf (gethash :set ih) nil))))
+ ih)))
+
+(defclass view-class-direct-slot-definition (view-class-slot-definition-mixin
+ standard-direct-slot-definition)
+ ())
+
+(defclass view-class-effective-slot-definition (view-class-slot-definition-mixin
+ standard-effective-slot-definition)
+ ())
+
+(defmethod direct-slot-definition-class ((class standard-db-class)
+ #-cmu &rest
+ initargs)
+ (declare (ignore initargs))
+ (find-class 'view-class-direct-slot-definition))
+
+(defmethod effective-slot-definition-class ((class standard-db-class)
+ #-cmu &rest
+ initargs)
+ (declare (ignore initargs))
+ (find-class 'view-class-effective-slot-definition))
+
+;; Compute the slot definition for slots in a view-class. Figures out
+;; what kind of database value (if any) is stored there, generates and
+;; verifies the column name.
+
+(defmethod compute-effective-slot-definition ((class standard-db-class)
+ #-cmu slot-name
+ direct-slots)
+ ;(declare (ignore #-cmu slot-name direct-slots))
+ (declare (ignore #-cmu slot-name))
+ (let ((slotd (call-next-method))
+ (sd (car direct-slots)))
+
+ (typecase sd
+ (view-class-slot-definition-mixin
+ ;; Use the specified :column argument if it is supplied, otherwise
+ ;; the column slot is filled in with the slot-name, but transformed
+ ;; to be sql safe, - to _ and such.
+ (setf (slot-value slotd 'column)
+ (column-name-from-arg
+ (if (slot-boundp sd 'column)
+ (view-class-slot-column sd)
+ (column-name-from-arg
+ (sql-escape (slot-definition-name sd))))))
+
+ (setf (slot-value slotd 'db-type)
+ (when (slot-boundp sd 'db-type)
+ (view-class-slot-db-type sd)))
+
+
+ (setf (slot-value slotd 'nulls-ok)
+ (view-class-slot-nulls-ok sd))
+
+ ;; :db-kind slot value defaults to :base (store slot value in
+ ;; database)
+
+ (setf (slot-value slotd 'db-kind)
+ (if (slot-boundp sd 'db-kind)
+ (view-class-slot-db-kind sd)
+ :base))
+
+ (setf (slot-value slotd 'db-writer)
+ (when (slot-boundp sd 'db-writer)
+ (view-class-slot-db-writer sd)))
+ (setf (slot-value slotd 'db-constraints)
+ (when (slot-boundp sd 'db-constraints)
+ (view-class-slot-db-constraints sd)))
+
+
+ ;; I wonder if this slot option and the previous could be merged,
+ ;; so that :base and :key remain keyword options, but :db-kind
+ ;; :join becomes :db-kind (:join <db info .... >)?
+
+ (setf (slot-value slotd 'db-info)
+ (when (slot-boundp sd 'db-info)
+ (if (listp (view-class-slot-db-info sd))
+ (parse-db-info (view-class-slot-db-info sd))
+ (view-class-slot-db-info sd)))))
+ ;; all other slots
+ (t
+ (change-class slotd 'view-class-effective-slot-definition)
+ (setf (slot-value slotd 'column)
+ (column-name-from-arg
+ (sql-escape (slot-definition-name sd))))
+
+ (setf (slot-value slotd 'db-info) nil)
+ (setf (slot-value slotd 'db-kind)
+ :virtual)))
+ slotd))
+
+(defun slotdefs-for-slots-with-class (slots class)
+ (let ((result nil))
+ (dolist (s slots)
+ (let ((c (slotdef-for-slot-with-class s class)))
+ (if c (setf result (cons c result)))))
+ result))
+
+(defun slotdef-for-slot-with-class (slot class)
+ (find-if #'(lambda (d) (eql slot (slot-definition-name d)))
+ (class-slots class)))
+
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; ======================================================================
+;;;; File: objects.lisp
+;;;; Updated: <04/04/2004 12:07:55 marcusp>
+;;;; ======================================================================
+;;;;
+;;;; Description ==========================================================
+;;;; ======================================================================
+;;;;
+;;;; The CLSQL-USQL Object Oriented Data Definitional Language (OODDL)
+;;;; and Object Oriented Data Manipulation Language (OODML).
+;;;;
+;;;; ======================================================================
+
+(in-package :clsql-usql-sys)
+
+(defclass standard-db-object ()
+ ((view-database
+ :initform nil
+ :initarg :view-database
+ :db-kind :virtual))
+ (:metaclass standard-db-class)
+ (:documentation "Superclass for all CLSQL-USQL View Classes."))
+
+(defmethod view-database ((self standard-db-object))
+ (slot-value self 'view-database))
+
+(defvar *db-deserializing* nil)
+(defvar *db-initializing* nil)
+
+(defmethod slot-value-using-class ((class standard-db-class) instance slot)
+ (declare (optimize (speed 3)))
+ (unless *db-deserializing*
+ (let ((slot-name (%slot-name slot))
+ (slot-object (%slot-object slot class)))
+ (when (and (eql (view-class-slot-db-kind slot-object) :join)
+ (not (slot-boundp instance slot-name)))
+ (let ((*db-deserializing* t))
+ (if (view-database instance)
+ (setf (slot-value instance slot-name)
+ (fault-join-slot class instance slot-object))
+ (setf (slot-value instance slot-name) nil))))))
+ (call-next-method))
+
+(defmethod (setf slot-value-using-class) (new-value (class standard-db-class)
+ instance slot)
+ (call-next-method))
+
+;; JMM - Can't go around trying to slot-access a symbol! Guess in
+;; CMUCL slot-name is the actual slot _object_, while in lispworks it
+;; is a lowly symbol (the variable is called slot-name after all) so
+;; the object (or in MOP terminology- the "slot definition") has to be
+;; retrieved using find-slot-definition
+
+(defun %slot-name (slot)
+ #+lispworks slot
+ #-lispworks (slot-definition-name slot))
+
+(defun %slot-object (slot class)
+ (declare (ignorable class))
+ #+lispworks (clos:find-slot-definition slot class)
+ #-lispworks slot)
+
+(defmethod initialize-instance :around ((class standard-db-object)
+ &rest all-keys
+ &key &allow-other-keys)
+ (declare (ignore all-keys))
+ (let ((*db-deserializing* t))
+ (call-next-method)))
+
+(defun sequence-from-class (view-class-name)
+ (sql-escape
+ (concatenate
+ 'string
+ (symbol-name (view-table (find-class view-class-name)))
+ "-SEQ")))
+
+(defun create-sequence-from-class (view-class-name
+ &key (database *default-database*))
+ (create-sequence (sequence-from-class view-class-name) :database database))
+
+(defun drop-sequence-from-class (view-class-name
+ &key (if-does-not-exist :error)
+ (database *default-database*))
+ (drop-sequence (sequence-from-class view-class-name)
+ :if-does-not-exist if-does-not-exist
+ :database database))
+
+;;
+;; Build the database tables required to store the given view class
+;;
+
+(defmethod database-pkey-constraint ((class standard-db-class) database)
+ (let ((keylist (mapcar #'view-class-slot-column (keyslots-for-class class))))
+ (when keylist
+ (format nil "CONSTRAINT ~APK PRIMARY KEY~A"
+ (database-output-sql (view-table class) database)
+ (database-output-sql keylist database)))))
+
+
+#.(locally-enable-sql-reader-syntax)
+
+(defun ensure-schema-version-table (database)
+ (unless (table-exists-p "usql_object_v" :database database)
+ (create-table [usql_object_v] '(([name] (string 32))
+ ([vers] integer)
+ ([def] (string 32)))
+ :database database)))
+
+(defun update-schema-version-records (view-class-name
+ &key (database *default-database*))
+ (let ((schemadef nil)
+ (tclass (find-class view-class-name)))
+ (dolist (slotdef (class-slots tclass))
+ (let ((res (database-generate-column-definition view-class-name
+ slotdef database)))
+ (when res (setf schemadef (cons res schemadef)))))
+ (when schemadef
+ (delete-records :from [usql_object_v]
+ :where [= [name] (sql-escape (class-name tclass))]
+ :database database)
+ (insert-records :into [usql_object_v]
+ :av-pairs `(([name] ,(sql-escape (class-name tclass)))
+ ([vers] ,(car (object-version tclass)))
+ ([def] ,(prin1-to-string
+ (object-definition tclass))))
+ :database database))))
+
+#.(restore-sql-reader-syntax-state)
+
+(defun create-view-from-class (view-class-name
+ &key (database *default-database*))
+ "Creates a view in DATABASE based on VIEW-CLASS-NAME which defines
+the view. The argument DATABASE has a default value of
+*DEFAULT-DATABASE*."
+ (let ((tclass (find-class view-class-name)))
+ (if tclass
+ (let ((*default-database* database))
+ (%install-class tclass database)
+ (ensure-schema-version-table database)
+ (update-schema-version-records view-class-name :database database))
+ (error "Class ~s not found." view-class-name)))
+ (values))
+
+(defmethod %install-class ((self standard-db-class) database &aux schemadef)
+ (dolist (slotdef (class-slots self))
+ (let ((res (database-generate-column-definition (class-name self)
+ slotdef database)))
+ (when res
+ (push res schemadef))))
+ (unless schemadef
+ (error "Class ~s has no :base slots" self))
+ (create-table (sql-expression :table (view-table self)) schemadef
+ :database database
+ :constraints (database-pkey-constraint self database))
+ (push self (database-view-classes database))
+ t)
+
+;;
+;; Drop the tables which store the given view class
+;;
+
+#.(locally-enable-sql-reader-syntax)
+
+(defun drop-view-from-class (view-class-name &key (database *default-database*))
+ "Deletes a view or base table from DATABASE based on VIEW-CLASS-NAME
+which defines that view. The argument DATABASE has a default value of
+*DEFAULT-DATABASE*."
+ (let ((tclass (find-class view-class-name)))
+ (if tclass
+ (let ((*default-database* database))
+ (%uninstall-class tclass)
+ (delete-records :from [usql_object_v]
+ :where [= [name] (sql-escape view-class-name)]))
+ (error "Class ~s not found." view-class-name)))
+ (values))
+
+#.(restore-sql-reader-syntax-state)
+
+(defun %uninstall-class (self &key (database *default-database*))
+ (drop-table (sql-expression :table (view-table self))
+ :if-does-not-exist :ignore
+ :database database)
+ (setf (database-view-classes database)
+ (remove self (database-view-classes database))))
+
+
+;;
+;; List all known view classes
+;;
+
+(defun list-classes (&key (test #'identity)
+ (root-class 'standard-db-object)
+ (database *default-database*))
+ "Returns a list of View Classes connected to a given DATABASE which
+defaults to *DEFAULT-DATABASE*."
+ (declare (ignore root-class))
+ (remove-if #'(lambda (c) (not (funcall test c)))
+ (database-view-classes database)))
+
+;;
+;; Define a new view class
+;;
+
+(defmacro def-view-class (class supers slots &rest options)
+ "Extends the syntax of defclass to allow special slots to be mapped
+onto the attributes of database views. The macro DEF-VIEW-CLASS
+creates a class called CLASS which maps onto a database view. Such a
+class is called a View Class. The macro DEF-VIEW-CLASS extends the
+syntax of DEFCLASS to allow special base slots to be mapped onto the
+attributes of database views (presently single tables). When a select
+query that names a View Class is submitted, then the corresponding
+database view is queried, and the slots in the resulting View Class
+instances are filled with attribute values from the database. If
+SUPERS is nil then STANDARD-DB-OBJECT automatically becomes the
+superclass of the newly-defined View Class."
+ `(defclass ,class ,supers ,slots ,@options
+ (:metaclass standard-db-class)))
+
+(defun keyslots-for-class (class)
+ (slot-value class 'key-slots))
+
+(defun key-qualifier-for-instance (obj &key (database *default-database*))
+ (let ((tb (view-table (class-of obj))))
+ (flet ((qfk (k)
+ (sql-operation '==
+ (sql-expression :attribute
+ (view-class-slot-column k)
+ :table tb)
+ (db-value-from-slot
+ k
+ (slot-value obj (slot-definition-name k))
+ database))))
+ (let* ((keys (keyslots-for-class (class-of obj)))
+ (keyxprs (mapcar #'qfk (reverse keys))))
+ (cond
+ ((= (length keyxprs) 0) nil)
+ ((= (length keyxprs) 1) (car keyxprs))
+ ((> (length keyxprs) 1) (apply #'sql-operation 'and keyxprs)))))))
+
+;;
+;; Function used by 'generate-selection-list'
+;;
+
+(defun generate-attribute-reference (vclass slotdef)
+ (cond
+ ((eq (view-class-slot-db-kind slotdef) :base)
+ (sql-expression :attribute (view-class-slot-column slotdef)
+ :table (view-table vclass)))
+ ((eq (view-class-slot-db-kind slotdef) :key)
+ (sql-expression :attribute (view-class-slot-column slotdef)
+ :table (view-table vclass)))
+ (t nil)))
+
+;;
+;; Function used by 'find-all'
+;;
+
+(defun generate-selection-list (vclass)
+ (let ((sels nil))
+ (dolist (slotdef (class-slots vclass))
+ (let ((res (generate-attribute-reference vclass slotdef)))
+ (when res
+ (push (cons slotdef res) sels))))
+ (if sels
+ sels
+ (error "No slots of type :base in view-class ~A" (class-name vclass)))))
+
+;;
+;; Used by 'create-view-from-class'
+;;
+
+
+(defmethod database-generate-column-definition (class slotdef database)
+ (declare (ignore database class))
+ (when (member (view-class-slot-db-kind slotdef) '(:base :key))
+ (let ((cdef
+ (list (sql-expression :attribute (view-class-slot-column slotdef))
+ (slot-type slotdef))))
+ (let ((const (view-class-slot-db-constraints slotdef)))
+ (when const
+ (setq cdef (append cdef (list const)))))
+ cdef)))
+
+;;
+;; Called by 'get-slot-values-from-view'
+;;
+
+(declaim (inline delistify))
+(defun delistify (list)
+ (if (listp list)
+ (car list)
+ list))
+
+(defun slot-type (slotdef)
+ (let ((slot-type (slot-definition-type slotdef)))
+ (if (listp slot-type)
+ (cons (find-symbol (symbol-name (car slot-type)) :usql-sys)
+ (cdr slot-type))
+ (find-symbol (symbol-name slot-type) :usql-sys))))
+
+(defmethod update-slot-from-db ((instance standard-db-object) slotdef value)
+ (declare (optimize (speed 3) #+cmu (extensions:inhibit-warnings 3)))
+ (let ((slot-reader (view-class-slot-db-reader slotdef))
+ (slot-name (slot-definition-name slotdef))
+ (slot-type (slot-type slotdef)))
+ (cond ((and value (null slot-reader))
+ (setf (slot-value instance slot-name)
+ (read-sql-value value (delistify slot-type)
+ (view-database instance))))
+ ((null value)
+ (update-slot-with-null instance slot-name slotdef))
+ ((typep slot-reader 'string)
+ (setf (slot-value instance slot-name)
+ (format nil slot-reader value)))
+ ((typep slot-reader 'function)
+ (setf (slot-value instance slot-name)
+ (apply slot-reader (list value))))
+ (t
+ (error "Slot reader is of an unusual type.")))))
+
+(defmethod key-value-from-db (slotdef value database)
+ (declare (optimize (speed 3) #+cmu (extensions:inhibit-warnings 3)))
+ (let ((slot-reader (view-class-slot-db-reader slotdef))
+ (slot-type (slot-type slotdef)))
+ (cond ((and value (null slot-reader))
+ (read-sql-value value (delistify slot-type) database))
+ ((null value)
+ nil)
+ ((typep slot-reader 'string)
+ (format nil slot-reader value))
+ ((typep slot-reader 'function)
+ (apply slot-reader (list value)))
+ (t
+ (error "Slot reader is of an unusual type.")))))
+
+(defun db-value-from-slot (slotdef val database)
+ (let ((dbwriter (view-class-slot-db-writer slotdef))
+ (dbtype (slot-type slotdef)))
+ (typecase dbwriter
+ (string (format nil dbwriter val))
+ (function (apply dbwriter (list val)))
+ (t
+ (typecase dbtype
+ (cons
+ (database-output-sql-as-type (car dbtype) val database))
+ (t
+ (database-output-sql-as-type dbtype val database)))))))
+
+(defun check-slot-type (slotdef val)
+ (let* ((slot-type (slot-type slotdef))
+ (basetype (if (listp slot-type) (car slot-type) slot-type)))
+ (when (and slot-type val)
+ (unless (typep val basetype)
+ (error 'clsql-type-error
+ :slotname (slot-definition-name slotdef)
+ :typespec slot-type
+ :value val)))))
+
+;;
+;; Called by find-all
+;;
+
+(defmethod get-slot-values-from-view (obj slotdeflist values)
+ (flet ((update-slot (slot-def values)
+ (update-slot-from-db obj slot-def values)))
+ (mapc #'update-slot slotdeflist values)
+ obj))
+
+
+(defun synchronize-keys (src srckey dest destkey)
+ (let ((skeys (if (listp srckey) srckey (list srckey)))
+ (dkeys (if (listp destkey) destkey (list destkey))))
+ (mapcar #'(lambda (sk dk)
+ (setf (slot-value dest dk)
+ (typecase sk
+ (symbol
+ (slot-value src sk))
+ (t sk))))
+ skeys dkeys)))
+
+(defun desynchronize-keys (dest destkey)
+ (let ((dkeys (if (listp destkey) destkey (list destkey))))
+ (mapcar #'(lambda (dk)
+ (setf (slot-value dest dk) nil))
+ dkeys)))
+
+(defmethod add-to-relation ((target standard-db-object)
+ slot-name
+ (value standard-db-object))
+ (let* ((objclass (class-of target))
+ (sdef (or (slotdef-for-slot-with-class slot-name objclass)
+ (error "~s is not an known slot on ~s" slot-name target)))
+ (dbinfo (view-class-slot-db-info sdef))
+ (join-class (gethash :join-class dbinfo))
+ (homekey (gethash :home-key dbinfo))
+ (foreignkey (gethash :foreign-key dbinfo))
+ (to-many (gethash :set dbinfo)))
+ (unless (equal (type-of value) join-class)
+ (error 'clsql-type-error :slotname slot-name :typespec join-class
+ :value value))
+ (when (gethash :target-slot dbinfo)
+ (error "add-to-relation does not work with many-to-many relations yet."))
+ (if to-many
+ (progn
+ (synchronize-keys target homekey value foreignkey)
+ (if (slot-boundp target slot-name)
+ (unless (member value (slot-value target slot-name))
+ (setf (slot-value target slot-name)
+ (append (slot-value target slot-name) (list value))))
+ (setf (slot-value target slot-name) (list value))))
+ (progn
+ (synchronize-keys value foreignkey target homekey)
+ (setf (slot-value target slot-name) value)))))
+
+(defmethod remove-from-relation ((target standard-db-object)
+ slot-name (value standard-db-object))
+ (let* ((objclass (class-of target))
+ (sdef (slotdef-for-slot-with-class slot-name objclass))
+ (dbinfo (view-class-slot-db-info sdef))
+ (homekey (gethash :home-key dbinfo))
+ (foreignkey (gethash :foreign-key dbinfo))
+ (to-many (gethash :set dbinfo)))
+ (when (gethash :target-slot dbinfo)
+ (error "remove-relation does not work with many-to-many relations yet."))
+ (if to-many
+ (progn
+ (desynchronize-keys value foreignkey)
+ (if (slot-boundp target slot-name)
+ (setf (slot-value target slot-name)
+ (remove value
+ (slot-value target slot-name)
+ :test #'equal))))
+ (progn
+ (desynchronize-keys target homekey)
+ (setf (slot-value target slot-name)
+ nil)))))
+
+(defgeneric update-record-from-slot (object slot &key database)
+ (:documentation
+ "The generic function UPDATE-RECORD-FROM-SLOT updates an individual
+data item in the column represented by SLOT. The DATABASE is only used
+if OBJECT is not yet associated with any database, in which case a
+record is created in DATABASE. Only SLOT is initialized in this case;
+other columns in the underlying database receive default values. The
+argument SLOT is the CLOS slot name; the corresponding column names
+are derived from the View Class definition."))
+
+(defmethod update-record-from-slot ((obj standard-db-object) slot &key
+ (database *default-database*))
+ (let* ((vct (view-table (class-of obj)))
+ (sd (slotdef-for-slot-with-class slot (class-of obj))))
+ (check-slot-type sd (slot-value obj slot))
+ (let* ((att (view-class-slot-column sd))
+ (val (db-value-from-slot sd (slot-value obj slot) database)))
+ (cond ((and vct sd (view-database obj))
+ (update-records (sql-expression :table vct)
+ :attributes (list (sql-expression
+ :attribute att))
+ :values (list val)
+ :where (key-qualifier-for-instance
+ obj :database database)
+ :database (view-database obj)))
+ ((and vct sd (not (view-database obj)))
+ (install-instance obj :database database))
+ (t
+ (error "Unable to update record.")))))
+ (values))
+
+(defgeneric update-record-from-slots (object slots &key database)
+ (:documentation
+ "The generic function UPDATE-RECORD-FROM-SLOTS updates data in the
+columns represented by SLOTS. The DATABASE is only used if OBJECT is
+not yet associated with any database, in which case a record is
+created in DATABASE. Only slots are initialized in this case; other
+columns in the underlying database receive default values. The
+argument SLOTS contains the CLOS slot names; the corresponding column
+names are derived from the view class definition."))
+
+(defmethod update-record-from-slots ((obj standard-db-object) slots &key
+ (database *default-database*))
+ (let* ((vct (view-table (class-of obj)))
+ (sds (slotdefs-for-slots-with-class slots (class-of obj)))
+ (avps (mapcar #'(lambda (s)
+ (let ((val (slot-value
+ obj (slot-definition-name s))))
+ (check-slot-type s val)
+ (list (sql-expression
+ :attribute (view-class-slot-column s))
+ (db-value-from-slot s val database))))
+ sds)))
+ (cond ((and avps (view-database obj))
+ (update-records (sql-expression :table vct)
+ :av-pairs avps
+ :where (key-qualifier-for-instance
+ obj :database database)
+ :database (view-database obj)))
+ ((and avps (not (view-database obj)))
+ (insert-records :into (sql-expression :table vct)
+ :av-pairs avps
+ :database database)
+ (setf (slot-value obj 'view-database) database))
+ (t
+ (error "Unable to update records"))))
+ (values))
+
+(defgeneric update-records-from-instance (object &key database)
+ (:documentation
+ "Using an instance of a view class, update the database table that
+stores its instance data. If the instance is already associated with a
+database, that database is used, and database is ignored. If instance
+is not yet associated with a database, a record is created for
+instance in the appropriate table of database and the instance becomes
+associated with that database."))
+
+(defmethod update-records-from-instance ((obj standard-db-object)
+ &key (database *default-database*))
+ (labels ((slot-storedp (slot)
+ (and (member (view-class-slot-db-kind slot) '(:base :key))
+ (slot-boundp obj (slot-definition-name slot))))
+ (slot-value-list (slot)
+ (let ((value (slot-value obj (slot-definition-name slot))))
+ (check-slot-type slot value)
+ (list (sql-expression :attribute (view-class-slot-column slot))
+ (db-value-from-slot slot value database)))))
+ (let* ((view-class (class-of obj))
+ (view-class-table (view-table view-class))
+ (slots (remove-if-not #'slot-storedp (class-slots view-class)))
+ (record-values (mapcar #'slot-value-list slots)))
+ (unless record-values
+ (error "No settable slots."))
+ (if (view-database obj)
+ (update-records (sql-expression :table view-class-table)
+ :av-pairs record-values
+ :where (key-qualifier-for-instance
+ obj :database database)
+ :database (view-database obj))
+ (progn
+ (insert-records :into (sql-expression :table view-class-table)
+ :av-pairs record-values
+ :database database)
+ (setf (slot-value obj 'view-database) database)))
+ (values))))
+
+(defmethod install-instance ((obj standard-db-object)
+ &key (database *default-database*))
+ (labels ((slot-storedp (slot)
+ (and (member (view-class-slot-db-kind slot) '(:base :key))
+ (slot-boundp obj (slot-definition-name slot))))
+ (slot-value-list (slot)
+ (let ((value (slot-value obj (slot-definition-name slot))))
+ (check-slot-type slot value)
+ (list (sql-expression :attribute (view-class-slot-column slot))
+ (db-value-from-slot slot value database)))))
+ (let* ((view-class (class-of obj))
+ (view-class-table (view-table view-class))
+ (slots (remove-if-not #'slot-storedp (class-slots view-class)))
+ (record-values (mapcar #'slot-value-list slots)))
+ (unless record-values
+ (error "No settable slots."))
+ (unless
+ (let ((obj-db (slot-value obj 'view-database)))
+ (when obj-db
+ (equal obj-db database))))
+ (insert-records :into (sql-expression :table view-class-table)
+ :av-pairs record-values
+ :database database)
+ (setf (slot-value obj 'view-database) database))
+ (values)))
+
+;; Perhaps the slot class is not correct in all CLOS implementations,
+;; tho I have not run across a problem yet.
+
+(defmethod handle-cascade-delete-rule ((instance standard-db-object)
+ (slot
+ view-class-effective-slot-definition))
+ (let ((val (slot-value instance (slot-definition-name slot))))
+ (typecase val
+ (list
+ (if (gethash :target-slot (view-class-slot-db-info slot))
+ ;; For relations with target-slot, we delete just the join instance
+ (mapcar #'(lambda (obj)
+ (delete-instance-records obj))
+ (fault-join-slot-raw (class-of instance) instance slot))
+ (dolist (obj val)
+ (delete-instance-records obj))))
+ (standard-db-object
+ (delete-instance-records val)))))
+
+(defmethod nullify-join-foreign-keys ((instance standard-db-object) slot)
+ (let* ((dbi (view-class-slot-db-info slot))
+ (fkeys (gethash :foreign-keys dbi)))
+ (mapcar #'(lambda (fk)
+ (if (view-class-slot-nulls-ok slot)
+ (setf (slot-value instance fk) nil)
+ (warn "Nullify delete rule cannot set slot not allowing nulls to nil")))
+ (if (listp fkeys) fkeys (list fkeys)))))
+
+(defmethod handle-nullify-delete-rule ((instance standard-db-object)
+ (slot
+ view-class-effective-slot-definition))
+ (let ((dbi (view-class-slot-db-info slot)))
+ (if (gethash :set dbi)
+ (if (gethash :target-slot (view-class-slot-db-info slot))
+ ;;For relations with target-slot, we delete just the join instance
+ (mapcar #'(lambda (obj)
+ (nullify-join-foreign-keys obj slot))
+ (fault-join-slot-raw (class-of instance) instance slot))
+ (dolist (obj (slot-value instance (slot-definition-name slot)))
+ (nullify-join-foreign-keys obj slot)))
+ (nullify-join-foreign-keys
+ (slot-value instance (slot-definition-name slot)) slot))))
+
+(defmethod propogate-deletes ((instance standard-db-object))
+ (let* ((view-class (class-of instance))
+ (joins (remove-if #'(lambda (sd)
+ (not (equal (view-class-slot-db-kind sd) :join)))
+ (class-slots view-class))))
+ (dolist (slot joins)
+ (let ((delete-rule (gethash :delete-rule (view-class-slot-db-info slot))))
+ (cond
+ ((eql delete-rule :cascade)
+ (handle-cascade-delete-rule instance slot))
+ ((eql delete-rule :deny)
+ (when (slot-value instance (slot-definition-name slot))
+ (error
+ "Unable to delete slot ~A, because it has a deny delete rule."
+ slot)))
+ ((eql delete-rule :nullify)
+ (handle-nullify-delete-rule instance slot))
+ (t t))))))
+
+(defgeneric delete-instance-records (instance)
+ (:documentation
+ "Deletes the records represented by INSTANCE from the database
+associated with it. If instance has no associated database, an error
+is signalled."))
+
+(defmethod delete-instance-records ((instance standard-db-object))
+ (let ((vt (sql-expression :table (view-table (class-of instance))))
+ (vd (or (view-database instance) *default-database*)))
+ (when vd
+ (let ((qualifier (key-qualifier-for-instance instance :database vd)))
+ (with-transaction (:database vd)
+ (propogate-deletes instance)
+ (delete-records :from vt :where qualifier :database vd)
+ (setf (slot-value instance 'view-database) nil)))))
+ (values))
+
+(defgeneric update-instance-from-records (instance &key database)
+ (:documentation
+ "Updates the values in the slots of the View Class instance
+INSTANCE using the data in the database DATABASE which defaults to the
+database that INSTANCE is associated with, or the value of
+*DEFAULT-DATABASE*."))
+
+(defmethod update-instance-from-records ((instance standard-db-object)
+ &key (database *default-database*))
+ (let* ((view-class (find-class (class-name (class-of instance))))
+ (view-table (sql-expression :table (view-table view-class)))
+ (vd (or (view-database instance) database))
+ (view-qual (key-qualifier-for-instance instance :database vd))
+ (sels (generate-selection-list view-class))
+ (res (apply #'select (append (mapcar #'cdr sels)
+ (list :from view-table
+ :where view-qual)))))
+ (get-slot-values-from-view instance (mapcar #'car sels) (car res))))
+
+(defgeneric update-slot-from-record (instance slot &key database)
+ (:documentation
+ "Updates the value in the slot SLOT of the View Class instance
+INSTANCE using the data in the database DATABASE which defaults to the
+database that INSTANCE is associated with, or the value of
+*DEFAULT-DATABASE*."))
+
+(defmethod update-slot-from-record ((instance standard-db-object)
+ slot &key (database *default-database*))
+ (let* ((view-class (find-class (class-name (class-of instance))))
+ (view-table (sql-expression :table (view-table view-class)))
+ (vd (or (view-database instance) database))
+ (view-qual (key-qualifier-for-instance instance :database vd))
+ (slot-def (slotdef-for-slot-with-class slot view-class))
+ (att-ref (generate-attribute-reference view-class slot-def))
+ (res (select att-ref :from view-table :where view-qual)))
+ (get-slot-values-from-view instance (list slot-def) (car res))))
+
+
+(defgeneric database-null-value (type)
+ (:documentation "Return an expression of type TYPE which SQL NULL values
+will be converted into."))
+
+(defmethod database-null-value ((type t))
+ (cond
+ ((subtypep type 'string) "")
+ ((subtypep type 'integer) 0)
+ ((subtypep type 'float) (float 0.0))
+ ((subtypep type 'list) nil)
+ ((subtypep type 'boolean) nil)
+ ((subtypep type 'symbol) nil)
+ ((subtypep type 'keyword) nil)
+ ((subtypep type 'wall-time) nil)
+ (t
+ (error "Unable to handle null for type ~A" type))))
+
+(defgeneric update-slot-with-null (instance slotname slotdef)
+ (:documentation "Called to update a slot when its column has a NULL
+value. If nulls are allowed for the column, the slot's value will be
+nil, otherwise its value will be set to the result of calling
+DATABASE-NULL-VALUE on the type of the slot."))
+
+(defmethod update-slot-with-null ((instance standard-db-object)
+ slotname
+ slotdef)
+ (let ((st (slot-type slotdef))
+ (allowed (slot-value slotdef 'nulls-ok)))
+ (if allowed
+ (setf (slot-value instance slotname) nil)
+ (setf (slot-value instance slotname)
+ (database-null-value st)))))
+
+(defvar +no-slot-value+ '+no-slot-value+)
+
+(defsql sql-slot-value (:symbol "slot-value") (classname slot &optional (value +no-slot-value+) (database *default-database*))
+ (let* ((class (find-class classname))
+ (sld (slotdef-for-slot-with-class slot class)))
+ (if sld
+ (if (eq value +no-slot-value+)
+ (sql-expression :attribute (view-class-slot-column sld)
+ :table (view-table class))
+ (db-value-from-slot
+ sld
+ value
+ database))
+ (error "Unknown slot ~A for class ~A" slot classname))))
+
+(defsql sql-view-class (:symbol "view-class") (classname &optional (database *default-database*))
+ (declare (ignore database))
+ (let* ((class (find-class classname)))
+ (unless (view-table class)
+ (error "No view-table for class ~A" classname))
+ (sql-expression :table (view-table class))))
+
+(defmethod database-get-type-specifier (type args database)
+ (declare (ignore type args))
+ (if (member (database-type database) '(:postgresql :postgresql-socket))
+ "VARCHAR"
+ "VARCHAR(255)"))
+
+(defmethod database-get-type-specifier ((type (eql 'integer)) args database)
+ (declare (ignore database))
+ ;;"INT8")
+ (if args
+ (format nil "INT(~A)" (car args))
+ "INT"))
+
+(defmethod database-get-type-specifier ((type (eql 'simple-base-string)) args
+ database)
+ (if args
+ (format nil "VARCHAR(~A)" (car args))
+ (if (member (database-type database) '(:postgresql :postgresql-socket))
+ "VARCHAR"
+ "VARCHAR(255)")))
+
+(defmethod database-get-type-specifier ((type (eql 'simple-string)) args
+ database)
+ (if args
+ (format nil "VARCHAR(~A)" (car args))
+ (if (member (database-type database) '(:postgresql :postgresql-socket))
+ "VARCHAR"
+ "VARCHAR(255)")))
+
+(defmethod database-get-type-specifier ((type (eql 'string)) args database)
+ (declare (ignore database))
+ (if args
+ (format nil "VARCHAR(~A)" (car args))
+ (if (member (database-type database) '(:postgresql :postgresql-socket))
+ "VARCHAR"
+ "VARCHAR(255)")))
+
+(defmethod database-get-type-specifier ((type (eql 'wall-time)) args database)
+ (declare (ignore args))
+ (case (database-type database)
+ (:postgresql
+ "TIMESTAMP WITHOUT TIME ZONE")
+ (:postgresql-socket
+ "TIMESTAMP WITHOUT TIME ZONE")
+ (:mysql
+ "DATETIME")
+ (t "TIMESTAMP")))
+
+(defmethod database-get-type-specifier ((type (eql 'duration)) args database)
+ (declare (ignore database args))
+ "INT8")
+
+(deftype raw-string (&optional len)
+ "A string which is not trimmed when retrieved from the database"
+ `(string ,len))
+
+(defmethod database-get-type-specifier ((type (eql 'raw-string)) args database)
+ (declare (ignore database))
+ (if args
+ (format nil "VARCHAR(~A)" (car args))
+ "VARCHAR"))
+
+(defmethod database-get-type-specifier ((type (eql 'float)) args database)
+ (declare (ignore database))
+ (if args
+ (format nil "FLOAT(~A)" (car args))
+ "FLOAT"))
+
+(defmethod database-get-type-specifier ((type (eql 'long-float)) args database)
+ (declare (ignore database))
+ (if args
+ (format nil "FLOAT(~A)" (car args))
+ "FLOAT"))
+
+(defmethod database-get-type-specifier ((type (eql 'boolean)) args database)
+ (declare (ignore args database))
+ "BOOL")
+
+(defmethod database-output-sql-as-type (type val database)
+ (declare (ignore type database))
+ val)
+
+(defmethod database-output-sql-as-type ((type (eql 'list)) val database)
+ (declare (ignore database))
+ (progv '(*print-circle* *print-array*) '(t t)
+ (prin1-to-string val)))
+
+(defmethod database-output-sql-as-type ((type (eql 'symbol)) val database)
+ (declare (ignore database))
+ (if (keywordp val)
+ (symbol-name val)
+ (if val
+ (concatenate 'string
+ (package-name (symbol-package val))
+ "::"
+ (symbol-name val))
+ "")))
+
+(defmethod database-output-sql-as-type ((type (eql 'keyword)) val database)
+ (declare (ignore database))
+ (if val
+ (symbol-name val)
+ ""))
+
+(defmethod database-output-sql-as-type ((type (eql 'vector)) val database)
+ (declare (ignore database))
+ (progv '(*print-circle* *print-array*) '(t t)
+ (prin1-to-string val)))
+
+(defmethod database-output-sql-as-type ((type (eql 'array)) val database)
+ (declare (ignore database))
+ (progv '(*print-circle* *print-array*) '(t t)
+ (prin1-to-string val)))
+
+(defmethod database-output-sql-as-type ((type (eql 'boolean)) val database)
+ (declare (ignore database))
+ (if val "t" "f"))
+
+(defmethod database-output-sql-as-type ((type (eql 'string)) val database)
+ (declare (ignore database))
+ val)
+
+(defmethod database-output-sql-as-type ((type (eql 'simple-string))
+ val database)
+ (declare (ignore database))
+ val)
+
+(defmethod database-output-sql-as-type ((type (eql 'simple-base-string))
+ val database)
+ (declare (ignore database))
+ val)
+
+(defmethod read-sql-value (val type database)
+ (declare (ignore type database))
+ (read-from-string val))
+
+(defmethod read-sql-value (val (type (eql 'string)) database)
+ (declare (ignore database))
+ val)
+
+(defmethod read-sql-value (val (type (eql 'simple-string)) database)
+ (declare (ignore database))
+ val)
+
+(defmethod read-sql-value (val (type (eql 'simple-base-string)) database)
+ (declare (ignore database))
+ val)
+
+(defmethod read-sql-value (val (type (eql 'raw-string)) database)
+ (declare (ignore database))
+ val)
+
+(defmethod read-sql-value (val (type (eql 'keyword)) database)
+ (declare (ignore database))
+ (when (< 0 (length val))
+ (intern (string-upcase val) "KEYWORD")))
+
+(defmethod read-sql-value (val (type (eql 'symbol)) database)
+ (declare (ignore database))
+ (when (< 0 (length val))
+ (if (find #\: val)
+ (read-from-string val)
+ (intern (string-upcase val) "KEYWORD"))))
+
+(defmethod read-sql-value (val (type (eql 'integer)) database)
+ (declare (ignore database))
+ (etypecase val
+ (string
+ (read-from-string val))
+ (number val)))
+
+(defmethod read-sql-value (val (type (eql 'float)) database)
+ (declare (ignore database))
+ ;; writing 1.0 writes 1, so we we *really* want a float, must do (float ...)
+ (float (read-from-string val)))
+
+(defmethod read-sql-value (val (type (eql 'boolean)) database)
+ (declare (ignore database))
+ (equal "t" val))
+
+(defmethod read-sql-value (val (type (eql 'wall-time)) database)
+ (declare (ignore database))
+ (unless (eq 'NULL val)
+ (parse-timestring val)))
+
+
+;; ------------------------------------------------------------
+;; Logic for 'faulting in' :join slots
+
+(defun fault-join-slot-raw (class instance slot-def)
+ (let* ((dbi (view-class-slot-db-info slot-def))
+ (jc (gethash :join-class dbi)))
+ (let ((jq (join-qualifier class instance slot-def)))
+ (when jq
+ (select jc :where jq)))))
+
+(defun fault-join-slot (class instance slot-def)
+ (let* ((dbi (view-class-slot-db-info slot-def))
+ (ts (gethash :target-slot dbi))
+ (res (fault-join-slot-raw class instance slot-def)))
+ (when res
+ (cond
+ ((and ts (gethash :set dbi))
+ (mapcar (lambda (obj)
+ (cons obj (slot-value obj ts))) res))
+ ((and ts (not (gethash :set dbi)))
+ (mapcar (lambda (obj) (slot-value obj ts)) res))
+ ((and (not ts) (not (gethash :set dbi)))
+ (car res))
+ ((and (not ts) (gethash :set dbi))
+ res)))))
+
+(defun join-qualifier (class instance slot-def)
+ (declare (ignore class))
+ (let* ((dbi (view-class-slot-db-info slot-def))
+ (jc (find-class (gethash :join-class dbi)))
+ ;;(ts (gethash :target-slot dbi))
+ ;;(tsdef (if ts (slotdef-for-slot-with-class ts jc)))
+ (foreign-keys (gethash :foreign-key dbi))
+ (home-keys (gethash :home-key dbi)))
+ (when (every #'(lambda (slt)
+ (and (slot-boundp instance slt)
+ (not (null (slot-value instance slt)))))
+ (if (listp home-keys) home-keys (list home-keys)))
+ (let ((jc
+ (mapcar #'(lambda (hk fk)
+ (let ((fksd (slotdef-for-slot-with-class fk jc)))
+ (sql-operation '==
+ (typecase fk
+ (symbol
+ (sql-expression
+ :attribute
+ (view-class-slot-column fksd)
+ :table (view-table jc)))
+ (t fk))
+ (typecase hk
+ (symbol
+ (slot-value instance hk))
+ (t
+ hk)))))
+ (if (listp home-keys)
+ home-keys
+ (list home-keys))
+ (if (listp foreign-keys)
+ foreign-keys
+ (list foreign-keys)))))
+ (when jc
+ (if (> (length jc) 1)
+ (apply #'sql-and jc)
+ jc))))))
+
+
+(defun find-all (view-classes &rest args &key all set-operation distinct from
+ where group-by having order-by order-by-descending offset limit
+ (database *default-database*))
+ "tweeze me apart someone pleeze"
+ (declare (ignore all set-operation from group-by having offset limit)
+ (optimize (debug 3) (speed 1)))
+ (let* ((*db-deserializing* t)
+ (*default-database* (or database (error 'clsql-nodb-error))))
+ (flet ((table-sql-expr (table)
+ (sql-expression :table (view-table table)))
+ (ref-equal (ref1 ref2)
+ (equal (sql ref1)
+ (sql ref2)))
+ (tables-equal (table-a table-b)
+ (string= (string (slot-value table-a 'name))
+ (string (slot-value table-b 'name)))))
+
+ (let* ((sclasses (mapcar #'find-class view-classes))
+ (sels (mapcar #'generate-selection-list sclasses))
+ (fullsels (apply #'append sels))
+ (sel-tables (collect-table-refs where))
+ (tables
+ (remove-duplicates
+ (append (mapcar #'table-sql-expr sclasses) sel-tables)
+ :test #'tables-equal))
+ (res nil))
+ (dolist (ob (listify order-by))
+ (when (and ob (not (member ob (mapcar #'cdr fullsels)
+ :test #'ref-equal)))
+ (setq fullsels
+ (append fullsels (mapcar #'(lambda (att) (cons nil att))
+ (listify ob))))))
+ (dolist (ob (listify order-by-descending))
+ (when (and ob (not (member ob (mapcar #'cdr fullsels)
+ :test #'ref-equal)))
+ (setq fullsels
+ (append fullsels (mapcar #'(lambda (att) (cons nil att))
+ (listify ob))))))
+ (dolist (ob (listify distinct))
+ (when (and (typep ob 'sql-ident)
+ (not (member ob (mapcar #'cdr fullsels)
+ :test #'ref-equal)))
+ (setq fullsels
+ (append fullsels (mapcar #'(lambda (att) (cons nil att))
+ (listify ob))))))
+ ;;(format t "~%fullsels is : ~A" fullsels)
+ (setq res (apply #'select (append (mapcar #'cdr fullsels)
+ (cons :from (list tables)) args)))
+ (flet ((build-instance (vals)
+ (flet ((%build-instance (vclass selects)
+ (let ((class-name (class-name vclass))
+ (db-vals (butlast vals
+ (- (list-length vals)
+ (list-length selects))))
+ cache-key)
+ (setf vals (nthcdr (list-length selects) vals))
+ (loop for select in selects
+ for value in db-vals
+ do
+ (when (eql (slot-value (car select) 'db-kind)
+ :key)
+ (push
+ (key-value-from-db (car select) value
+ *default-database*)
+ cache-key)))
+ (push class-name cache-key)
+ (%make-fresh-object class-name
+ (mapcar #'car selects)
+ db-vals))))
+ (let ((instances (mapcar #'%build-instance sclasses sels)))
+ (if (= (length sclasses) 1)
+ (car instances)
+ instances)))))
+ (remove-if #'null (mapcar #'build-instance res)))))))
+
+(defun %make-fresh-object (class-name slots values)
+ (let* ((*db-initializing* t)
+ (obj (make-instance class-name
+ :view-database *default-database*)))
+ (setf obj (get-slot-values-from-view obj slots values))
+ (postinitialize obj)
+ obj))
+
+(defmethod postinitialize ((self t))
+ )
+
+(defun select (&rest select-all-args)
+ "Selects data from database given the constraints specified. Returns
+a list of lists of record values as specified by select-all-args. By
+default, the records are each represented as lists of attribute
+values. The selections argument may be either db-identifiers, literal
+strings or view classes. If the argument consists solely of view
+classes, the return value will be instances of objects rather than raw
+tuples."
+ (flet ((select-objects (target-args)
+ (and target-args
+ (every #'(lambda (arg)
+ (and (symbolp arg)
+ (find-class arg nil)))
+ target-args))))
+ (multiple-value-bind (target-args qualifier-args)
+ (query-get-selections select-all-args)
+ (if (select-objects target-args)
+ (apply #'find-all target-args qualifier-args)
+ (let ((expr (apply #'make-query select-all-args)))
+ (destructuring-bind (&key (flatp nil)
+ (database *default-database*)
+ &allow-other-keys)
+ qualifier-args
+ (let ((res (query expr :database database)))
+ (if (and flatp
+ (= (length (slot-value expr 'selections)) 1))
+ (mapcar #'car res)
+ res))))))))
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; ======================================================================
+;;;; File: operations.lisp
+;;;; Updated: <04/04/2004 12:07:26 marcusp>
+;;;; ======================================================================
+;;;;
+;;;; Description ==========================================================
+;;;; ======================================================================
+;;;;
+;;;; Definition of SQL operations used with the symbolic SQL syntax.
+;;;;
+;;;; ======================================================================
+
+(in-package :clsql-usql-sys)
+
+
+;; Keep a hashtable for mapping symbols to sql generator functions,
+;; for use by the bracketed reader syntax.
+
+(defvar *sql-op-table* (make-hash-table :test #'equal))
+
+
+;; Define an SQL operation type.
+
+(defmacro defsql (function definition-keys &body body)
+ `(progn
+ (defun ,function ,@body)
+ (let ((symbol (cadr (member :symbol ',definition-keys))))
+ (setf (gethash (if symbol (string-upcase symbol) ',function)
+ *sql-op-table*)
+ ',function))))
+
+
+;; SQL operations
+
+(defsql sql-query (:symbol "select") (&rest args)
+ (apply #'make-query args))
+
+(defsql sql-any (:symbol "any") (&rest rest)
+ (make-instance 'sql-value-exp
+ :modifier 'any :components rest))
+
+(defsql sql-all (:symbol "all") (&rest rest)
+ (make-instance 'sql-value-exp
+ :modifier 'all :components rest))
+
+(defsql sql-not (:symbol "not") (&rest rest)
+ (make-instance 'sql-value-exp
+ :modifier 'not :components rest))
+
+(defsql sql-union (:symbol "union") (&rest rest)
+ (make-instance 'sql-value-exp
+ :modifier 'union :components rest))
+
+(defsql sql-intersect (:symbol "intersect") (&rest rest)
+ (make-instance 'sql-value-exp
+ :modifier 'intersect :components rest))
+
+(defsql sql-minus (:symbol "minus") (&rest rest)
+ (make-instance 'sql-value-exp
+ :modifier 'minus :components rest))
+
+(defsql sql-group-by (:symbol "group-by") (&rest rest)
+ (make-instance 'sql-value-exp
+ :modifier 'group-by :components rest))
+
+(defsql sql-limit (:symbol "limit") (&rest rest)
+ (make-instance 'sql-value-exp
+ :modifier 'limit :components rest))
+
+(defsql sql-having (:symbol "having") (&rest rest)
+ (make-instance 'sql-value-exp
+ :modifier 'having :components rest))
+
+(defsql sql-null (:symbol "null") (&rest rest)
+ (if rest
+ (make-instance 'sql-relational-exp :operator '|IS NULL|
+ :sub-expressions (list (car rest)))
+ (make-instance 'sql-value-exp :components 'null)))
+
+(defsql sql-not-null (:symbol "not-null") ()
+ (make-instance 'sql-value-exp
+ :components '|NOT NULL|))
+
+(defsql sql-exists (:symbol "exists") (&rest rest)
+ (make-instance 'sql-value-exp
+ :modifier 'exists :components rest))
+
+(defsql sql-* (:symbol "*") (&rest rest)
+ (if (zerop (length rest))
+ (make-instance 'sql-ident :name '*)
+ ;(error 'clsql-sql-syntax-error :reason "'*' with arguments")))
+ (make-instance 'sql-relational-exp :operator '* :sub-expressions rest)))
+
+(defsql sql-+ (:symbol "+") (&rest rest)
+ (if (cdr rest)
+ (make-instance 'sql-relational-exp
+ :operator '+ :sub-expressions rest)
+ (make-instance 'sql-value-exp :modifier '+ :components rest)))
+
+(defsql sql-/ (:symbol "/") (&rest rest)
+ (make-instance 'sql-relational-exp
+ :operator '/ :sub-expressions rest))
+
+(defsql sql-- (:symbol "-") (&rest rest)
+ (if (cdr rest)
+ (make-instance 'sql-relational-exp
+ :operator '- :sub-expressions rest)
+ (make-instance 'sql-value-exp :modifier '- :components rest)))
+
+(defsql sql-like (:symbol "like") (&rest rest)
+ (make-instance 'sql-relational-exp
+ :operator 'like :sub-expressions rest))
+
+(defsql sql-uplike (:symbol "uplike") (&rest rest)
+ (make-instance 'sql-upcase-like
+ :sub-expressions rest))
+
+(defsql sql-and (:symbol "and") (&rest rest)
+ (make-instance 'sql-relational-exp
+ :operator 'and :sub-expressions rest))
+
+(defsql sql-or (:symbol "or") (&rest rest)
+ (make-instance 'sql-relational-exp
+ :operator 'or :sub-expressions rest))
+
+(defsql sql-in (:symbol "in") (&rest rest)
+ (make-instance 'sql-relational-exp
+ :operator 'in :sub-expressions rest))
+
+(defsql sql-|| (:symbol "||") (&rest rest)
+ (make-instance 'sql-relational-exp
+ :operator '|| :sub-expressions rest))
+
+(defsql sql-is (:symbol "is") (&rest rest)
+ (make-instance 'sql-relational-exp
+ :operator 'is :sub-expressions rest))
+
+(defsql sql-= (:symbol "=") (&rest rest)
+ (make-instance 'sql-relational-exp
+ :operator '= :sub-expressions rest))
+
+(defsql sql-== (:symbol "==") (&rest rest)
+ (make-instance 'sql-assignment-exp
+ :operator '= :sub-expressions rest))
+
+(defsql sql-< (:symbol "<") (&rest rest)
+ (make-instance 'sql-relational-exp
+ :operator '< :sub-expressions rest))
+
+
+(defsql sql-> (:symbol ">") (&rest rest)
+ (make-instance 'sql-relational-exp
+ :operator '> :sub-expressions rest))
+
+(defsql sql-<> (:symbol "<>") (&rest rest)
+ (make-instance 'sql-relational-exp
+ :operator '<> :sub-expressions rest))
+
+(defsql sql->= (:symbol ">=") (&rest rest)
+ (make-instance 'sql-relational-exp
+ :operator '>= :sub-expressions rest))
+
+(defsql sql-<= (:symbol "<=") (&rest rest)
+ (make-instance 'sql-relational-exp
+ :operator '<= :sub-expressions rest))
+
+(defsql sql-count (:symbol "count") (&rest rest)
+ (make-instance 'sql-function-exp
+ :name 'count :args rest))
+
+(defsql sql-max (:symbol "max") (&rest rest)
+ (make-instance 'sql-function-exp
+ :name 'max :args rest))
+
+(defsql sql-min (:symbol "min") (&rest rest)
+ (make-instance 'sql-function-exp
+ :name 'min :args rest))
+
+(defsql sql-avg (:symbol "avg") (&rest rest)
+ (make-instance 'sql-function-exp
+ :name 'avg :args rest))
+
+(defsql sql-sum (:symbol "sum") (&rest rest)
+ (make-instance 'sql-function-exp
+ :name 'sum :args rest))
+
+(defsql sql-the (:symbol "the") (&rest rest)
+ (make-instance 'sql-typecast-exp
+ :modifier (first rest) :components (second rest)))
+
+(defsql sql-function (:symbol "function") (&rest args)
+ (make-instance 'sql-function-exp
+ :name (make-symbol (car args)) :args (cdr args)))
+
+;;(defsql sql-distinct (:symbol "distinct") (&rest rest)
+;; nil)
+
+;;(defsql sql-between (:symbol "between") (&rest rest)
+;; nil)
+
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; ======================================================================
+;;;; File: package.lisp
+;;;; Author: Marcus Pearce <m.t.pearce@city.ac.uk>
+;;;; Created: 30/03/2004
+;;;; Updated: <04/04/2004 12:21:50 marcusp>
+;;;; ======================================================================
+;;;;
+;;;; Description ==========================================================
+;;;; ======================================================================
+;;;;
+;;;; Package definitions for CLSQL-USQL.
+;;;;
+;;;; ======================================================================
+
+(in-package #:cl-user)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+
+(defpackage #:clsql-usql-sys
+ (:nicknames #:usql-sys #:sql-sys)
+ (:use #:common-lisp #:clsql-base-sys #+lispworks #:clos)
+ ;; This is for working with the CMUCL/SBCL PCL MOP, which is kinda whacky
+ #+(or cmu sbcl)
+ (:shadowing-import-from #+cmu :pcl #+sbcl :sb-pcl
+ :built-in-class
+ :class-direct-slots
+ :class-name
+ :class-of
+ :class-slots
+ :compute-effective-slot-definition
+ :direct-slot-definition-class
+ :effective-slot-definition-class
+ :find-class
+ :slot-boundp
+ :slot-definition-name
+ :slot-definition-type
+ :slot-value-using-class
+ :standard-direct-slot-definition
+ :standard-effective-slot-definition
+ :validate-superclass
+ :class-direct-superclasses
+ :name
+ :standard-class)
+ (:import-from :clsql-base-sys
+ ;; conditions
+ :clsql-condition
+ :clsql-error
+ :clsql-simple-error
+ :clsql-warning
+ :clsql-simple-warning
+ :clsql-invalid-spec-error
+ :clsql-invalid-spec-error-connection-spec
+ :clsql-invalid-spec-error-database-type
+ :clsql-invalid-spec-error-template
+ :clsql-connect-error
+ :clsql-connect-error-database-type
+ :clsql-connect-error-connection-spec
+ :clsql-connect-error-errno
+ :clsql-connect-error-error
+ :clsql-sql-error
+ :clsql-sql-error-database
+ :clsql-sql-error-expression
+ :clsql-sql-error-errno
+ :clsql-sql-error-error
+ :clsql-database-warning
+ :clsql-database-warning-database
+ :clsql-database-warning-message
+ :clsql-exists-condition
+ :clsql-exists-condition-new-db
+ :clsql-exists-condition-old-db
+ :clsql-exists-warning
+ :clsql-exists-error
+ :clsql-closed-error
+ :clsql-closed-error-database
+ :clsql-type-error
+ :clsql-sql-syntax-error
+ ;; db-interface
+ :check-connection-spec
+ :database-initialize-database-type
+ :database-type-load-foreign
+ :database-name-from-spec
+ :database-create-sequence
+ :database-drop-sequence
+ :database-sequence-next
+ :database-set-sequence-position
+ :database-query-result-set
+ :database-dump-result-set
+ :database-store-next-row
+ :database-get-type-specifier
+ :database-list-tables
+ :database-list-views
+ :database-list-indexes
+ :database-list-sequences
+ :database-list-attributes
+ :database-attribute-type
+ :database-add-attribute
+ :database-type
+ ;; initialize
+ :*loaded-database-types*
+ :reload-database-types
+ :*default-database-type*
+ :*initialized-database-types*
+ :initialize-database-type
+ ;; classes
+ :database
+ :closed-database
+ :database-name
+ :command-recording-stream
+ :result-recording-stream
+ :database-view-classes
+ :database-schema
+ :conn-pool
+ :print-object
+ ;; utils
+ :sql-escape)
+ (:export
+ ;; "Private" exports for use by interface packages
+ :check-connection-spec
+ :database-initialize-database-type
+ :database-type-load-foreign
+ :database-name-from-spec
+ :database-connect
+ :database-query
+ :database-execute-command
+ :database-create-sequence
+ :database-drop-sequence
+ :database-sequence-next
+ :database-set-sequence-position
+ :database-query-result-set
+ :database-dump-result-set
+ :database-store-next-row
+ :database-get-type-specifier
+ :database-list-tables
+ :database-table-exists-p
+ :database-list-views
+ :database-view-exists-p
+ :database-list-indexes
+ :database-index-exists-p
+ :database-list-sequences
+ :database-sequence-exists-p
+ :database-list-attributes
+ :database-attribute-type
+ .
+ ;; Shared exports for re-export by USQL.
+ ;; I = Implemented, D = Documented
+ ;; name file ID
+ ;;====================================================
+ #1=(;;------------------------------------------------
+ ;; CommonSQL API
+ ;;------------------------------------------------
+ ;;FDML
+ :select ; objects xx
+ :cache-table-queries ;
+ :*cache-table-queries-default* ;
+ :delete-records ; sql xx
+ :insert-records ; sql xx
+ :update-records ; sql xx
+ :execute-command ; sql xx
+ :query ; sql xx
+ :print-query ; sql xx
+ :do-query ; sql xx
+ :map-query ; sql xx
+ :loop ; loop-ext x
+ ;;FDDL
+ :create-table ; table xx
+ :drop-table ; table xx
+ :list-tables ; table xx
+ :table-exists-p ; table xx
+ :list-attributes ; table xx
+ :attribute-type ; table xx
+ :list-attribute-types ; table xx
+ :create-view ; table xx
+ :drop-view ; table xx
+ :create-index ; table xx
+ :drop-index ; table xx
+ ;;OODDL
+ :standard-db-object ; objects xx
+ :def-view-class ; objects xx
+ :create-view-from-class ; objects xx
+ :drop-view-from-class ; objects xx
+ ;;OODML
+ :instance-refreshed ;
+ :update-object-joins ;
+ :*default-update-objects-max-len* ;
+ :update-slot-from-record ; objects xx
+ :update-instance-from-records ; objects xx
+ :update-records-from-instance ; objects xx
+ :update-record-from-slot ; objects xx
+ :update-record-from-slots ; objects xx
+ :list-classes ; objects xx
+ :delete-instance-records ; objects xx
+ ;;Symbolic SQL Syntax
+ :sql ; syntax xx
+ :sql-expression ; syntax xx
+ :sql-operation ; syntax xx
+ :sql-operator ; syntax xx
+ :disable-sql-reader-syntax ; syntax xx
+ :enable-sql-reader-syntax ; syntax xx
+ :locally-disable-sql-reader-syntax ; syntax xx
+ :locally-enable-sql-reader-syntax ; syntax xx
+ :restore-sql-reader-syntax-state ; syntax xx
+
+ ;;------------------------------------------------
+ ;; Miscellaneous Extensions
+ ;;------------------------------------------------
+ ;;Initialization
+ :*loaded-database-types* ; clsql-base xx
+ :reload-database-types ; clsql-base xx
+ :closed-database ; database xx
+ :database-type ; database x
+ :in-schema ; classes x
+ ;;FDDL
+ :list-views ; table xx
+ :view-exists-p ; table xx
+ :list-indexes ; table xx
+ :index-exists-p ; table xx
+ :create-sequence ; table xx
+ :drop-sequence ; table xx
+ :list-sequences ; table xx
+ :sequence-exists-p ; table xx
+ :sequence-next ; table xx
+ :sequence-last ; table xx
+ :set-sequence-position ; table xx
+ ;;OODDL
+ :view-table ; metaclass x
+ :create-sequence-from-class ; objects x
+ :drop-sequence-from-class ; objects x
+ ;;OODML
+ :add-to-relation ; objects x
+ :remove-from-relation ; objects x
+ :read-sql-value ; objects x
+ :database-output-sql-as-type ; objects x
+ :database-get-type-specifier ; objects x
+ :database-output-sql ; sql/class xx
+
+ ;;-----------------------------------------------
+ ;; Conditions/Warnings/Errors
+ ;;-----------------------------------------------
+ :clsql-condition
+ :clsql-error
+ :clsql-simple-error
+ :clsql-warning
+ :clsql-simple-warning
+ :clsql-invalid-spec-error
+ :clsql-invalid-spec-error-connection-spec
+ :clsql-invalid-spec-error-database-type
+ :clsql-invalid-spec-error-template
+ :clsql-connect-error
+ :clsql-connect-error-database-type
+ :clsql-connect-error-connection-spec
+ :clsql-connect-error-errno
+ :clsql-connect-error-error
+ :clsql-sql-error
+ :clsql-type-error
+ :clsql-sql-error-database
+ :clsql-sql-error-expression
+ :clsql-sql-error-errno
+ :clsql-sql-error-error
+ :clsql-exists-condition
+ :clsql-exists-condition-new-db
+ :clsql-exists-condition-old-db
+ :clsql-exists-warning
+ :clsql-exists-error
+ :clsql-closed-error
+ :clsql-closed-error-database
+
+ ;;-----------------------------------------------
+ ;; Symbolic Sql Syntax
+ ;;-----------------------------------------------
+ :sql-and-qualifier
+ :sql-escape
+ :sql-query
+ :sql-any
+ :sql-all
+ :sql-not
+ :sql-union
+ :sql-intersection
+ :sql-minus
+ :sql-group-by
+ :sql-having
+ :sql-null
+ :sql-not-null
+ :sql-exists
+ :sql-*
+ :sql-+
+ :sql-/
+ :sql-like
+ :sql-uplike
+ :sql-and
+ :sql-or
+ :sql-in
+ :sql-||
+ :sql-is
+ :sql-=
+ :sql-==
+ :sql-<
+ :sql->
+ :sql->=
+ :sql-<=
+ :sql-count
+ :sql-max
+ :sql-min
+ :sql-avg
+ :sql-sum
+ :sql-view-class
+ :sql_slot-value
+
+))
+ (:documentation "This is the INTERNAL SQL-Interface package of USQL."))
+
+
+;; see http://thread.gmane.org/gmane.lisp.lispworks.general/681
+#+lispworks
+(setf *packages-for-warn-on-redefinition*
+ (delete "SQL" *packages-for-warn-on-redefinition* :test 'string=))
+
+(defpackage #:clsql-usql
+ (:nicknames #:usql #:sql)
+ (:use :common-lisp)
+ (:import-from :clsql-usql-sys . #1#)
+ (:export . #1#)
+ (:documentation "This is the SQL-Interface package of USQL."))
+
+);eval-when
+
+
--- /dev/null
+
+;; Note that this will no longer required for cmucl as of version 19a.
+
+(in-package #+cmu :pcl #+sbcl :sb-pcl)
+
+(defmacro pv-binding1 ((pv calls pv-table-symbol pv-parameters slot-vars)
+ &body body)
+ `(pv-env (,pv ,calls ,pv-table-symbol ,pv-parameters)
+ (let (,@(mapcar #'(lambda (slot-var p) `(,slot-var (get-slots-or-nil ,p)))
+ slot-vars pv-parameters))
+ ,@(mapcar #'(lambda (slot-var) `(declare (ignorable ,slot-var))) slot-vars)
+ ,@body)))
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; ======================================================================
+;;;; File: sql.lisp
+;;;; Updated: <04/04/2004 12:05:32 marcusp>
+;;;; ======================================================================
+;;;;
+;;;; Description ==========================================================
+;;;; ======================================================================
+;;;;
+;;;; The CLSQL-USQL Functional Data Manipulation Language (FDML).
+;;;;
+;;;; ======================================================================
+
+(in-package :clsql-usql-sys)
+
+
+;;; Basic operations on databases
+
+
+(defmethod database-query-result-set ((expr %sql-expression) database
+ &key full-set types)
+ (database-query-result-set (sql-output expr database) database
+ :full-set full-set :types types))
+
+(defmethod execute-command ((expr %sql-expression)
+ &key (database *default-database*))
+ (execute-command (sql-output expr database) :database database)
+ (values))
+
+
+
+(defmethod query ((expr %sql-expression) &key (database *default-database*)
+ (result-types nil) (flatp nil))
+ (query (sql-output expr database) :database database :flatp flatp
+ :result-types result-types))
+
+(defun print-query (query-exp &key titles (formats t) (sizes t) (stream t)
+ (database *default-database*))
+ "The PRINT-QUERY function takes a symbolic SQL query expression and
+formatting information and prints onto STREAM a table containing the
+results of the query. A list of strings to use as column headings is
+given by TITLES, which has a default value of NIL. The FORMATS
+argument is a list of format strings used to print each attribute, and
+has a default value of T, which means that ~A or ~VA are used if sizes
+are provided or computed. The field sizes are given by SIZES. It has a
+default value of T, which specifies that minimum sizes are
+computed. The output stream is given by STREAM, which has a default
+value of T. This specifies that *STANDARD-OUTPUT* is used."
+ (flet ((compute-sizes (data)
+ (mapcar #'(lambda (x) (apply #'max (mapcar #'length x)))
+ (apply #'mapcar (cons #'list data))))
+ (format-record (record control sizes)
+ (format stream "~&~?" control
+ (if (null sizes) record
+ (mapcan #'(lambda (s f) (list s f)) sizes record)))))
+ (let* ((query-exp (etypecase query-exp
+ (string query-exp)
+ (sql-query (sql-output query-exp))))
+ (data (query query-exp :database database))
+ (sizes (if (or (null sizes) (listp sizes)) sizes
+ (compute-sizes (if titles (cons titles data) data))))
+ (formats (if (or (null formats) (not (listp formats)))
+ (make-list (length (car data)) :initial-element
+ (if (null sizes) "~A " "~VA "))
+ formats))
+ (control-string (format nil "~{~A~}" formats)))
+ (when titles (format-record titles control-string sizes))
+ (dolist (d data (values)) (format-record d control-string sizes)))))
+
+(defun insert-records (&key (into nil)
+ (attributes nil)
+ (values nil)
+ (av-pairs nil)
+ (query nil)
+ (database *default-database*))
+ "Inserts a set of values into a table. The records created contain
+values for attributes (or av-pairs). The argument VALUES is a list of
+values. If ATTRIBUTES is supplied then VALUES must be a corresponding
+list of values for each of the listed attribute names. If AV-PAIRS is
+non-nil, then both ATTRIBUTES and VALUES must be nil. If QUERY is
+non-nil, then neither VALUES nor AV-PAIRS should be. QUERY should be a
+query expression, and the attribute names in it must also exist in the
+table INTO. The default value of DATABASE is *DEFAULT-DATABASE*."
+ (let ((stmt (make-sql-insert :into into :attrs attributes
+ :vals values :av-pairs av-pairs
+ :subquery query)))
+ (execute-command stmt :database database)))
+
+(defun make-sql-insert (&key (into nil)
+ (attrs nil)
+ (vals nil)
+ (av-pairs nil)
+ (subquery nil))
+ (if (null into)
+ (error 'clsql-sql-syntax-error :reason ":into keyword not supplied"))
+ (let ((ins (make-instance 'sql-insert :into into)))
+ (with-slots (attributes values query)
+ ins
+ (cond ((and vals (not attrs) (not query) (not av-pairs))
+ (setf values vals))
+ ((and vals attrs (not subquery) (not av-pairs))
+ (setf attributes attrs)
+ (setf values vals))
+ ((and av-pairs (not vals) (not attrs) (not subquery))
+ (setf attributes (mapcar #'car av-pairs))
+ (setf values (mapcar #'cadr av-pairs)))
+ ((and subquery (not vals) (not attrs) (not av-pairs))
+ (setf query subquery))
+ ((and subquery attrs (not vals) (not av-pairs))
+ (setf attributes attrs)
+ (setf query subquery))
+ (t
+ (error 'clsql-sql-syntax-error
+ :reason "bad or ambiguous keyword combination.")))
+ ins)))
+
+(defun delete-records (&key (from nil)
+ (where nil)
+ (database *default-database*))
+ "Deletes rows from a database table specified by FROM in which the
+WHERE condition is true. The argument DATABASE specifies a database
+from which the records are to be removed, and defaults to
+*default-database*."
+ (let ((stmt (make-instance 'sql-delete :from from :where where)))
+ (execute-command stmt :database database)))
+
+(defun update-records (table &key
+ (attributes nil)
+ (values nil)
+ (av-pairs nil)
+ (where nil)
+ (database *default-database*))
+ "Changes the values of existing fields in TABLE with columns
+specified by ATTRIBUTES and VALUES (or AV-PAIRS) where the WHERE
+condition is true."
+ (when av-pairs
+ (setf attributes (mapcar #'car av-pairs)
+ values (mapcar #'cadr av-pairs)))
+ (let ((stmt (make-instance 'sql-update :table table
+ :attributes attributes
+ :values values
+ :where where)))
+ (execute-command stmt :database database)))
+
+
+;; iteration
+
+(defun map-query (output-type-spec function query-expression
+ &key (database *default-database*)
+ (types nil))
+ "Map the function over all tuples that are returned by the query in
+query-expression. The results of the function are collected as
+specified in output-type-spec and returned like in MAP."
+ ;; DANGER Will Robinson: Parts of the code for implementing
+ ;; map-query (including the code below and the helper functions
+ ;; called) are highly CMU CL specific.
+ ;; KMR -- these have been replaced with cross-platform instructions above
+ (macrolet ((type-specifier-atom (type)
+ `(if (atom ,type) ,type (car ,type))))
+ (case (type-specifier-atom output-type-spec)
+ ((nil)
+ (map-query-for-effect function query-expression database types))
+ (list
+ (map-query-to-list function query-expression database types))
+ ((simple-vector simple-string vector string array simple-array
+ bit-vector simple-bit-vector base-string
+ simple-base-string)
+ (map-query-to-simple output-type-spec function query-expression
+ database types))
+ (t
+ (funcall #'map-query
+ (cmucl-compat:result-type-or-lose output-type-spec t)
+ function query-expression :database database :types types)))))
+
+(defun map-query-for-effect (function query-expression database types)
+ (multiple-value-bind (result-set columns)
+ (database-query-result-set query-expression database :full-set nil
+ :types types)
+ (when result-set
+ (unwind-protect
+ (do ((row (make-list columns)))
+ ((not (database-store-next-row result-set database row))
+ nil)
+ (apply function row))
+ (database-dump-result-set result-set database)))))
+
+(defun map-query-to-list (function query-expression database types)
+ (multiple-value-bind (result-set columns)
+ (database-query-result-set query-expression database :full-set nil
+ :types types)
+ (when result-set
+ (unwind-protect
+ (let ((result (list nil)))
+ (do ((row (make-list columns))
+ (current-cons result (cdr current-cons)))
+ ((not (database-store-next-row result-set database row))
+ (cdr result))
+ (rplacd current-cons (list (apply function row)))))
+ (database-dump-result-set result-set database)))))
+
+(defun map-query-to-simple (output-type-spec function query-expression
+ database types)
+ (multiple-value-bind (result-set columns rows)
+ (database-query-result-set query-expression database :full-set t
+ :types types)
+ (when result-set
+ (unwind-protect
+ (if rows
+ ;; We know the row count in advance, so we allocate once
+ (do ((result
+ (cmucl-compat:make-sequence-of-type output-type-spec rows))
+ (row (make-list columns))
+ (index 0 (1+ index)))
+ ((not (database-store-next-row result-set database row))
+ result)
+ (declare (fixnum index))
+ (setf (aref result index)
+ (apply function row)))
+ ;; Database can't report row count in advance, so we have
+ ;; to grow and shrink our vector dynamically
+ (do ((result
+ (cmucl-compat:make-sequence-of-type output-type-spec 100))
+ (allocated-length 100)
+ (row (make-list columns))
+ (index 0 (1+ index)))
+ ((not (database-store-next-row result-set database row))
+ (cmucl-compat:shrink-vector result index))
+ (declare (fixnum allocated-length index))
+ (when (>= index allocated-length)
+ (setf allocated-length (* allocated-length 2)
+ result (adjust-array result allocated-length)))
+ (setf (aref result index)
+ (apply function row))))
+ (database-dump-result-set result-set database)))))
+
+(defmacro do-query (((&rest args) query-expression
+ &key (database '*default-database*) (types nil))
+ &body body)
+ "Repeatedly executes BODY within a binding of ARGS on the attributes
+of each record resulting from QUERY. The return value is determined by
+the result of executing BODY. The default value of DATABASE is
+*DEFAULT-DATABASE*."
+ (let ((result-set (gensym))
+ (columns (gensym))
+ (row (gensym))
+ (db (gensym)))
+ `(let ((,db ,database))
+ (multiple-value-bind (,result-set ,columns)
+ (database-query-result-set ,query-expression ,db
+ :full-set nil :types ,types)
+ (when ,result-set
+ (unwind-protect
+ (do ((,row (make-list ,columns)))
+ ((not (database-store-next-row ,result-set ,db ,row))
+ nil)
+ (destructuring-bind ,args ,row
+ ,@body))
+ (database-dump-result-set ,result-set ,db)))))))
+
+
+;; output-sql
+
+(defmethod database-output-sql ((str string) database)
+ (declare (ignore database)
+ (optimize (speed 3) (safety 1) #+cmu (extensions:inhibit-warnings 3))
+ (type (simple-array * (*)) str))
+ (let ((len (length str)))
+ (declare (type fixnum len))
+ (cond ((= len 0)
+ +empty-string+)
+ ((and (null (position #\' str))
+ (null (position #\\ str)))
+ (concatenate 'string "'" str "'"))
+ (t
+ (let ((buf (make-string (+ (* len 2) 2) :initial-element #\')))
+ (do* ((i 0 (incf i))
+ (j 1 (incf j)))
+ ((= i len) (subseq buf 0 (1+ j)))
+ (declare (type integer i j))
+ (let ((char (aref str i)))
+ (cond ((eql char #\')
+ (setf (aref buf j) #\\)
+ (incf j)
+ (setf (aref buf j) #\'))
+ ((eql char #\\)
+ (setf (aref buf j) #\\)
+ (incf j)
+ (setf (aref buf j) #\\))
+ (t
+ (setf (aref buf j) char))))))))))
+
+(let ((keyword-package (symbol-package :foo)))
+ (defmethod database-output-sql ((sym symbol) database)
+ (declare (ignore database))
+ (if (equal (symbol-package sym) keyword-package)
+ (concatenate 'string "'" (string sym) "'")
+ (symbol-name sym))))
+
+(defmethod database-output-sql ((tee (eql t)) database)
+ (declare (ignore database))
+ "'Y'")
+
+(defmethod database-output-sql ((num number) database)
+ (declare (ignore database))
+ (princ-to-string num))
+
+(defmethod database-output-sql ((arg list) database)
+ (if (null arg)
+ "NULL"
+ (format nil "(~{~A~^,~})" (mapcar #'(lambda (val)
+ (sql-output val database))
+ arg))))
+
+(defmethod database-output-sql ((arg vector) database)
+ (format nil "~{~A~^,~}" (map 'list #'(lambda (val)
+ (sql-output val database))
+ arg)))
+
+(defmethod database-output-sql ((self wall-time) database)
+ (declare (ignore database))
+ (db-timestring self))
+
+(defmethod database-output-sql (thing database)
+ (if (or (null thing)
+ (eq 'null thing))
+ "NULL"
+ (error 'clsql-simple-error
+ :format-control
+ "No type conversion to SQL for ~A is defined for DB ~A."
+ :format-arguments (list (type-of thing) (type-of database)))))
+
+(defmethod output-sql-hash-key ((arg vector) &optional database)
+ (list 'vector (map 'list (lambda (arg)
+ (or (output-sql-hash-key arg database)
+ (return-from output-sql-hash-key nil)))
+ arg)))
+
+(defmethod output-sql (expr &optional (database *default-database*))
+ (write-string (database-output-sql expr database) *sql-stream*)
+ t)
+
+(defmethod output-sql ((expr list) &optional (database *default-database*))
+ (if (null expr)
+ (write-string +null-string+ *sql-stream*)
+ (progn
+ (write-char #\( *sql-stream*)
+ (do ((item expr (cdr item)))
+ ((null (cdr item))
+ (output-sql (car item) database))
+ (output-sql (car item) database)
+ (write-char #\, *sql-stream*))
+ (write-char #\) *sql-stream*)))
+ t)
+
+
--- /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)))
+
+
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; ======================================================================
+;;;; File: table.lisp
+;;;; Updated: <04/04/2004 12:05:03 marcusp>
+;;;; ======================================================================
+;;;;
+;;;; Description ==========================================================
+;;;; ======================================================================
+;;;;
+;;;; The CLSQL-USQL Functional Data Definition Language (FDDL)
+;;;; including functions for schema manipulation. Currently supported
+;;;; SQL objects include tables, views, indexes, attributes and
+;;;; sequences.
+;;;;
+;;;; ======================================================================
+
+(in-package :clsql-usql-sys)
+
+
+;; Utilities
+
+(defun database-identifier (name)
+ (sql-escape (etypecase name
+ (string
+ (string-upcase name))
+ (sql-ident
+ (sql-output name))
+ (symbol
+ (sql-output name)))))
+
+
+;; Tables
+
+(defvar *table-schemas* (make-hash-table :test #'equal)
+ "Hash of schema name to table lists.")
+
+(defun create-table (name description &key (database *default-database*)
+ (constraints nil))
+ "Create a table called NAME, in DATABASE which defaults to
+*DEFAULT-DATABASE*, containing the attributes in DESCRIPTION which is
+a list containing lists of attribute-name and type information pairs."
+ (let* ((table-name (etypecase name
+ (symbol (sql-expression :attribute name))
+ (string (sql-expression :attribute (make-symbol name)))
+ (sql-ident name)))
+ (stmt (make-instance 'sql-create-table
+ :name table-name
+ :columns description
+ :modifiers constraints)))
+ (pushnew table-name (gethash *default-schema* *table-schemas*)
+ :test #'equal)
+ (execute-command stmt :database database)))
+
+(defun drop-table (name &key (if-does-not-exist :error)
+ (database *default-database*))
+ "Drops table NAME from DATABASE which defaults to
+*DEFAULT-DATABASE*. If the table does not exist and IF-DOES-NOT-EXIST
+is :ignore then DROP-TABLE returns nil whereas an error is signalled
+if IF-DOES-NOT-EXIST is :error."
+ (let ((table-name (database-identifier name)))
+ (ecase if-does-not-exist
+ (:ignore
+ (unless (table-exists-p table-name :database database)
+ (return-from drop-table nil)))
+ (:error
+ t))
+ (let ((expr (concatenate 'string "DROP TABLE " table-name)))
+ (execute-command expr :database database))))
+
+(defun list-tables (&key (owner nil) (database *default-database*))
+ "List all tables in DATABASE which defaults to
+*DEFAULT-DATABASE*. If OWNER is nil, only user-owned tables are
+considered. This is the default. If OWNER is :all , all tables are
+considered. If OWNER is a string, this denotes a username and only
+tables owned by OWNER are considered. Table names are returned as a
+list of strings."
+ (database-list-tables database :owner owner))
+
+(defun table-exists-p (name &key (owner nil) (database *default-database*))
+ "Test for existence of an SQL table called NAME in DATABASE which
+defaults to *DEFAULT-DATABASE*. If OWNER is nil, only user-owned
+tables are considered. This is the default. If OWNER is :all , all
+tables are considered. If OWNER is a string, this denotes a username
+and only tables owned by OWNER are considered. Table names are
+returned as a list of strings."
+ (when (member (database-identifier name)
+ (list-tables :owner owner :database database)
+ :test #'string-equal)
+ t))
+
+
+;; Views
+
+(defvar *view-schemas* (make-hash-table :test #'equal)
+ "Hash of schema name to view lists.")
+
+(defun create-view (name &key as column-list (with-check-option nil)
+ (database *default-database*))
+ "Creates a view called NAME using the AS query and the optional
+COLUMN-LIST and WITH-CHECK-OPTION. The COLUMN-LIST argument is a list
+of columns to add to the view. The WITH-CHECK-OPTION adds 'WITH CHECK
+OPTION' to the resulting SQL. The default value of WITH-CHECK-OPTION
+is NIL. The default value of DATABASE is *DEFAULT-DATABASE*."
+ (let* ((view-name (etypecase name
+ (symbol (sql-expression :attribute name))
+ (string (sql-expression :attribute (make-symbol name)))
+ (sql-ident name)))
+ (stmt (make-instance 'sql-create-view
+ :name view-name
+ :column-list column-list
+ :query as
+ :with-check-option with-check-option)))
+ (pushnew view-name (gethash *default-schema* *view-schemas*) :test #'equal)
+ (execute-command stmt :database database)))
+
+(defun drop-view (name &key (if-does-not-exist :error)
+ (database *default-database*))
+ "Deletes view NAME from DATABASE which defaults to
+*DEFAULT-DATABASE*. If the view does not exist and IF-DOES-NOT-EXIST
+is :ignore then DROP-VIEW returns nil whereas an error is signalled if
+IF-DOES-NOT-EXIST is :error."
+ (let ((view-name (database-identifier name)))
+ (ecase if-does-not-exist
+ (:ignore
+ (unless (view-exists-p view-name :database database)
+ (return-from drop-view)))
+ (:error
+ t))
+ (let ((expr (concatenate 'string "DROP VIEW " view-name)))
+ (execute-command expr :database database))))
+
+(defun list-views (&key (owner nil) (database *default-database*))
+ "List all views in DATABASE which defaults to *DEFAULT-DATABASE*. If
+OWNER is nil, only user-owned views are considered. This is the
+default. If OWNER is :all , all views are considered. If OWNER is a
+string, this denotes a username and only views owned by OWNER are
+considered. View names are returned as a list of strings."
+ (database-list-views database :owner owner))
+
+(defun view-exists-p (name &key (owner nil) (database *default-database*))
+ "Test for existence of an SQL view called NAME in DATABASE which
+defaults to *DEFAULT-DATABASE*. If OWNER is nil, only user-owned views
+are considered. This is the default. If OWNER is :all , all views are
+considered. If OWNER is a string, this denotes a username and only
+views owned by OWNER are considered. View names are returned as a list
+of strings."
+ (when (member (database-identifier name)
+ (list-views :owner owner :database database)
+ :test #'string-equal)
+ t))
+
+
+;; Indexes
+
+(defvar *index-schemas* (make-hash-table :test #'equal)
+ "Hash of schema name to index lists.")
+
+(defun create-index (name &key on (unique nil) attributes
+ (database *default-database*))
+ "Creates an index called NAME on the table specified by ON. The
+attributes of the table to index are given by ATTRIBUTES. Setting
+UNIQUE to T includes UNIQUE in the SQL index command, specifying that
+the columns indexed must contain unique values. The default value of
+UNIQUE is nil. The default value of DATABASE is *DEFAULT-DATABASE*."
+ (let* ((index-name (database-identifier name))
+ (table-name (database-identifier on))
+ (attributes (mapcar #'database-identifier (listify attributes)))
+ (stmt (format nil "CREATE ~A INDEX ~A ON ~A (~{~A~^, ~})"
+ (if unique "UNIQUE" "")
+ index-name table-name attributes)))
+ (pushnew index-name (gethash *default-schema* *index-schemas*))
+ (execute-command stmt :database database)))
+
+(defun drop-index (name &key (if-does-not-exist :error)
+ (on nil)
+ (database *default-database*))
+ "Deletes index NAME from table FROM in DATABASE which defaults to
+*DEFAULT-DATABASE*. If the index does not exist and IF-DOES-NOT-EXIST
+is :ignore then DROP-INDEX returns nil whereas an error is signalled
+if IF-DOES-NOT-EXIST is :error. The argument ON allows the optional
+specification of a table to drop the index from."
+ (let ((index-name (database-identifier name)))
+ (ecase if-does-not-exist
+ (:ignore
+ (unless (index-exists-p index-name :database database)
+ (return-from drop-index)))
+ (:error t))
+ (execute-command (format nil "DROP INDEX ~A~A" index-name
+ (if (null on) ""
+ (concatenate 'string " ON "
+ (database-identifier on))))
+ :database database)))
+
+(defun list-indexes (&key (owner nil) (database *default-database*))
+ "List all indexes in DATABASE, which defaults to
+*default-database*. If OWNER is :all , all indexs are considered. If
+OWNER is a string, this denotes a username and only indexs owned by
+OWNER are considered. Index names are returned as a list of strings."
+ (database-list-indexes database :owner owner))
+
+(defun index-exists-p (name &key (owner nil) (database *default-database*))
+ "Test for existence of an index called NAME in DATABASE which
+defaults to *DEFAULT-DATABASE*. If OWNER is :all , all indexs are
+considered. If OWNER is a string, this denotes a username and only
+indexs owned by OWNER are considered. Index names are returned as a
+list of strings."
+ (when (member (database-identifier name)
+ (list-indexes :owner owner :database database)
+ :test #'string-equal)
+ t))
+
+;; Attributes
+
+(defun list-attributes (name &key (owner nil) (database *default-database*))
+ "List the attributes of a attribute called NAME in DATABASE which
+defaults to *DEFAULT-DATABASE*. If OWNER is nil, only user-owned
+attributes are considered. This is the default. If OWNER is :all , all
+attributes are considered. If OWNER is a string, this denotes a
+username and only attributes owned by OWNER are considered. Attribute
+names are returned as a list of strings. Attributes are returned as a
+list of strings."
+ (database-list-attributes (database-identifier name) database :owner owner))
+
+(defun attribute-type (attribute table &key (owner nil)
+ (database *default-database*))
+ "Return the field type of the ATTRIBUTE in TABLE. The optional
+keyword argument DATABASE specifies the database to query, defaulting
+to *DEFAULT-DATABASE*. If OWNER is nil, only user-owned attributes are
+considered. This is the default. If OWNER is :all , all attributes are
+considered. If OWNER is a string, this denotes a username and only
+attributes owned by OWNER are considered. Attribute names are returned
+as a list of strings. Attributes are returned as a list of strings."
+ (database-attribute-type (database-identifier attribute)
+ (database-identifier table)
+ database
+ :owner owner))
+
+(defun list-attribute-types (table &key (owner nil)
+ (database *default-database*))
+ "Returns type information for the attributes in TABLE from DATABASE
+which has a default value of *default-database*. If OWNER is nil, only
+user-owned attributes are considered. This is the default. If OWNER is
+:all, all attributes are considered. If OWNER is a string, this
+denotes a username and only attributes owned by OWNER are
+considered. Returns a list in which each element is a list (attribute
+datatype). Attribute is a string denoting the atribute name. Datatype
+is the vendor-specific type returned by ATTRIBUTE-TYPE."
+ (mapcar #'(lambda (type)
+ (list type (attribute-type type table :database database
+ :owner owner)))
+ (list-attributes table :database database :owner owner)))
+
+;(defun add-attribute (table attribute &key (database *default-database*))
+; (database-add-attribute table attribute database))
+
+;(defun rename-attribute (table oldatt newname
+; &key (database *default-database*))
+; (error "(rename-attribute ~a ~a ~a ~a) is not implemented"
+; table oldatt newname database))
+
+
+;; Sequences
+
+(defvar *sequence-schemas* (make-hash-table :test #'equal)
+ "Hash of schema name to sequence lists.")
+
+(defun create-sequence (name &key (database *default-database*))
+ "Create a sequence called NAME in DATABASE which defaults to
+*DEFAULT-DATABASE*."
+ (let ((sequence-name (database-identifier name)))
+ (database-create-sequence sequence-name database)
+ (pushnew sequence-name (gethash *default-schema* *sequence-schemas*)
+ :test #'equal))
+ (values))
+
+(defun drop-sequence (name &key (if-does-not-exist :error)
+ (database *default-database*))
+ "Drops sequence NAME from DATABASE which defaults to
+*DEFAULT-DATABASE*. If the sequence does not exist and
+IF-DOES-NOT-EXIST is :ignore then DROP-SEQUENCE returns nil whereas an
+error is signalled if IF-DOES-NOT-EXIST is :error."
+ (let ((sequence-name (database-identifier name)))
+ (ecase if-does-not-exist
+ (:ignore
+ (unless (sequence-exists-p sequence-name :database database)
+ (return-from drop-sequence)))
+ (:error t))
+ (database-drop-sequence sequence-name database))
+ (values))
+
+(defun list-sequences (&key (owner nil) (database *default-database*))
+ "List all sequences in DATABASE, which defaults to
+*default-database*. If OWNER is nil, only user-owned sequences are
+considered. This is the default. If OWNER is :all , all sequences are
+considered. If OWNER is a string, this denotes a username and only
+sequences owned by OWNER are considered. Sequence names are returned
+as a list of strings."
+ (database-list-sequences database :owner owner))
+
+(defun sequence-exists-p (name &key (owner nil)
+ (database *default-database*))
+ "Test for existence of a sequence called NAME in DATABASE which
+defaults to *DEFAULT-DATABASE*."
+ (when (member (database-identifier name)
+ (list-sequences :owner owner :database database)
+ :test #'string-equal)
+ t))
+
+(defun sequence-next (name &key (database *default-database*))
+ "Return the next value in the sequence NAME in DATABASE."
+ (database-sequence-next (database-identifier name) database))
+
+(defun set-sequence-position (name position &key (database *default-database*))
+ "Explicitly set the the position of the sequence NAME in DATABASE to
+POSITION."
+ (database-set-sequence-position (database-identifier name) position database))
+
+(defun sequence-last (name &key (database *default-database*))
+ "Return the last value of the sequence NAME in DATABASE."
+ (database-sequence-last (database-identifier name) database))
\ No newline at end of file
projects / clsql.git / commitdiff