+12 May 2004 Kevin Rosenberg (kevin@rosenberg.net)
+ * sql/sql.lisp: Add FOR-EACH-ROW macro from clsql-classic/sql.lisp
+ * clsql-classic: Remove system and subdirectory
+ * clsql-base: Remove system and subdirectory and
+ fold into clsql system
+
12 May 2004 Kevin Rosenberg (kevin@rosenberg.net)
* Version 2.10.16: CLSQL now fully supports AllegroCL AMD64
* db-odbc/odbc-api.lisp: work around return-type bug [spr28889] in
PKG := clsql
DEBPKG := cl-sql
-SUBDIRS := sql tests uffi base classic db-mysql db-aodbc db-odbc \
+SUBDIRS := sql tests uffi db-mysql db-aodbc db-odbc \
db-postgresql db-postgresql-socket db-sqlite
DOCSUBDIRS:=doc
* :db-constraint tests
* test *db-auto-sync*
* test SELECT caching
+* for-each-row macro
COMMONSQL SPEC
+++ /dev/null
-clsql-uffi.so
-clsql-uffi.dll
-clsql-uffi.lib
-clsql-uffi.dylib
-.bin
-*.fasl
-*.pfsl
-*.dfsl
-*.cfsl
-*.fasla16
-*.fasla8
-*.faslm16
-*.faslm8
-*.fsl
+++ /dev/null
-SUBDIRS :=
-
-include ../Makefile.common
-
-.PHONY: distclean
-distclean: clean
+++ /dev/null
-;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
-;;;; *************************************************************************
-;;;;
-;;;; $Id$
-;;;;
-;;;; Base SQL functions
-;;;;
-;;;; This file is part of CLSQL.
-;;;;
-;;;; 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)
-
-;;; 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 :auto) (flatp nil) (field-names t))
- (record-sql-command query-expression database)
- (multiple-value-bind (rows names) (database-query query-expression database result-types
- field-names)
- (let ((result (if (and flatp (= 1 (length (car rows))))
- (mapcar #'car rows)
- rows)))
- (record-sql-result result database)
- (if field-names
- (values result names)
- result))))
-
-;;; 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))
-
-;;; 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: classes.lisp
-;;;; Purpose: Classes for High-level SQL interface
-;;;; Programmers: Kevin M. Rosenberg based on
-;;;; original code by Pierre R. Mai
-;;;; Date Started: Feb 2002
-;;;;
-;;;; $Id$
-;;;;
-;;;; 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
-;;;; 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)
-
-
-(defclass database ()
- ((name :initform nil :initarg :name :reader database-name)
- (connection-spec :initform nil :initarg :connection-spec
- :reader connection-spec
- :documentation "Require to use connection pool")
- (database-type :initarg :database-type :initform :unknown
- :reader database-type)
- (state :initform :closed :reader database-state)
- (command-recording-stream :accessor command-recording-stream :initform nil)
- (result-recording-stream :accessor result-recording-stream :initform nil)
- (record-caches :accessor record-caches :initform nil)
- (view-classes :accessor database-view-classes :initform nil)
- (schema :accessor database-schema :initform nil)
- (transaction-level :initform 0 :accessor transaction-level)
- (transaction :initform nil :accessor transaction)
- (conn-pool :initform nil :initarg :conn-pool :accessor conn-pool)
- (attribute-cache :initform (make-hash-table :size 100 :test 'equal)
- :accessor attribute-cache
- :documentation "Internal cache of table attributes. It is keyed by table-name. Values
-are a list of ACTION specified for table and any cached value of list-attributes-types."))
- (:documentation
- "This class is the supertype of all databases handled by CLSQL."))
-
-(defmethod print-object ((object database) stream)
- (print-unreadable-object (object stream :type t :identity t)
- (format stream "~A ~A"
- (if (slot-boundp object 'name)
- (database-name object)
- "<unbound>")
- (database-state object))))
-
-
+++ /dev/null
-;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
-;;;; *************************************************************************
-;;;; FILE IDENTIFICATION
-;;;;
-;;;; 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-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)
-
-(defpackage #:cmucl-compat
- (:use #:common-lisp)
- (:export
- #:shrink-vector
- #:make-sequence-of-type
- #:result-type-or-lose
- #:required-argument
- ))
-(in-package #:cmucl-compat)
-
-#+(or cmu scl)
-(defmacro required-argument ()
- `(ext:required-argument))
-
-#-(or cmu scl)
-(defun required-argument ()
- (error "~&A required keyword argument was not supplied"))
-
-#+(or cmu scl)
-(defmacro shrink-vector (vec len)
- `(lisp::shrink-vector ,vec ,len))
-
-#+sbcl
-(defmacro shrink-vector (vec len)
- `(sb-kernel::shrink-vector ,vec ,len))
-
-#-(or cmu sbcl scl)
-(defmacro shrink-vector (vec len)
- "Shrinks a vector. Optimized if vector has a fill pointer.
-Needs to be a macro to overwrite value of VEC."
- (let ((new-vec (gensym)))
- `(cond
- ((adjustable-array-p ,vec)
- (adjust-array ,vec ,len))
- ((typep ,vec 'simple-array)
- (let ((,new-vec (make-array ,len :element-type
- (array-element-type ,vec))))
- (check-type ,len fixnum)
- (locally (declare (optimize (speed 3) (safety 0) (space 0)) )
- (dotimes (i ,len)
- (declare (fixnum i))
- (setf (aref ,new-vec i) (aref ,vec i))))
- (setq ,vec ,new-vec)))
- ((typep ,vec 'vector)
- (setf (fill-pointer ,vec) ,len)
- ,vec)
- (t
- (error "Unable to shrink vector ~S which is type-of ~S" ,vec (type-of ,vec)))
- )))
-
-
-#-(or cmu scl)
-(defun make-sequence-of-type (type length)
- "Returns a sequence of the given TYPE and LENGTH."
- (make-sequence type length))
-
-#+(or cmu scl)
-(if (fboundp 'lisp::make-sequence-of-type)
- (defun make-sequence-of-type (type len)
- (lisp::make-sequence-of-type type len))
- (defun 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)
- (unless (or type nil-ok)
- (error "NIL output type invalid for this sequence function"))
- (case type
- ((list cons)
- 'list)
- ((string simple-string base-string simple-base-string)
- 'string)
- (simple-vector
- 'simple-vector)
- (vector
- 'vector)
- (t
- (error "~S is a bad type specifier for sequence functions." type))
- ))
-
-#+(or cmu scl)
-(defun result-type-or-lose (type nil-ok)
- (lisp::result-type-or-lose type nil-ok))
+++ /dev/null
-;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
-;;;; *************************************************************************
-;;;; FILE IDENTIFICATION
-;;;;
-;;;; Name: conditions.lisp
-;;;; Purpose: Error conditions for high-level SQL interface
-;;;; Programmers: Kevin M. Rosenberg based on
-;;;; Original code by Pierre R. Mai
-;;;; Date Started: Feb 2002
-;;;;
-;;;; $Id$
-;;;;
-;;;; 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
-;;;; 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)
-
-(defvar *backend-warning-behavior* :warn
- "Action to perform on warning messages from backend. Default is to :warn. May also be
-set to :error to signal an error or :ignore/nil to silently ignore the warning.")
-
-;;; Conditions
-(define-condition clsql-condition ()
- ())
-
-(define-condition clsql-error (error clsql-condition)
- ())
-
-(define-condition clsql-simple-error (simple-condition clsql-error)
- ())
-
-(define-condition clsql-warning (warning clsql-condition)
- ())
-
-(define-condition clsql-simple-warning (simple-condition clsql-warning)
- ())
-
-(define-condition clsql-generic-error (clsql-error)
- ((message :initarg :message
- :reader clsql-generic-error-message))
- (:report (lambda (c stream)
- (format stream (clsql-generic-error-message c)))))
-
-(define-condition clsql-invalid-spec-error (clsql-error)
- ((connection-spec :initarg :connection-spec
- :reader clsql-invalid-spec-error-connection-spec)
- (database-type :initarg :database-type
- :reader clsql-invalid-spec-error-database-type)
- (template :initarg :template
- :reader clsql-invalid-spec-error-template))
- (:report (lambda (c stream)
- (format stream "The connection specification ~A~%is invalid for database type ~A.~%The connection specification must conform to ~A"
- (clsql-invalid-spec-error-connection-spec c)
- (clsql-invalid-spec-error-database-type c)
- (clsql-invalid-spec-error-template c)))))
-
-(defmacro check-connection-spec (connection-spec database-type template)
- "Check the connection specification against the provided template,
-and signal an clsql-invalid-spec-error if they don't match."
- `(handler-case
- (destructuring-bind ,template ,connection-spec
- (declare (ignore ,@(remove '&optional template)))
- t)
- (error () (error 'clsql-invalid-spec-error
- :connection-spec ,connection-spec
- :database-type ,database-type
- :template (quote ,template)))))
-
-(define-condition clsql-access-error (clsql-error)
- ((database-type :initarg :database-type
- :reader clsql-access-error-database-type)
- (connection-spec :initarg :connection-spec
- :reader clsql-access-error-connection-spec)
- (error :initarg :error :reader clsql-access-error-error))
- (:report (lambda (c stream)
- (format stream "While trying to access database ~A~% using database-type ~A:~% Error ~A~% has occurred."
- (database-name-from-spec
- (clsql-access-error-connection-spec c)
- (clsql-access-error-database-type c))
- (clsql-access-error-database-type c)
- (clsql-access-error-error c)))))
-
-(define-condition clsql-connect-error (clsql-access-error)
- ((errno :initarg :errno :reader clsql-connect-error-errno))
- (:report (lambda (c stream)
- (format stream "While trying to connect to database ~A~% using database-type ~A:~% Error ~D / ~A~% has occurred."
- (database-name-from-spec
- (clsql-access-error-connection-spec c)
- (clsql-access-error-database-type c))
- (clsql-access-error-database-type c)
- (clsql-connect-error-errno c)
- (clsql-access-error-error c)))))
-
-(define-condition clsql-sql-error (clsql-error)
- ((database :initarg :database :reader clsql-sql-error-database)
- (message :initarg :message :initform nil :reader clsql-sql-error-message)
- (expression :initarg :expression :initarg nil :reader clsql-sql-error-expression)
- (errno :initarg :errno :initarg nil :reader clsql-sql-error-errno)
- (error :initarg :error :initarg nil :reader clsql-sql-error-error))
- (:report (lambda (c stream)
- (if (clsql-sql-error-message c)
- (format stream "While accessing database ~A~%, Error~% ~A~% has occurred."
- (clsql-sql-error-database c)
- (clsql-sql-error-message c))
- (format stream "While accessing database ~A~% with expression ~S:~% Error ~D / ~A~% has occurred."
- (clsql-sql-error-database c)
- (clsql-sql-error-expression c)
- (clsql-sql-error-errno c)
- (clsql-sql-error-error c))))))
-
-(define-condition clsql-database-warning (clsql-warning)
- ((database :initarg :database :reader clsql-database-warning-database)
- (message :initarg :message :reader clsql-database-warning-message))
- (:report (lambda (c stream)
- (format stream "While accessing database ~A~% Warning: ~A~% has occurred."
- (clsql-database-warning-database c)
- (clsql-database-warning-message c)))))
-
-(define-condition clsql-exists-condition (clsql-condition)
- ((old-db :initarg :old-db :reader clsql-exists-condition-old-db)
- (new-db :initarg :new-db :reader clsql-exists-condition-new-db
- :initform nil))
- (:report (lambda (c stream)
- (format stream "In call to ~S:~%" 'connect)
- (cond
- ((null (clsql-exists-condition-new-db c))
- (format stream
- " There is an existing connection ~A to database ~A."
- (clsql-exists-condition-old-db c)
- (database-name (clsql-exists-condition-old-db c))))
- ((eq (clsql-exists-condition-new-db c)
- (clsql-exists-condition-old-db c))
- (format stream
- " Using existing connection ~A to database ~A."
- (clsql-exists-condition-old-db c)
- (database-name (clsql-exists-condition-old-db c))))
- (t
- (format stream
- " Created new connection ~A to database ~A~%, although there is an existing connection (~A)."
- (clsql-exists-condition-new-db c)
- (database-name (clsql-exists-condition-new-db c))
- (clsql-exists-condition-old-db c)))))))
-
-(define-condition clsql-exists-warning (clsql-exists-condition
- clsql-warning)
- ())
-
-(define-condition clsql-exists-error (clsql-exists-condition
- clsql-error)
- ())
-
-(define-condition clsql-closed-error (clsql-error)
- ((database :initarg :database :reader clsql-closed-error-database))
- (:report (lambda (c stream)
- (format stream "The database ~A has already been closed."
- (clsql-closed-error-database c)))))
-
-(define-condition clsql-no-database-error (clsql-error)
- ((database :initarg :database :reader clsql-no-database-error-database))
- (:report (lambda (c stream)
- (format stream "~S is not a CLSQL database."
- (clsql-no-database-error-database c)))))
-
-(define-condition clsql-odbc-error (clsql-error)
- ((odbc-message :initarg :odbc-message
- :reader clsql-odbc-error-message)
- (sql-state :initarg :sql-state :initform nil
- :reader clsql-odbc-error-sql-state))
- (:report (lambda (c stream)
- (format stream "[ODBC error] ~A; state: ~A"
- (clsql-odbc-error-message c)
- (clsql-odbc-error-sql-state c)))))
-
-;; Signal conditions
-
-
-(defun signal-closed-database-error (database)
- (cerror "Ignore this error and return nil."
- 'clsql-closed-error
- :database database))
-
-(defun signal-no-database-error (database)
- (error 'clsql-no-database-error :database database))
-
-(define-condition clsql-type-error (clsql-error clsql-condition)
- ((slotname :initarg :slotname
- :reader clsql-type-error-slotname)
- (typespec :initarg :typespec
- :reader clsql-type-error-typespec)
- (value :initarg :value
- :reader clsql-type-error-value))
- (:report (lambda (c stream)
- (format stream
- "Invalid value ~A in slot ~A, not of type ~A."
- (clsql-type-error-value c)
- (clsql-type-error-slotname c)
- (clsql-type-error-typespec c)))))
-
-(define-condition clsql-sql-syntax-error (clsql-error)
- ((reason :initarg :reason
- :reader clsql-sql-syntax-error-reason))
- (:report (lambda (c stream)
- (format stream "Invalid SQL syntax: ~A"
- (clsql-sql-syntax-error-reason c)))))
-
+++ /dev/null
-;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
-;;;; *************************************************************************
-;;;;
-;;;; $Id$
-;;;;
-;;;; Base database functions
-;;;;
-;;;; This file is part of CLSQL.
-;;;;
-;;;; 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)
-
-(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.")
-
-(defun is-database-open (database)
- (eql (database-state database) :open))
-
-(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."
-
- (unless database-type
- (error "Must specify a database-type."))
-
- (when (stringp connection-spec)
- (setq connection-spec (string-to-list-connection-spec connection-spec)))
-
- (unless (member database-type *loaded-database-types*)
- (asdf:operate 'asdf:load-op (ensure-keyword
- (concatenate 'string
- (symbol-name '#:clsql-)
- (symbol-name database-type)))))
-
- (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
- (setf (slot-value result 'state) :open)
- (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*)))
- (setf (slot-value database 'state) :closed)
- 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."
- (let ((db (etypecase database
- (database database)
- ((or string list)
- (let ((db (find-database database :errorp nil)))
- (when (null db)
- (if (and database error)
- (error 'clsql-generic-error
- :message
- (format nil "Unable to find database with connection-spec ~A." database))
- (return-from reconnect nil)))
- db)))))
-
- (when (is-database-open db)
- (if force
- (ignore-errors (disconnect :database db))
- (disconnect :database db :error nil)))
-
- (connect (connection-spec db))))
-
-
-(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."
- (flet ((get-data ()
- (let ((data '()))
- (dolist (db (connected-databases) data)
- (push
- (append
- (list (if (equal db *default-database*) "*" "")
- (database-name db)
- (string-downcase (string (database-type db)))
- (cond ((and (command-recording-stream db)
- (result-recording-stream db))
- "Both")
- ((command-recording-stream db) "Commands")
- ((result-recording-stream db) "Results")
- (t "nil")))
- (when full
- (list
- (if (conn-pool db) "t" "nil")
- (format nil "~A" (length (database-list-tables db)))
- (format nil "~A" (length (database-list-views db))))))
- 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 #\-))))
- (format t "~&CLSQL STATUS: ~A~%" (iso-timestring (get-time)))
- (let ((data (get-data)))
- (when data
- (let* ((titles (if full
- (list "" "DATABASE" "TYPE" "RECORDING" "POOLED"
- "TABLES" "VIEWS")
- (list "" "DATABASE" "TYPE" "RECORDING")))
- (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)))
-
-(defun create-database (connection-spec &key database-type)
- (when (stringp connection-spec)
- (setq connection-spec (string-to-list-connection-spec connection-spec)))
- (database-create connection-spec database-type))
-
-(defun probe-database (connection-spec &key database-type)
- (when (stringp connection-spec)
- (setq connection-spec (string-to-list-connection-spec connection-spec)))
- (database-probe connection-spec database-type))
-
-(defun destroy-database (connection-spec &key database-type)
- (when (stringp connection-spec)
- (setq connection-spec (string-to-list-connection-spec connection-spec)))
- (database-destroy connection-spec database-type))
-
-(defun list-databases (connection-spec &key database-type)
- (when (stringp connection-spec)
- (setq connection-spec (string-to-list-connection-spec connection-spec)))
- (database-list connection-spec database-type))
-
-(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))
-
+++ /dev/null
-;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
-;;;; *************************************************************************
-;;;; FILE IDENTIFICATION
-;;;;
-;;;; 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
-;;;; onShoreD to support UncommonSQL front-end
-;;;; Date Started: Feb 2002
-;;;;
-;;;; $Id$
-;;;;
-;;;; 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
-;;;; 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)
-
-(defgeneric database-type-load-foreign (database-type)
- (:documentation
- "The internal generic implementation of reload-database-types."))
-
-(defgeneric database-type-library-loaded (database-type)
- (:documentation
- "The internal generic implementation for checking if
-database type library loaded successfully."))
-
-(defgeneric database-initialize-database-type (database-type)
- (:documentation
- "The internal generic implementation of initialize-database-type."))
-
-(defgeneric database-name-from-spec (connection-spec database-type)
- (:documentation
- "Returns the name of the database that would be created if connect
-was called with the connection-spec."))
-
-(defgeneric database-connect (connection-spec database-type)
- (:documentation "Internal generic implementation of connect."))
-
-(defgeneric database-reconnect (database)
- (:method ((database t))
- (signal-no-database-error database))
- (:documentation "Internal generic implementation of reconnect."))
-
-(defgeneric database-disconnect (database)
- (:method ((database t))
- (signal-no-database-error database))
- (:documentation "Internal generic implementation of disconnect."))
-
-(defgeneric database-query (query-expression database result-types field-names)
- (:method (query-expression (database t) result-types field-names)
- (declare (ignore query-expression result-types field-names))
- (signal-no-database-error database))
- (:documentation "Internal generic implementation of query."))
-
-
-(defgeneric database-execute-command (sql-expression database)
- (:method (sql-expression (database t))
- (declare (ignore sql-expression))
- (signal-no-database-error database))
- (:documentation "Internal generic implementation of execute-command."))
-
-;;; Mapping and iteration
-(defgeneric database-query-result-set
- (query-expression database &key full-set result-types)
- (:method (query-expression (database t) &key full-set result-types)
- (declare (ignore query-expression full-set result-types))
- (signal-no-database-error database)
- (values nil nil nil))
- (:documentation
- "Internal generic implementation of query mapping. Starts the
-query specified by query-expression on the given database and returns
-a result-set to be used with database-store-next-row and
-database-dump-result-set to access the returned data. The second
-value is the number of columns in the result-set, if there are any.
-If full-set is true, the number of rows in the result-set is returned
-as a third value, if this is possible (otherwise nil is returned for
-the third value). This might have memory and resource usage
-implications, since many databases will require the query to be
-executed in full to answer this question. If the query produced no
-results then nil is returned for all values that would have been
-returned otherwise. If an error occurs during query execution, the
-function should signal a clsql-sql-error."))
-
-(defgeneric database-dump-result-set (result-set database)
- (:method (result-set (database t))
- (declare (ignore result-set))
- (signal-no-database-error database))
- (:documentation "Dumps the received result-set."))
-
-(defgeneric database-store-next-row (result-set database list)
- (:method (result-set (database t) list)
- (declare (ignore result-set list))
- (signal-no-database-error database))
- (:documentation
- "Returns t and stores the next row in the result set in list or
-returns nil when result-set is finished."))
-
-(defgeneric database-create (connection-spec type)
- (:documentation
- "Creates a database, returns T if successfull or signals an error."))
-
-(defgeneric database-probe (connection-spec type)
- (:method (spec type)
- (declare (ignore spec))
- (warn "database-proe not support for database-type ~A." type))
- (:documentation
- "Probes for the existence of a database, returns T if database found or NIL
-if not found. May signal an error if unable to communicate with database server."))
-
-(defgeneric database-list (connection-spec type)
- (:method (spec type)
- (declare (ignore spec))
- (warn "database-list not support for database-type ~A." type))
- (:documentation
- "Lists all databases found for TYPE. May signal an error if unable to communicate with database server."))
-
-(defgeneric database-destroy (connection-spec database)
- (:documentation "Destroys (drops) a database."))
-
-(defgeneric database-truncate (database)
- (:method ((database t))
- (signal-no-database-error database))
- (:documentation "Remove all data from database."))
-
-(defgeneric database-describe-table (database table)
- (:method ((database t) table)
- (declare (ignore table))
- (signal-no-database-error database))
- (:documentation "Return a list of name/type for columns in table"))
-
-(defgeneric database-destory (connection-spec type)
- (:documentation
- "Destroys a database, returns T if successfull or signals an error
-if unable to destory."))
-
-(defgeneric database-create-sequence (name database)
- (:documentation "Create a sequence in DATABASE."))
-
-(defgeneric database-drop-sequence (name database)
- (:documentation "Drop a sequence from DATABASE."))
-
-(defgeneric database-sequence-next (name database)
- (:documentation "Increment a sequence in DATABASE."))
-
-(defgeneric database-list-sequences (database &key owner)
- (:documentation "List all sequences in DATABASE."))
-
-(defgeneric database-set-sequence-position (name position database)
- (:documentation "Set the position of the sequence called NAME in DATABASE."))
-
-(defgeneric database-sequence-last (name database)
- (:documentation "Select the last value in sequence NAME in DATABASE."))
-
-(defgeneric database-start-transaction (database)
- (:documentation "Start a transaction in DATABASE."))
-
-(defgeneric database-commit-transaction (database)
- (:documentation "Commit current transaction in DATABASE."))
-
-(defgeneric database-abort-transaction (database)
- (:documentation "Abort current transaction in DATABASE."))
-
-(defgeneric database-get-type-specifier (type args database)
- (:documentation "Return the type SQL type specifier as a string, for
-the given lisp type and parameters."))
-
-(defgeneric database-list-tables (database &key owner)
- (:documentation "List all tables in the given database"))
-
-(defgeneric database-list-views (database &key owner)
- (:documentation "List all views in the DATABASE."))
-
-(defgeneric database-list-indexes (database &key owner)
- (:documentation "List all indexes in the DATABASE."))
-
-(defgeneric database-list-table-indexes (table database &key owner)
- (:documentation "List all indexes for a table in the DATABASE."))
-
-(defgeneric database-list-attributes (table database &key owner)
- (:documentation "List all attributes in TABLE."))
-
-(defgeneric database-attribute-type (attribute table database &key owner)
- (:documentation "Return the type of ATTRIBUTE in TABLE. Returns multiple values
-of TYPE_NAME (keyword) PRECISION SCALE NULLABLE."))
-
-(defgeneric database-add-attribute (table attribute database)
- (:documentation "Add the attribute to the table."))
-
-(defgeneric database-rename-attribute (table oldatt newname database)
- (:documentation "Rename the attribute in the table to NEWNAME."))
-
-(defgeneric oid (object)
- (:documentation "Return the unique ID of a database object."))
-
-;;; Database backend capabilities
-
-(defgeneric database-underlying-type (database)
- (:method (database)
- (database-type database))
- (:documentation "Returns the type of the underlying database. For ODBC, needs to query ODBC driver."))
-
-(defgeneric db-type-use-column-on-drop-index? (db-type)
- (:method (db-type)
- (declare (ignore db-type))
- nil)
- (:documentation "NIL [default] if database-type does not use column name on DROP INDEX."))
-
-(defgeneric db-type-has-views? (db-type)
- (:method (db-type)
- (declare (ignore db-type))
- ;; SQL92 has views
- t)
- (:documentation "T [default] if database-type supports views."))
-
-(defgeneric db-type-default-case (db-type)
- (:method (db-type)
- (declare (ignore db-type))
- ;; By default, CommonSQL converts identifiers to UPPER case.
- :upper)
- (:documentation ":upper [default] if means identifiers mapped to UPPER case SQL like CommonSQL API. However, Postgresql maps identifiers to lower case, so PostgreSQL uses a value of :lower for this result."))
-
-(defgeneric db-type-has-fancy-math? (db-type)
- (:method (db-type)
- (declare (ignore db-type))
- nil)
- (:documentation "NIL [default] if database-type does not have fancy math."))
-
-(defgeneric db-type-has-subqueries? (db-type)
- (:method (db-type)
- (declare (ignore db-type))
- t)
- (:documentation "T [default] if database-type supports views."))
-
-(defgeneric db-type-has-boolean-where? (db-type)
- (:method (db-type)
- (declare (ignore db-type))
- ;; SQL99 has boolean where
- t)
- (:documentation "T [default] if database-type supports boolean WHERE clause, such as 'WHERE MARRIED'."))
-
-(defgeneric db-backend-has-create/destroy-db? (db-type)
- (:method (db-type)
- (declare (ignore db-type))
- t)
- (:documentation "T [default] if backend can destroy and create databases."))
-
-(defgeneric db-type-transaction-capable? (db database)
- (:method (db database)
- (declare (ignore db database))
- t)
- (:documentation "T [default] if database can supports transactions."))
-
-;;; Large objects support (Marc Battyani)
-
-(defgeneric database-create-large-object (database)
- (:documentation "Creates a new large object in the database and returns the object identifier"))
-
-(defgeneric database-write-large-object (object-id data database)
- (:documentation "Writes data to the large object"))
-
-(defgeneric database-read-large-object (object-id database)
- (:documentation "Reads the large object content"))
-
-(defgeneric database-delete-large-object (object-id database)
- (:documentation "Deletes the large object in the database"))
-
-
-;; Checks for closed database
-
-(defmethod database-disconnect :before ((database database))
- (unless (is-database-open database)
- (signal-closed-database-error database)))
-
-(defmethod database-query :before (query-expression (database database)
- result-set field-names)
- (declare (ignore query-expression result-set field-names))
- (unless (is-database-open database)
- (signal-closed-database-error database)))
-
-(defmethod database-execute-command :before (sql-expression (database database))
- (declare (ignore sql-expression))
- (unless (is-database-open database)
- (signal-closed-database-error database)))
-
-(defmethod database-query-result-set :before (expr (database database)
- &key full-set result-types)
- (declare (ignore expr full-set result-types))
- (unless (is-database-open database)
- (signal-closed-database-error database)))
-
-(defmethod database-dump-result-set :before (result-set (database database))
- (declare (ignore result-set))
- (unless (is-database-open database)
- (signal-closed-database-error database)))
-
-(defmethod database-store-next-row :before (result-set (database database) list)
- (declare (ignore result-set list))
- (unless (is-database-open database)
- (signal-closed-database-error database)))
-
-(defmethod database-commit-transaction :before ((database database))
- (unless (is-database-open database)
- (signal-closed-database-error database)))
-
-(defmethod database-start-transaction :before ((database database))
- (unless (is-database-open database)
- (signal-closed-database-error database)))
-
-(defmethod database-abort-transaction :before ((database database))
- (unless (is-database-open database)
- (signal-closed-database-error database)))
-
-(defgeneric describe-table (table &key database)
- (:documentation "Describes a table, returns a list of name/type for columns in table"))
-
+++ /dev/null
-;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
-;;;; *************************************************************************
-;;;; FILE IDENTIFICATION
-;;;;
-;;;; 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-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
-;;;; 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)
-
-(defvar *loaded-database-types* nil
- "Contains a list of database types which have been defined/loaded.")
-
-(defmethod database-type-load-foreign (x)
- (error "No generic function defined for database-type-load-foreign with parameters of ~S" x))
-
-(defmethod database-type-load-foreign :after (database-type)
- (when (database-type-library-loaded database-type)
- (pushnew database-type *loaded-database-types*)))
-
-(defun reload-database-types ()
- "Reloads any foreign code for the loaded database types after a dump."
- (mapc #'database-type-load-foreign *loaded-database-types*))
-
-(defvar *default-database-type* nil
- "Specifies the default type of database.")
-
-(defvar *initialized-database-types* nil
- "Contains a list of database types which have been initialized by calls
-to initialize-database-type.")
-
-(defun initialize-database-type (&key (database-type *default-database-type*))
- "Initialize the given database-type, if it is not already
-initialized, as indicated by `*initialized-database-types*'."
- (when (member database-type *initialized-database-types*)
- (return-from initialize-database-type database-type))
-
- (let ((system (intern (concatenate 'string
- (symbol-name '#:clsql-)
- (symbol-name database-type)))))
- (when (not (find-package system))
- (asdf:operate 'asdf:load-op system)))
-
- (when (database-initialize-database-type database-type)
- (push database-type *initialized-database-types*)
- database-type))
-
+++ /dev/null
-;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
-;;;; *************************************************************************
-;;;; FILE IDENTIFICATION
-;;;;
-;;;; Name: loop-extension.lisp
-;;;; Purpose: Extensions to the Loop macro for CLSQL
-;;;;
-;;;; Copyright (c) 2001-2004 Kevin Rosenberg and (c) 1999-2001 Pierre R. Mai
-;;;;
-;;;; $Id$
-;;;; *************************************************************************
-
-(in-package #:cl-user)
-
-#+(or allegro sbcl)
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (defpackage #:ansi-loop
- (:import-from #+sbcl #:sb-loop #+allegro #:excl
- #:loop-error
- #:*loop-epilogue*
- #:*loop-ansi-universe*
- #:add-loop-path)))
-
-#+(or allegro sbcl)
-(defun ansi-loop::loop-gentemp (&optional (pref 'loopva-))
- (gensym (string pref)))
-
-#+(or cmu scl sbcl openmcl allegro)
-(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 '(clsql-base:*default-database*)))
-
- (unless (consp variable)
- (setq variable (list variable)))
-
- (cond
- ;; object query
- ((and (consp (first in-phrase))
- (string-equal "sql-query" (symbol-name (caar in-phrase)))
- (consp (second (first in-phrase)))
- (eq 'quote (first (second (first in-phrase))))
- (symbolp (second (second (first in-phrase)))))
-
- (let ((result-var (ansi-loop::loop-gentemp
- 'loop-record-result-))
- (step-var (ansi-loop::loop-gentemp 'loop-record-step-)))
- `(((,variable nil ,@(and data-type (list data-type)))
- (,result-var (clsql-base:query ,(first in-phrase)))
- (,step-var nil))
- ()
- ()
- ()
- (if (null ,result-var)
- t
- (progn
- (setq ,step-var (first ,result-var))
- (setq ,result-var (rest ,result-var))
- nil))
- (,variable ,step-var)
- (null ,result-var)
- ()
- (if (null ,result-var)
- t
- (progn
- (setq ,step-var (first ,result-var))
- (setq ,result-var (rest ,result-var))
- nil))
- (,variable ,step-var))))
-
- ((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
- (clsql-base:database-dump-result-set ,result-set-var ,db-var))
- ansi-loop::*loop-epilogue*)
- `(((,variable nil ,@(and data-type (list data-type)))
- (,query-var ,(first in-phrase))
- (,db-var ,(first from-phrase))
- (,result-set-var nil)
- (,step-var nil))
- ((multiple-value-bind (%rs %cols)
- (clsql-base:database-query-result-set ,query-var ,db-var :result-types :auto)
- (setq ,result-set-var %rs ,step-var (make-list %cols))))
- ()
- ()
- (not (clsql-base:database-store-next-row ,result-set-var ,db-var ,step-var))
- (,variable ,step-var)
- (not ,result-set-var)
- ()
- (not (clsql-base:database-store-next-row ,result-set-var ,db-var ,step-var))
- (,variable ,step-var)))))))
-
-#+(or cmu scl sbcl openmcl allegro)
-(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)
-
-#+lispworks
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (in-package loop))
-
-#+lispworks
-(cl-user::define-loop-method (record records tuple tuples) clsql-loop-method
- (in of from))
-
-#+lispworks
-(defun clsql-loop-method (method-name iter-var iter-var-data-type
- prep-phrases inclusive? allowed-preps
- method-specific-data)
- (declare (ignore method-name inclusive? allowed-preps method-specific-data))
- (let ((in-phrase nil)
- (from-phrase nil))
- (loop for (prep . rest) in prep-phrases
- do
- (cond
- ((or (eq prep 'in) (eq prep 'of))
- (when in-phrase
- (error
- "Duplicate OF or IN iteration path: ~S." (cons prep rest)))
- (setq in-phrase rest))
- ((eq prep 'from)
- (when from-phrase
- (error
- "Duplicate FROM iteration path: ~S." (cons prep rest)))
- (setq from-phrase rest))
- (t
- (error
- "Unknown preposition: ~S." prep))))
- (unless in-phrase
- (error "Missing OF or IN iteration path."))
- (unless from-phrase
- (setq from-phrase '(clsql-base:*default-database*)))
-
- (unless (consp iter-var)
- (setq iter-var (list iter-var)))
-
- (cond
- ;; object query
- ((and (consp in-phrase)
- (string-equal "sql-query" (symbol-name (car in-phrase)))
- (consp (second in-phrase))
- (eq 'quote (first (second in-phrase)))
- (symbolp (second (second in-phrase))))
-
- (let ((result-var (gensym "LOOP-RECORD-RESULT-"))
- (step-var (gensym "LOOP-RECORD-STEP-")))
- (values
- t
- nil
- `(,@(mapcar (lambda (v) `(,v nil)) iter-var)
- (,result-var (clsql-base:query ,in-phrase))
- (,step-var nil))
- ()
- ()
- ()
- `((if (null ,result-var)
- t
- (progn
- (setq ,step-var (first ,result-var))
- (setq ,result-var (rest ,result-var))
- nil)))
- `(,iter-var ,step-var)
- `((if (null ,result-var)
- t
- (progn
- (setq ,step-var (first ,result-var))
- (setq ,result-var (rest ,result-var))
- nil)))
- `(,iter-var ,step-var)
- ()
- ()
- )))
-
- ((consp iter-var)
- (let ((query-var (gensym "LOOP-RECORD-"))
- (db-var (gensym "LOOP-RECORD-DATABASE-"))
- (result-set-var (gensym "LOOP-RECORD-RESULT-SET-"))
- (step-var (gensym "LOOP-RECORD-STEP-")))
- (values
- t
- nil
- `(,@(mapcar (lambda (v) `(,v nil)) iter-var)
- (,query-var ,in-phrase)
- (,db-var ,(first from-phrase))
- (,result-set-var nil)
- (,step-var nil))
- `((multiple-value-bind (%rs %cols)
- (clsql-base:database-query-result-set ,query-var ,db-var :result-types :auto)
- (setq ,result-set-var %rs ,step-var (make-list %cols))))
- ()
- ()
- `((unless (clsql-base:database-store-next-row ,result-set-var ,db-var ,step-var)
- (when ,result-set-var
- (clsql-base:database-dump-result-set ,result-set-var ,db-var))
- t))
- `(,iter-var ,step-var)
- `((unless (clsql-base:database-store-next-row ,result-set-var ,db-var ,step-var)
- (when ,result-set-var
- (clsql-base:database-dump-result-set ,result-set-var ,db-var))
- t))
- `(,iter-var ,step-var)
- ()
- ()))))))
-
+++ /dev/null
-;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
-;;;; *************************************************************************
-;;;; FILE IDENTIFICATION
-;;;;
-;;;; Name: package.lisp
-;;;; Purpose: Package definition for base (low-level) SQL interface
-;;;; Programmers: Kevin M. Rosenberg based on
-;;;; Original code by Pierre R. Mai
-;;;; Date Started: Feb 2002
-;;;;
-;;;; $Id$
-;;;;
-;;;; 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
-;;;; 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)
-
-;;;; This file makes the required package definitions for CLSQL's
-;;;; core packages.
-
-(defpackage #:clsql-base
- (:use #:cl)
- (:export
- #:check-connection-spec
- #:database-type-load-foreign
- #:database-type-library-loaded ;; KMR - Tests if foreign library okay
- #:database-initialize-database-type
- #:database-connect
- #:database-disconnect
- #:database-reconnect
- #:database-query
- #:database-execute-command
- #:database-query-result-set
- #:database-dump-result-set
- #:database-store-next-row
- #:database-create
- #:database-destroy
- #:database-probe
- #:database-list
- #:database-describe-table
- #:database-underlying-type
-
- #:database-list-tables
- #:database-list-attributes
- #:database-attribute-type
- #:database-create-sequence
- #:database-drop-sequence
- #:database-sequence-next
- #:sql-escape
- #:database-sequence-last
- #:database-set-sequence-position
- #:database-list-attributes
- #:database-list-sequences
- #:database-list-indexes
- #:database-list-table-indexes
- #:database-list-views
-
- ;; Large objects
- #:database-create-large-object
- #:database-write-large-object
- #:database-read-large-object
- #:database-delete-large-object
- #:create-large-object
- #:write-large-object
- #:read-large-object
- #:delete-large-object
-
- #:command-output
- #:make-process-lock
- #:with-process-lock
- #:connection-spec
- #:ensure-keyword
-
- ;; utils.lisp
- #:without-interrupts
- #:make-process-lock
- #:with-process-lock
- #:command-output
- #:symbol-name-default-case
- #:convert-to-db-default-case
- #:ensure-keyword
-
- #: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-access-error
- #:clsql-access-error-database-type
- #:clsql-access-error-connection-spec
- #:clsql-access-error-error
- #:clsql-connect-error
- #:clsql-connect-error-errno
- #: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-sql-syntax-error
- #:clsql-type-error
- #:clsql-odbc-error
- #:clsql-odbc-error-message
- #:*backend-warning-behavior*
-
- #:*loaded-database-types*
- #:reload-database-types
- #:*default-database-type*
- #:*initialized-database-types*
- #:initialize-database-type
- #:*connect-if-exists*
- #:*default-database*
- #:connected-databases
- #:database
- #:database-name
- #:find-database
- #:database-name-from-spec
- #:is-database-open
-
- ;; accessors for database class
- #:name
- #:connection-spec
- #:transaction
- #:transaction-level
- #:conn-pool
- #:command-recording-stream
- #:result-recording-stream
- #:record-caches
- #:view-classes
- #:database-type
- #:database-state
- #:attribute-cache
-
- ;; 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
- #:duration-timestring
- #:extract-roman
- #:format-duration
- #:format-time
- #:get-time
- #:utime->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
- #:parse-yearstring
- #: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
- #:gregorian-to-mjd
- #:mjd-to-gregorian
-
- ;; recording.lisp -- SQL I/O Recording
- #:record-sql-command
- #: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
- #:disconnect-pooled
- #:create-database
- #:destroy-database
- #:probe-database
- #:list-databases
-
- ;; basic-sql.lisp
- #:query
- #:execute-command
- #:write-large-object
- #:read-large-object
- #:delete-large-object
- #:describe-table
-
- ;; 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
-
- ;; Database features specialized by backend
- #:db-type-use-column-on-drop-index?
- #:db-type-has-views?
- #:db-type-has-subqueries?
- #:db-type-has-boolean-where?
- #:db-type-has-fancy-math?
- #:db-type-default-case
- #:db-backend-has-create/destroy-db?
- #:db-type-transaction-capable?
- )
- (:documentation "This is the INTERNAL SQL-Interface package of CLSQL-BASE."))
-
-
+++ /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-base)
-
-(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 pool-database-type :initarg :pool-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 (pool-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
- :pool-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$
-;;;;
-;;;; CLSQL broadcast streams which can be used to monitor the
-;;;; flow of commands to, and results from, a database.
-;;;;
-;;;; This file is part of CLSQL.
-;;;;
-;;;; 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)
-
-(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$
-;;;;
-;;;; A variety of structures and function for creating and
-;;;; manipulating dates, times, durations and intervals for
-;;;; CLSQL.
-;;;;
-;;;; This file was originally part of ODCL and is Copyright (c) 2002 -
-;;;; 2003 onShore Development, Inc.
-;;;;
-;;;; 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)
-
-;; ------------------------------------------------------------
-;; 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
-
-(defun duration-timestring (duration)
- (let ((second (duration-second duration))
- (minute (duration-minute duration))
- (hour (duration-hour duration))
- (day (duration-day duration)))
- (format nil "P~dD~dH~dM~dS" day hour minute second)))
-
-
-;; ------------------------------------------------------------
-;; 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 utime->time (utime)
- "Return a pair: (GREGORIAN DAY . TIME-OF-DAY)"
- (multiple-value-bind (second minute hour day mon year)
- (decode-universal-time utime)
- (make-time :year year :month mon :day day :hour hour :minute minute
- :second second)))
-
-(defun get-time ()
- "Return a pair: (GREGORIAN DAY . TIME-OF-DAY)"
- (utime->time (get-universal-time)))
-
-(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 (month day year)
- (mjd-to-gregorian (time-mjd time))
- (values year month 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 &optional round)
- (ecase precision
- (:second
- (+ (duration-second duration)
- (* (duration-reduce duration :minute) 60)))
- (:minute
- (+ (if round
- (floor (duration-second duration) 30)
- 0)
- (duration-minute duration)
- (* (duration-reduce duration :hour) 60)))
- (:hour
- (+ (if round
- (floor (duration-minute duration) 30)
- 0)
- (duration-hour duration)
- (* (duration-reduce duration :day) 24)))
- (:day
- (+ (if round
- (floor (duration-hour duration) 12)
- 0)
- (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) (setf 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) (setf 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)
- (name 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!
- (let ((list (sort-interval-list list)))
- (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))))))
-
-(defun interval-clear (list time)
- (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"
- (let ((*print-circle* nil))
- (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-month ()
- (second (mjd-to-gregorian (time-mjd (get-time)))))
-
-(defun current-day ()
- (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"))))
-
-(defgeneric to-string (val &rest keys)
- )
-
-(defmethod to-string ((time wall-time) &rest keys)
- (destructuring-bind (&key (style :daytime) &allow-other-keys)
- keys
- (print-date time style)))
-
-(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)
- (setf doy (- doy (floor (+ 23 (* 4 month)) 10)))
- (when (leap-year? year)
- (incf doy)))
- doy))
-
-(defun parse-yearstring (string)
- (let ((year (or (parse-integer-insensitively string)
- (extract-roman string))))
- (when (and year (< 1500 year 2500))
- (make-time :year year))))
-
-(defun parse-integer-insensitively (string)
- (let ((start (position-if #'digit-char-p string))
- (end (position-if #'digit-char-p string :from-end t)))
- (when (and start end)
- (parse-integer (subseq string start (1+ end)) :junk-allowed t))))
-
-(defvar *roman-digits*
- '((#\M . 1000)
- (#\D . 500)
- (#\C . 100)
- (#\L . 50)
- (#\X . 10)
- (#\V . 5)
- (#\I . 1)))
-
-(defun extract-roman (string &aux parse)
- (dotimes (x (length string))
- (let ((val (cdr (assoc (aref string x) *roman-digits*))))
- (when (and val parse (< (car parse) val))
- (push (- (pop parse)) parse))
- (push val parse)))
- (apply #'+ parse))
-
-
-;; ------------------------------------------------------------
-;; 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))))
- (setf 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$
-;;;;
-;;;; Transaction support
-;;;;
-;;;; This file is part of CLSQL.
-;;;;
-;;;; 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)
-
-(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)
- (unless database (error 'clsql-no-database-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)
- (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)
- (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)))
+++ /dev/null
-;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
-;;;; *************************************************************************
-;;;; FILE IDENTIFICATION
-;;;;
-;;;; 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-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 #:clsql-base)
-
-(defun number-to-sql-string (num)
- (etypecase num
- (integer
- num)
- (rational
- (float-to-sql-string (coerce num 'double-float)))
- (number
- (float-to-sql-string num))))
-
-(defun float-to-sql-string (num)
- "Convert exponent character for SQL"
- (let ((str (write-to-string num :readably t)))
- (cond
- ((find #\f str)
- (substitute #\e #\f str))
- ((find #\d str)
- (substitute #\e #\d str))
- ((find #\l str)
- (substitute #\e #\l str))
- ((find #\s str)
- (substitute #\e #\S str))
- ((find #\F str)
- (substitute #\e #\F str))
- ((find #\D str)
- (substitute #\e #\D str))
- ((find #\L str)
- (substitute #\e #\L str))
- ((find #\S str)
- (substitute #\e #\S str))
- (t
- str))))
-
-(defun sql-escape (identifier)
- "Change hyphens to underscores, ensure string"
- (let* ((unescaped (etypecase identifier
- (symbol (symbol-name identifier))
- (string identifier)))
- (escaped (make-string (length unescaped))))
- (dotimes (i (length unescaped))
- (setf (char escaped i)
- (cond ((equal (char unescaped i) #\-)
- #\_)
- ;; ...
- (t
- (char unescaped i)))))
- escaped))
-
-(defmacro without-interrupts (&body body)
- #+lispworks `(mp:without-preemption ,@body)
- #+allegro `(mp:without-scheduling ,@body)
- #+cmu `(system:without-interrupts ,@body)
- #+sbcl `(sb-sys::without-interrupts ,@body)
- #+openmcl `(ccl:without-interrupts ,@body))
-
-(defun make-process-lock (name)
- #+allegro (mp:make-process-lock :name name)
- #+cmu (mp:make-lock name)
- #+lispworks (mp:make-lock :name name)
- #+openmcl (ccl:make-lock name)
- #+sb-thread (sb-thread:make-mutex :name name)
- #+scl (thread:make-lock name)
- #-(or allegro cmu lispworks openmcl sb-thread scl) (declare (ignore name))
- #-(or allegro cmu lispworks openmcl sb-thread scl) nil)
-
-(defmacro with-process-lock ((lock desc) &body body)
- #+(or cmu allegro lispworks openmcl sb-thread)
- (declare (ignore desc))
- #+(or allegro cmu lispworks openmcl sb-thread)
- (let ((l (gensym)))
- `(let ((,l ,lock))
- #+allegro (mp:with-process-lock (,l) ,@body)
- #+cmu (mp:with-lock-held (,l) ,@body)
- #+openmcl (ccl:with-lock-grabbed (,l) ,@body)
- #+lispworks (mp:with-lock (,l) ,@body)
- #+sb-thread (sb-thread:with-recursive-lock (,l) ,@body)
- ))
- #+scl `(thread:with-lock-held (,lock ,desc) ,@body)
- #-(or cmu allegro lispworks openmcl sb-thread scl) (declare
- (ignore lock desc))
- #-(or cmu allegro lispworks openmcl sb-thread scl) `(progn ,@body))
-
-(defun sql-escape-quotes (s)
- "Escape quotes for SQL string writing"
- (substitute-string-for-char s #\' "''"))
-
-(defun substitute-string-for-char (procstr match-char subst-str)
-"Substitutes a string for a single matching character of a string"
- (let ((pos (position match-char procstr)))
- (if pos
- (concatenate 'string
- (subseq procstr 0 pos) subst-str
- (substitute-string-for-char
- (subseq procstr (1+ pos)) match-char subst-str))
- procstr)))
-
-
-(defun position-char (char string start max)
- "From KMRCL."
- (declare (optimize (speed 3) (safety 0) (space 0))
- (fixnum start max) (simple-string string))
- (do* ((i start (1+ i)))
- ((= i max) nil)
- (declare (fixnum i))
- (when (char= char (schar string i)) (return i))))
-
-(defun delimited-string-to-list (string &optional (separator #\space)
- skip-terminal)
- "Split a string with delimiter, from KMRCL."
- (declare (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0))
- (type string string)
- (type character separator))
- (do* ((len (length string))
- (output '())
- (pos 0)
- (end (position-char separator string pos len)
- (position-char separator string pos len)))
- ((null end)
- (if (< pos len)
- (push (subseq string pos) output)
- (when (or (not skip-terminal) (zerop len))
- (push "" output)))
- (nreverse output))
- (declare (type fixnum pos len)
- (type (or null fixnum) end))
- (push (subseq string pos end) output)
- (setq pos (1+ end))))
-
-(defun string-to-list-connection-spec (str)
- (let ((at-pos (position-char #\@ str 0 (length str))))
- (cond
- ((and at-pos (> (length str) at-pos))
- ;; Connection spec is SQL*NET format
- (cons (subseq str (1+ at-pos))
- (delimited-string-to-list (subseq str 0 at-pos) #\/)))
- (t
- (delimited-string-to-list str #\/)))))
-
-#+allegro
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (unless (find-package '#:excl.osi)
- (require 'osi)))
-
-(defun command-output (control-string &rest args)
- ;; Concatenates output and error since Lispworks combines
- ;; these, thus CLSQL can't depend upon separate results
- (multiple-value-bind (output error status)
- (apply #'%command-output control-string args)
- (values
- (concatenate 'string (if output output "")
- (if error error ""))
- status)))
-
-(defun read-stream-to-string (in)
- (with-output-to-string (out)
- (let ((eof (gensym)))
- (do ((line (read-line in nil eof)
- (read-line in nil eof)))
- ((eq line eof))
- (format out "~A~%" line)))))
-
-;; From KMRCL
-(defun %command-output (control-string &rest args)
- "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
-synchronously execute the result using a Bourne-compatible shell,
-returns (VALUES string-output error-output exit-status)"
- (let ((command (apply #'format nil control-string args)))
- #+sbcl
- (let* ((process (sb-ext:run-program
- "/bin/sh"
- (list "-c" command)
- :input nil :output :stream :error :stream))
- (output (read-stream-to-string (sb-impl::process-output process)))
- (error (read-stream-to-string (sb-impl::process-error process))))
- (close (sb-impl::process-output process))
- (close (sb-impl::process-error process))
- (values
- output
- error
- (sb-impl::process-exit-code process)))
-
-
- #+(or cmu scl)
- (let* ((process (ext:run-program
- "/bin/sh"
- (list "-c" command)
- :input nil :output :stream :error :stream))
- (output (read-stream-to-string (ext::process-output process)))
- (error (read-stream-to-string (ext::process-error process))))
- (close (ext::process-output process))
- (close (ext::process-error process))
-
- (values
- output
- error
- (ext::process-exit-code process)))
-
- #+allegro
- (multiple-value-bind (output error status)
- (excl.osi:command-output command :whole t)
- (values output error status))
-
- #+lispworks
- ;; BUG: Lispworks combines output and error streams
- (let ((output (make-string-output-stream)))
- (unwind-protect
- (let ((status
- (system:call-system-showing-output
- command
- :shell-type "/bin/sh"
- :output-stream output)))
- (values (get-output-stream-string output) nil status))
- (close output)))
-
- #+clisp
- ;; BUG: CLisp doesn't allow output to user-specified stream
- (values
- nil
- nil
- (ext:run-shell-command command :output :terminal :wait t))
-
- #+openmcl
- (let* ((process (ccl:run-program
- "/bin/sh"
- (list "-c" command)
- :input nil :output :stream :error :stream
- :wait t))
- (output (read-stream-to-string (ccl::external-process-output-stream process)))
- (error (read-stream-to-string (ccl::external-process-error-stream process))))
- (close (ccl::external-process-output-stream process))
- (close (ccl::external-process-error-stream process))
- (values output
- error
- (nth-value 1 (ccl::external-process-status process))))
-
- #-(or openmcl clisp lispworks allegro scl cmu sbcl)
- (error "COMMAND-OUTPUT not implemented for this Lisp")
-
- ))
-
-
-;; From KMRCL
-(defmacro in (obj &rest choices)
- (let ((insym (gensym)))
- `(let ((,insym ,obj))
- (or ,@(mapcar #'(lambda (c) `(eql ,insym ,c))
- choices)))))
-
-;; From KMRCL
-(defun substitute-char-string (procstr match-char subst-str)
- "Substitutes a string for a single matching character of a string"
- (substitute-chars-strings procstr (list (cons match-char subst-str))))
-
-(defun replaced-string-length (str repl-alist)
- (declare (simple-string str)
- (optimize (speed 3) (safety 0) (space 0)))
- (do* ((i 0 (1+ i))
- (orig-len (length str))
- (new-len orig-len))
- ((= i orig-len) new-len)
- (declare (fixnum i orig-len new-len))
- (let* ((c (char str i))
- (match (assoc c repl-alist :test #'char=)))
- (declare (character c))
- (when match
- (incf new-len (1- (length
- (the simple-string (cdr match)))))))))
-
-
-(defun substitute-chars-strings (str repl-alist)
- "Replace all instances of a chars with a string. repl-alist is an assoc
-list of characters and replacement strings."
- (declare (simple-string str)
- (optimize (speed 3) (safety 0) (space 0)))
- (do* ((orig-len (length str))
- (new-string (make-string (replaced-string-length str repl-alist)))
- (spos 0 (1+ spos))
- (dpos 0))
- ((>= spos orig-len)
- new-string)
- (declare (fixnum spos dpos) (simple-string new-string))
- (let* ((c (char str spos))
- (match (assoc c repl-alist :test #'char=)))
- (declare (character c))
- (if match
- (let* ((subst (cdr match))
- (len (length subst)))
- (declare (fixnum len)
- (simple-string subst))
- (dotimes (j len)
- (declare (fixnum j))
- (setf (char new-string dpos) (char subst j))
- (incf dpos)))
- (progn
- (setf (char new-string dpos) c)
- (incf dpos))))))
-
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (when (char= #\a (schar (symbol-name '#:a) 0))
- (pushnew :lowercase-reader *features*)))
-
-(defun symbol-name-default-case (str)
- #-lowercase-reader
- (string-upcase str)
- #+lowercase-reader
- (string-downcase str))
-
-(defun convert-to-db-default-case (str database)
- (if database
- (case (db-type-default-case (database-underlying-type database))
- (:upper (string-upcase str))
- (:lower (string-downcase str))
- (t str))
- ;; Default CommonSQL behavior is to upcase strings
- (string-upcase str)))
-
-
-(defun ensure-keyword (name)
- "Returns keyword for a name"
- (etypecase name
- (keyword name)
- (string (nth-value 0 (intern (symbol-name-default-case name) :keyword)))
- (symbol (nth-value 0 (intern (symbol-name name) :keyword)))))
+++ /dev/null
-clsql-uffi.so
-clsql-uffi.dll
-clsql-uffi.lib
-clsql-uffi.dylib
-.bin
-*.fasl
-*.pfsl
-*.dfsl
-*.cfsl
-*.fasla16
-*.fasla8
-*.faslm16
-*.faslm8
-*.fsl
+++ /dev/null
-SUBDIRS :=
-
-include ../Makefile.common
-
-.PHONY: distclean
-distclean: clean
+++ /dev/null
-;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
-;;;; *************************************************************************
-;;;; FILE IDENTIFICATION
-;;;;
-;;;; Name: functional.lisp
-;;;; Purpose: Functional interface
-;;;;
-;;;; Copyright (c) 1999-2001 Pierre R. Mai
-;;;;
-;;;; $Id$
-;;;;
-;;;; This file is part of CLSQL.
-;;;;
-;;;; 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-classic)
-
-;;; This file implements the more advanced functions of the
-;;; functional SQL interface, which are just nicer layers above the
-;;; basic SQL interface.
-
-;;; These functions are no longer exported since they conflict with names
-;;; exported by CLSQL
-
-(defun insert-records
- (&key into attributes values av-pairs query (database *default-database*))
- "Insert records into the given table according to the given options."
- (cond
- ((and av-pairs (or attributes values))
- (error "Supply either av-pairs or values (and possibly attributes) to call of insert-records."))
- ((and (or av-pairs values) query)
- (error
- "Supply either query or values/av-pairs to call of insert-records."))
- ((and attributes (not query)
- (or (not (listp values)) (/= (length attributes) (length values))))
- (error "You must supply a matching values list when using attributes in call of insert-records."))
- (query
- (execute-command
- (format nil "insert into ~A ~@[(~{~A~^,~}) ~]~A" into attributes query)
- :database database))
- (t
- (execute-command
- (multiple-value-bind (attributes values)
- (if av-pairs
- (values (mapcar #'first av-pairs) (mapcar #'second av-pairs))
- (values attributes values))
- (format nil "insert into ~A ~@[(~{~A~^,~}) ~]values (~{'~A'~^,~})"
- into attributes values))
- :database database))))
-
-(defun delete-records (&key from where (database *default-database*))
- "Delete the indicated records from the given database."
- (execute-command (format nil "delete from ~A ~@[where ~A ~]" from where)
- :database database))
-
-(defun update-records (table &key attributes values av-pairs where (database *default-database*))
- "Update the specified records in the given database."
- (cond
- ((and av-pairs (or attributes values))
- (error "Supply either av-pairs or values (and possibly attributes) to call of update-records."))
- ((and attributes
- (or (not (listp values)) (/= (length attributes) (length values))))
- (error "You must supply a matching values list when using attributes in call of update-records."))
- ((or (and attributes (not values)) (and values (not attributes)))
- (error "You must supply both values and attributes in call of update-records."))
- (t
- (execute-command
- (format nil "update ~A set ~:{~A = '~A'~:^, ~}~@[ where ~A~]"
- table
- (or av-pairs
- (mapcar #'list attributes values))
- where)
- :database database))))
-
+++ /dev/null
-;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
-;;;; *************************************************************************
-;;;; FILE IDENTIFICATION
-;;;;
-;;;; Name: package.lisp
-;;;; Purpose: Package definition for CLSQL-CLASSIC high-level interface
-;;;; Programmers: Kevin M. Rosenberg based on
-;;;; Original code by Pierre R. Mai
-;;;; Date Started: Feb 2002
-;;;;
-;;;; $Id$
-;;;;
-;;;; 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
-;;;; 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)
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (defpackage #:clsql-classic
- (:use #:cl #:clsql-base)
- (:import-from
- #:clsql-base
- .
- #1=(
- #: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-access-error
- #:clsql-access-error-database-type
- #:clsql-access-error-connection-spec
- #:clsql-access-error-error
- #:clsql-connect-error
- #:clsql-connect-error-errno
- #: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
-
- #:*loaded-database-types*
- #:reload-database-types
- #:*default-database-type*
- #:*initialized-database-types*
- #:initialize-database-type
-
- #:database
- #:database-name
- #:database-type
- #:is-database-open
- #:database-name-from-spec
-
- ;; utils.lisp
- #:number-to-sql-string
- #:float-to-sql-string
- #:sql-escape-quotes
-
- ;; 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
- #:create-database
- #:destroy-database
- #:probe-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
- #:disconnect-pooled
- ))
- (:export
- ;; sql.cl
- #:for-each-row
-
- ;; Large objects (Marc B)
- #:create-large-object
- #:write-large-object
- #:read-large-object
- #:delete-large-object
-
- ;; functional.lisp
- ;; These are no longer export since different functions are
- ;; exported by the CLSQL package
- ;; #:insert-records
- ;; #:delete-records
- ;; #:update-records
-
- .
- #1#
- )
- (:documentation "This is the INTERNAL SQL-Interface package of CLSQL-CLASSIC."))
-
- ) ;eval-when
-
-(defpackage #:clsql-classic-user
- (:use #:common-lisp #:clsql-classic)
- (:documentation "This is the user package for experimenting with CLSQL-CLASSIC."))
+++ /dev/null
-;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
-;;;; *************************************************************************
-;;;; FILE IDENTIFICATION
-;;;;
-;;;; 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-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
-;;;; 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-classic)
-
-
-;;; Row processing macro
-
-(defmacro for-each-row (((&rest fields) &key from order-by where distinct limit) &body body)
- (let ((d (gensym "DISTINCT-"))
- (bind-fields (loop for f in fields collect (car f)))
- (w (gensym "WHERE-"))
- (o (gensym "ORDER-BY-"))
- (frm (gensym "FROM-"))
- (l (gensym "LIMIT-"))
- (q (gensym "QUERY-")))
- `(let ((,frm ,from)
- (,w ,where)
- (,d ,distinct)
- (,l ,limit)
- (,o ,order-by))
- (let ((,q (query-string ',fields ,frm ,w ,d ,o ,l)))
- (loop for tuple in (query ,q)
- collect (destructuring-bind ,bind-fields tuple
- ,@body))))))
-
-(defun query-string (fields from where distinct order-by limit)
- (concatenate
- 'string
- (format nil "select ~A~{~A~^,~} from ~{~A~^ and ~}"
- (if distinct "distinct " "") (field-names fields)
- (from-names from))
- (if where (format nil " where ~{~A~^ ~}"
- (where-strings where)) "")
- (if order-by (format nil " order by ~{~A~^, ~}"
- (order-by-strings order-by)))
- (if limit (format nil " limit ~D" limit) "")))
-
-(defun lisp->sql-name (field)
- (typecase field
- (string field)
- (symbol (string-upcase (symbol-name field)))
- (cons (cadr field))
- (t (format nil "~A" field))))
-
-(defun field-names (field-forms)
- "Return a list of field name strings from a fields form"
- (loop for field-form in field-forms
- collect
- (lisp->sql-name
- (if (cadr field-form)
- (cadr field-form)
- (car field-form)))))
-
-(defun from-names (from)
- "Return a list of field name strings from a fields form"
- (loop for table in (if (atom from) (list from) from)
- collect (lisp->sql-name table)))
-
-
-(defun where-strings (where)
- (loop for w in (if (atom (car where)) (list where) where)
- collect
- (if (consp w)
- (format nil "~A ~A ~A" (second w) (first w) (third w))
- (format nil "~A" w))))
-
-(defun order-by-strings (order-by)
- (loop for o in order-by
- collect
- (if (atom o)
- (lisp->sql-name o)
- (format nil "~A ~A" (lisp->sql-name (car o))
- (lisp->sql-name (cadr o))))))
-
-
-
-;;; These functions are not exported. If you application depends on these
-;;; functions consider using the clsql package using has further support.
-
-(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))
-
-
-(defun list-attributes (table &key (database *default-database*))
- "List the attributes of TABLE in *default-database, or if the
-:database keyword is given, the specified database. Attributes are
-returned as a list of strings."
- (database-list-attributes table database))
-
-(defun attribute-type (attribute table &key (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*."
- (database-attribute-type attribute table database))
-
-(defun create-sequence (name &key (database *default-database*))
- (database-create-sequence name database))
-
-(defun drop-sequence (name &key (database *default-database*))
- (database-drop-sequence name database))
-
-(defun sequence-next (name &key (database *default-database*))
- (database-sequence-next name database))
-
-
:description "Common Lisp SQL AODBC Driver"
:long-description "cl-sql-aodbc package provides a database driver to AllegroCL's AODBC database interface."
- :depends-on (clsql-base)
+ :depends-on (clsql)
:components
((:module :db-aodbc
:components
+++ /dev/null
-;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
-;;;; *************************************************************************
-;;;; FILE IDENTIFICATION
-;;;;
-;;;; Name: clsql-base.asd
-;;;; Purpose: ASDF definition file for Base CLSQL
-;;;; Programmer: Kevin M. Rosenberg
-;;;; Date Started: Feb 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.
-;;;; *************************************************************************
-
-(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)
-
-#+(or allegro lispworks cmu sbcl openmcl mcl scl)
-(defsystem clsql-base
- :name "cl-sql-base"
- :author "Kevin Rosenberg <kevin@rosenberg.net>"
- :maintainer "Kevin M. Rosenberg <kmr@debian.org>"
- :licence "Lessor Lisp General Public License"
- :description "Common Lisp SQL Base Package"
- :long-description "cl-sql-base package provides the low-level interface for the database drivers."
-
- :components
- ((:module :base
- :components
- ((:file "cmucl-compat")
- (:file "package")
- (:file "utils" :depends-on ("package" "db-interface"))
- (:file "classes" :depends-on ("package"))
- (:file "conditions" :depends-on ("classes"))
- (:file "db-interface" :depends-on ("conditions"))
- (:file "initialize" :depends-on ("db-interface" "utils"))
- (: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" "cmucl-compat"))
- (:file "pool" :depends-on ("basic-sql"))
- (:file "transaction" :depends-on ("basic-sql"))
- ))))
-
+++ /dev/null
-;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
-;;;; *************************************************************************
-;;;; FILE IDENTIFICATION
-;;;;
-;;;; Name: clsql-classic.asd
-;;;; Purpose: System definition for CLSQL-CLASSIC
-;;;; Programmer: Kevin M. Rosenberg
-;;;; Date Started: Feb 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.
-;;;; *************************************************************************
-
-(defpackage #:clsql-classic-system (:use #:asdf #:cl))
-(in-package #:clsql-classic-system)
-
-#+(or allegro lispworks cmu sbcl openmcl mcl scl)
-(defsystem clsql-classic
- :name "clsql-classic"
- :author "Kevin Rosenberg <kevin@rosenberg.net>"
- :maintainer "Kevin M. Rosenberg <kmr@debian.org>"
- :version "2.1.x"
- :licence "Lessor Lisp General Public License"
- :description "Common Lisp SQL Interface Library"
- :long-description "cl-sql package provides the high-level interface for the CLSQL system."
-
- :depends-on (clsql-base)
- :components
- ((:module :classic
- :components
- ((:file "package")
- (:file "sql" :depends-on ("package"))
- (:file "functional" :depends-on ("sql"))))))
-
-#+(or allegro lispworks cmu sbcl openmcl mcl scl)
-(defmethod perform ((o test-op) (c (eql (find-system 'clsql-classic))))
- (warn "Testing is provided by the CLSQL-TESTS system"))
:description "Common Lisp SQL MySQL Driver"
:long-description "cl-sql-mysql package provides a database driver to the MySQL database system."
- :depends-on (uffi clsql-base clsql-uffi)
+ :depends-on (uffi clsql clsql-uffi)
:components
((:module :db-mysql
:components
:description "Common Lisp SQL ODBC Driver"
:long-description "cl-sql-odbc package provides a database driver to the ODBC database system."
- :depends-on (uffi clsql-base clsql-uffi)
+ :depends-on (uffi clsql clsql-uffi)
:components
((:module :db-odbc
:components
:description "Common Lisp SQL Oracle Driver"
:long-description "cl-sql-oracle package provides a database driver to the Oracle database system."
- :depends-on (clsql-base)
+ :depends-on (clsql)
:components
((:module :db-oracle
:components
:description "Common Lisp SQL PostgreSQL Socket Driver"
:long-description "cl-sql-postgresql-socket package provides a database driver to the PostgreSQL database via a socket interface."
- :depends-on (clsql-base uffi md5 #+sbcl sb-bsd-sockets)
+ :depends-on (clsql uffi md5 #+sbcl sb-bsd-sockets)
:components
((:module :db-postgresql-socket
:components
:description "Common Lisp PostgreSQL API Driver"
:long-description "cl-sql-postgresql package provides a the database driver for the PostgreSQL API."
- :depends-on (uffi clsql-base clsql-uffi)
+ :depends-on (uffi clsql clsql-uffi)
:components
((:module :db-postgresql
:components
:long-description "cl-sql-sqlite package provides a database driver to SQLite database library."
- :depends-on (clsql-base #-clisp clsql-uffi)
+ :depends-on (clsql #-clisp clsql-uffi)
:components
((:module :db-sqlite
:components
:description "Common UFFI Helper functions for Common Lisp SQL Interface Library"
:long-description "cl-sql-uffi package provides common helper functions using the UFFI for the CLSQL package."
- :depends-on (uffi clsql-base)
+ :depends-on (uffi clsql)
:components
((:module :uffi
(defsystem #:clsql
:name "CLSQL"
- :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."
- :depends-on (clsql-base)
+ :author "Kevin Rosenberg <kevin@rosenberg.net>"
+ :maintainer "Kevin M. Rosenberg <kmr@debian.org>"
+ :licence "Lessor Lisp General Public License"
+ :description "Common Lisp SQL Interface library"
+ :long-description "A Common Lisp interface to SQL RDBMS based on
+the Xanalys CommonSQL interface for Lispworks. It depends on the
+low-level database interfaces as well as a functional and an object
+oriented interface."
:components
((:module sql
:components
- ((:module :package
+ ((:module :base
:pathname ""
- :components ((:file "package")
- (:file "kmr-mop" :depends-on ("package"))))
+ :components
+ ((:file "cmucl-compat")
+ (:file "package")
+ (:file "utils" :depends-on ("package" "db-interface"))
+ (:file "base-classes" :depends-on ("package"))
+ (:file "conditions" :depends-on ("base-classes"))
+ (:file "db-interface" :depends-on ("conditions"))
+ (:file "initialize" :depends-on ("db-interface" "utils"))
+ (: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" "cmucl-compat"))
+ (:file "pool" :depends-on ("basic-sql"))
+ (:file "transaction" :depends-on ("basic-sql"))
+ (:file "kmr-mop" :depends-on ("package"))))
(:module :core
:pathname ""
:components ((:file "generics")
(:file "classes" :depends-on ("generics"))
(:file "operations" :depends-on ("classes"))
(:file "syntax" :depends-on ("operations")))
- :depends-on (:package))
+ :depends-on (:base))
(:module :functional
:pathname ""
:components ((:file "sql")
(defpackage #:clsql-aodbc
(:nicknames #:aodbc)
- (:use #:cl #:clsql-base)
+ (:use #:common-lisp #:clsql-sys)
(:export #:aodbc-database)
(:documentation "This is the CLSQL interface to Allegro's AODBC"))
(defvar *mysql-library-loaded* nil
"T if foreign library was able to be loaded successfully")
-(defmethod clsql-base:database-type-library-loaded ((database-type (eql :mysql)))
+(defmethod clsql-sys:database-type-library-loaded ((database-type (eql :mysql)))
*mysql-library-loaded*)
-(defmethod clsql-base:database-type-load-foreign ((database-type (eql :mysql)))
+(defmethod clsql-sys:database-type-load-foreign ((database-type (eql :mysql)))
(let ((mysql-path
(uffi:find-foreign-library *mysql-library-candidate-names*
*mysql-library-candidate-directories*
(setq *mysql-library-loaded* t))
-(clsql-base:database-type-load-foreign :mysql)
+(clsql-sys:database-type-load-foreign :mysql)
(in-package #:cl-user)
(defpackage #:mysql
- (:use #:cl #:clsql-uffi)
+ (:use #:common-lisp #:clsql-uffi)
(:export
#:database-library-loaded
;;;; *************************************************************************
(defpackage #:clsql-mysql
- (:use #:common-lisp #:clsql-base #:mysql #:clsql-uffi)
+ (:use #:common-lisp #:clsql-sys #:mysql #:clsql-uffi)
(:export #:mysql-database)
(:documentation "This is the CLSQL interface to MySQL."))
(defmethod database-create (connection-spec (type (eql :mysql)))
(destructuring-bind (host name user password) connection-spec
(multiple-value-bind (output status)
- (clsql-base:command-output "mysqladmin create -u~A -p~A -h~A ~A"
+ (clsql-sys:command-output "mysqladmin create -u~A -p~A -h~A ~A"
user password
(if host host "localhost")
name)
(defmethod database-destroy (connection-spec (type (eql :mysql)))
(destructuring-bind (host name user password) connection-spec
(multiple-value-bind (output status)
- (clsql-base:command-output "mysqladmin drop -f -u~A -p~A -h~A ~A"
+ (clsql-sys:command-output "mysqladmin drop -f -u~A -p~A -h~A ~A"
user password
(if host host "localhost")
name)
(let ((database (database-connect (list host "mysql" user password) type)))
(unwind-protect
(progn
- (setf (slot-value database 'clsql-base::state) :open)
+ (setf (slot-value database 'clsql-sys::state) :open)
(mapcar #'car (database-query "show databases" database :auto nil)))
(progn
(database-disconnect database)
- (setf (slot-value database 'clsql-base::state) :closed))))))
+ (setf (slot-value database 'clsql-sys::state) :closed))))))
;;; Database capabilities
(let ((tuple (car (database-query "SHOW VARIABLES LIKE 'HAVE_INNODB'" database :auto nil))))
(and tuple (string-equal "YES" (second tuple)))))
-(when (clsql-base:database-type-library-loaded :mysql)
- (clsql-base:initialize-database-type :database-type :mysql))
+(when (clsql-sys:database-type-library-loaded :mysql)
+ (clsql-sys:initialize-database-type :database-type :mysql))
(defvar *time-conversion-function*
(lambda (universal-time &optional fraction)
(declare (ignore fraction))
- (clsql-base:format-time
- nil (clsql-base:utime->time universal-time)
+ (clsql-sys:format-time
+ nil (clsql-sys:utime->time universal-time)
:format :iso)
#+ignore
universal-time)
(progn ,result-code ,@body))
(#.$SQL_INVALID_HANDLE
(error
- 'clsql-base:clsql-odbc-error
+ 'clsql-sys:clsql-odbc-error
:odbc-message "Invalid handle"))
(#.$SQL_STILL_EXECUTING
(error
- 'clsql-base:clsql-odbc-error
+ 'clsql-sys:clsql-odbc-error
:odbc-message "Still executing"))
(#.$SQL_ERROR
(multiple-value-bind (error-message sql-state)
(or ,hdbc +null-handle-ptr+)
(or ,hstmt +null-handle-ptr+))
(error
- 'clsql-base:clsql-odbc-error
+ 'clsql-sys:clsql-odbc-error
:odbc-message error-message
:sql-state sql-state)))
(#.$SQL_NO_DATA_FOUND
(or ,hdbc +null-handle-ptr+)
(or ,hstmt +null-handle-ptr+))
(error
- 'clsql-base:clsql-odbc-error
+ 'clsql-sys:clsql-odbc-error
:odbc-message error-message
:sql-state sql-state))
#+ignore
"get-free-query finds or makes a nonactive query object, and then sets it to active.
This makes the functions db-execute-command and db-query thread safe."
(with-slots (queries hdbc) database
- (or (clsql-base:without-interrupts
+ (or (clsql-sys:without-interrupts
(let ((inactive-query (find-if (lambda (query)
(not (query-active-p query)))
queries)))
(defvar *odbc-library-loaded* nil
"T if foreign library was able to be loaded successfully")
-(defmethod clsql-base:database-type-library-loaded ((database-type (eql :odbc)))
+(defmethod clsql-sys:database-type-library-loaded ((database-type (eql :odbc)))
*odbc-library-loaded*)
-(defmethod clsql-base:database-type-load-foreign ((database-type (eql :odbc)))
+(defmethod clsql-sys:database-type-load-foreign ((database-type (eql :odbc)))
(uffi:load-foreign-library *odbc-library-path*
:module "odbc")
(setq *odbc-library-loaded* t))
-(clsql-base:database-type-load-foreign :odbc)
+(clsql-sys:database-type-load-foreign :odbc)
;;;; *************************************************************************
(defpackage #:clsql-odbc
- (:use #:common-lisp #:clsql-base)
+ (:use #:common-lisp #:clsql-sys)
(:export #:odbc-database)
(:documentation "This is the CLSQL interface to ODBC."))
;; nothing to do
t)
-(when (clsql-base:database-type-library-loaded :odbc)
- (clsql-base:initialize-database-type :database-type :odbc))
+(when (clsql-sys:database-type-library-loaded :odbc)
+ (clsql-sys:initialize-database-type :database-type :odbc))
(in-package #:cl-user)
(defpackage #:clsql-oracle
- (:use #:common-lisp #:clsql-base)
+ (:use #:common-lisp #:clsql-sys)
(:export #:oracle-database
#:*oracle-so-load-path*
#:*oracle-so-libraries*)
(:float4 700)
(:float8 701)))
-(defmethod clsql-base:database-type-library-loaded ((database-type
+(defmethod clsql-sys:database-type-library-loaded ((database-type
(eql :postgresql-socket)))
"T if foreign library was able to be loaded successfully. Always true for
socket interface"
t)
-(defmethod clsql-base:database-type-load-foreign ((database-type (eql :postgresql-socket)))
+(defmethod clsql-sys:database-type-load-foreign ((database-type (eql :postgresql-socket)))
t)
:connection connection :message message))))
(#.+notice-response-message+
(let ((message (read-socket-value-string socket)))
- (unless (eq :ignore clsql-base:*backend-warning-behavior*)
+ (unless (eq :ignore clsql-sys:*backend-warning-behavior*)
(warn 'postgresql-warning
:connection connection :message message))))
(#.+notification-response-message+
(in-package #:cl-user)
(defpackage :clsql-postgresql-socket
- (:use #:common-lisp #:clsql-base #:postgresql-socket)
+ (:use #:common-lisp #:clsql-sys #:postgresql-socket)
(:export #:postgresql-socket-database)
(:documentation "This is the CLSQL socket interface to PostgreSQL."))
;; interface foreign library loading routines
-(clsql-base:database-type-load-foreign :postgresql-socket)
+(clsql-sys:database-type-load-foreign :postgresql-socket)
;; Field type conversion
type)))
(unwind-protect
(progn
- (setf (slot-value database 'clsql-base::state) :open)
+ (setf (slot-value database 'clsql-sys::state) :open)
(mapcar #'car (database-query "select datname from pg_database"
database :auto nil)))
(progn
(database-disconnect database)
- (setf (slot-value database 'clsql-base::state) :closed))))))
+ (setf (slot-value database 'clsql-sys::state) :closed))))))
(defmethod database-describe-table ((database postgresql-socket-database)
table)
(defmethod db-type-default-case ((db-type (eql :postgresql-socket)))
:lower)
-(when (clsql-base:database-type-library-loaded :postgresql-socket)
- (clsql-base:initialize-database-type :database-type :postgresql-socket))
+(when (clsql-sys:database-type-library-loaded :postgresql-socket)
+ (clsql-sys:initialize-database-type :database-type :postgresql-socket))
(defvar *postgresql-library-loaded* nil
"T if foreign library was able to be loaded successfully")
-(defmethod clsql-base:database-type-library-loaded ((database-type
+(defmethod clsql-sys:database-type-library-loaded ((database-type
(eql :postgresql)))
*postgresql-library-loaded*)
-(defmethod clsql-base:database-type-load-foreign ((database-type
+(defmethod clsql-sys:database-type-load-foreign ((database-type
(eql :postgresql)))
(let ((libpath (uffi:find-foreign-library
"libpq"
(setq *postgresql-library-loaded* t)
(warn "Can't load PostgreSQL client library ~A" libpath))))
-(clsql-base:database-type-load-foreign :postgresql)
+(clsql-sys:database-type-load-foreign :postgresql)
(in-package #:cl-user)
(defpackage #:clsql-postgresql
- (:use #:common-lisp #:clsql-base #:postgresql #:clsql-uffi)
+ (:use #:common-lisp #:clsql-sys #:postgresql #:clsql-uffi)
(:export #:postgresql-database)
(:documentation "This is the CLSQL interface to PostgreSQL."))
(destructuring-bind (host name user password) connection-spec
(declare (ignore user password))
(multiple-value-bind (output status)
- (clsql-base:command-output "createdb -h~A ~A"
+ (clsql-sys:command-output "createdb -h~A ~A"
(if host host "localhost")
name)
(if (or (not (zerop status))
(destructuring-bind (host name user password) connection-spec
(declare (ignore user password))
(multiple-value-bind (output status)
- (clsql-base:command-output "dropdb -h~A ~A"
+ (clsql-sys:command-output "dropdb -h~A ~A"
(if host host "localhost")
name)
(if (or (not (zerop status))
type)))
(unwind-protect
(progn
- (setf (slot-value database 'clsql-base::state) :open)
+ (setf (slot-value database 'clsql-sys::state) :open)
(mapcar #'car (database-query "select datname from pg_database"
database nil nil)))
(progn
(database-disconnect database)
- (setf (slot-value database 'clsql-base::state) :closed))))))
+ (setf (slot-value database 'clsql-sys::state) :closed))))))
(defmethod database-describe-table ((database postgresql-database) table)
(database-query
(defmethod db-type-default-case ((db-type (eql :postgresql)))
:lower)
-(when (clsql-base:database-type-library-loaded :postgresql)
- (clsql-base:initialize-database-type :database-type :postgresql))
+(when (clsql-sys:database-type-library-loaded :postgresql)
+ (clsql-sys:initialize-database-type :database-type :postgresql))
(setq *sqlite-library-loaded* t)
(warn "Can't load SQLite library ~A" libpath))))
-(clsql-base:database-type-load-foreign :sqlite)
+(clsql-sys:database-type-load-foreign :sqlite)
(in-package #:cl-user)
(defpackage #:clsql-sqlite
- (:use #:common-lisp #:clsql-base)
+ (:use #:common-lisp #:clsql-sys)
(:export #:sqlite-database))
Package: cl-sql
Architecture: all
-Depends: cl-sql-base
+Depends: common-lisp-controller (>= 3.37)
+Recommends: cl-sql-backend
Description: SQL Interface for Common Lisp
CLSQL is a Common Lisp interface for multiple SQL databases
on multiple Common Lisp implementations. It uses the UFFI
foreign language interface.
-Package: cl-sql-base
-Architecture: all
-Depends: common-lisp-controller (>= 3.37)
-Recommends: cl-sql-backend
-Description: SQL Interface for Common Lisp
- CLSQL uses the UFFI library to provide SQL to multiple SQL databases
- on multiple Common Lisp implementations.
- .
- This package provides the base framework for database backends.
-
Package: cl-sql-uffi
Architecture: any
-Depends: common-lisp-controller (>= 3.37), cl-uffi, cl-sql-base
+Depends: cl-uffi, cl-sql (>= ${Source-Version})
Recommends: cl-sql-backend
Description: Common UFFI functions for CLSQL database backends
This package provides an interface to several UFFI functions used by multiple
Package: cl-sql-mysql
Architecture: any
-Depends: cl-sql-base (>= ${Source-Version}), libmysqlclient-dev, cl-sql-uffi (>= ${Source-Version})
+Depends: cl-sql (>= ${Source-Version}), libmysqlclient-dev, cl-sql-uffi (>= ${Source-Version})
Provides: cl-sql-backend
Description: CLSQL database backend, MySQL
This package enables you to use the CLSQL data access package
Package: cl-sql-aodbc
Architecture: all
-Depends: cl-sql-base (>= ${Source-Version}), cl-sql-mysql, cl-sql-postgresql
+Depends: cl-sql (>= ${Source-Version}), cl-sql-mysql, cl-sql-postgresql
Provides: cl-sql-backend
Suggests: acl-pro-installer
Description: CLSQL database backend, AODBC
Package: cl-sql-odbc
Architecture: all
-Depends: cl-sql-base (>= ${Source-Version}), unixodbc-dev, cl-sql-mysql, cl-sql-postgresql
+Depends: cl-sql (>= ${Source-Version}), unixodbc-dev, cl-sql-mysql, cl-sql-postgresql
Provides: cl-sql-backend
Suggests: acl-pro-installer
Description: CLSQL database backend, ODBC
Package: cl-sql-postgresql
Architecture: all
-Depends: cl-sql-base (>= ${Source-Version}), postgresql-dev, cl-sql-uffi (>= ${Source-Version})
+Depends: cl-sql (>= ${Source-Version}), postgresql-dev, cl-sql-uffi (>= ${Source-Version})
Provides: cl-sql-backend
Description: CLSQL database backend, PostgreSQL
This package enables you to use the CLSQL data access package
Package: cl-sql-postgresql-socket
Architecture: all
-Depends: cl-sql-base (>= ${Source-Version}), cl-md5, cl-sql-uffi (>= ${Source-Version}), libc6-dev
+Depends: cl-sql (>= ${Source-Version}), cl-md5, cl-sql-uffi (>= ${Source-Version}), libc6-dev
Provides: cl-sql-backend
Description: CLSQL database backend, PostgreSQL
This package enables you to use the CLSQL data access package
Package: cl-sql-sqlite
Architecture: all
-Depends: cl-sql-base (>= ${Source-Version}), libsqlite0-dev, cl-sql-uffi (>= ${Source-Version})
+Depends: cl-sql (>= ${Source-Version}), libsqlite0-dev, cl-sql-uffi (>= ${Source-Version})
Provides: cl-sql-backend
Description: CLSQL database backend, SQLite
This package enables you to use the CLSQL data access package
with SQLite databases.
CLSQL is a Common Lisp interface to SQL databases.
-Package: cl-sql-classic
-Architecture: all
-Depends: cl-sql-base (>= ${Source-Version})
-Description: Classic CLSQL high-level interface
- This package provides the Classic, original high-level interface for CLSQL.
- CLSQL is a Common Lisp interface to SQL databases.
-
Package: cl-sql-tests
Architecture: all
-Depends: cl-sql-base, cl-sql-postgresql, cl-sql-postgresql-socket, cl-sql-mysql, cl-rt
+Depends: cl-sql, cl-sql-postgresql, cl-sql-postgresql-socket, cl-sql-mysql, cl-sqlite, cl-sql-odbc, rt
Suggests: acl-installer, libmyodbc, unixodbc,cl-sql-aodbc
Description: Testing suite for CLSQL
This package contains a test suite for CLSQL. It requires manual
plain-pkg := clsql
pkg := cl-sql
-pkg-base := cl-sql-base
pkg-uffi := cl-sql-uffi
-pkg-classic := cl-sql-classic
pkg-mysql := cl-sql-mysql
pkg-pg := cl-sql-postgresql
pkg-pg-socket := cl-sql-postgresql-socket
pkg-odbc := cl-sql-odbc
pkg-sqlite := cl-sql-sqlite
pkg-tests := cl-sql-tests
-all-pkgs := $(pkg) $(pkg-base) $(pkg-uffi) $(pkg-mysql) $(pkg-pg) $(pkg-pg-socket) $(pkg-aodbc) $(pkg-odbc) $(pkg-sqlite) $(pkg-tests)
+all-pkgs := $(pkg) $(pkg-uffi) $(pkg-mysql) $(pkg-pg) $(pkg-pg-socket) $(pkg-aodbc) $(pkg-odbc) $(pkg-sqlite) $(pkg-tests)
UPSTREAM_VER := $(shell sed -n -e "s/${pkg} (\(.*\)-[0-9A-Za-z\.]).*/\1/p" < debian/changelog |head -1)
## Lisp sources
srcs := $(wildcard sql/*.lisp) clsql.asd
-srcs-base := $(wildcard base/*.lisp)
-srcs-classic := $(wildcard classic/*.lisp)
srcs-uffi := $(wildcard uffi/*.lisp) $(wildcard uffi/*.c)
srcs-uffi-so := $(wildcard uffi/*.so)
srcs-mysql := $(wildcard db-mysql/*.lisp) $(wildcard db-mysql/*.c)
clc-sql := $(clc-source)/clsql
lispdir-sql := $(clc-sql)/sql
-clc-base := $(clc-source)/clsql-base
-lispdir-base := $(clc-base)/base
-clc-classic := $(clc-source)/clsql-classic
-lispdir-classic := $(clc-classic)/classic
clc-uffi := $(clc-source)/clsql-uffi
lispdir-uffi := $(clc-uffi)/uffi
sodir-uffi := usr/lib/clsql
# Add here commands to install the package into debian/uffi.
dh_installdirs --all $(clc-systems) $(clc-source)
dh_installdirs -p $(pkg) $(lispdir-sql)
- dh_installdirs -p $(pkg-base) $(lispdir-base)
dh_installdirs -p $(pkg-uffi) $(lispdir-uffi) $(sodir-uffi)
dh_installdirs -p $(pkg-pg) $(lispdir-pg)
dh_installdirs -p $(pkg-pg-socket) $(lispdir-pg-socket)
dh_install -p $(pkg) $(srcs) $(lispdir-sql)
dh_install -p $(pkg) clsql.asd $(clc-clsql)
- # Base
- dh_install -p $(pkg-base) $(srcs-base) $(lispdir-base)
- dh_install -p $(pkg-base) clsql-base.asd $(clc-base)
-
- # Classic
- dh_install -p $(pkg-classic) $(srcs-classic) $(lispdir-classic)
- dh_install -p $(pkg-classic) clsql-classic.asd $(clc-classic)
-
# UFFI
dh_install -p $(pkg-uffi) $(srcs-uffi) $(lispdir-uffi)
dh_install -p $(pkg-uffi) $(srcs-uffi-so) $(sodir-uffi)
# CLC Systems
dh_link -p $(pkg) $(clc-clsql)/clsql.asd $(clc-systems)/clsql.asd
- dh_link -p $(pkg-base) $(clc-base)/clsql-base.asd $(clc-systems)/clsql-base.asd
- dh_link -p $(pkg-classic) $(clc-classic)/clsql-classic.asd $(clc-systems)/clsql-classic.asd
dh_link -p $(pkg-uffi) $(clc-uffi)/clsql-uffi.asd $(clc-systems)/clsql-uffi.asd
dh_link -p $(pkg-mysql) $(clc-mysql)/clsql-mysql.asd $(clc-systems)/clsql-mysql.asd
dh_link -p $(pkg-pg) $(clc-pg)/clsql-postgresql.asd $(clc-systems)/clsql-postgresql.asd
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: classes.lisp
+;;;; Purpose: Classes for High-level SQL interface
+;;;; Programmers: Kevin M. Rosenberg based on
+;;;; original code by Pierre R. Mai
+;;;; Date Started: Feb 2002
+;;;;
+;;;; $Id$
+;;;;
+;;;; 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
+;;;; 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)
+
+
+(defclass database ()
+ ((name :initform nil :initarg :name :reader database-name)
+ (connection-spec :initform nil :initarg :connection-spec
+ :reader connection-spec
+ :documentation "Require to use connection pool")
+ (database-type :initarg :database-type :initform :unknown
+ :reader database-type)
+ (state :initform :closed :reader database-state)
+ (command-recording-stream :accessor command-recording-stream :initform nil)
+ (result-recording-stream :accessor result-recording-stream :initform nil)
+ (record-caches :accessor record-caches :initform nil)
+ (view-classes :accessor database-view-classes :initform nil)
+ (schema :accessor database-schema :initform nil)
+ (transaction-level :initform 0 :accessor transaction-level)
+ (transaction :initform nil :accessor transaction)
+ (conn-pool :initform nil :initarg :conn-pool :accessor conn-pool)
+ (attribute-cache :initform (make-hash-table :size 100 :test 'equal)
+ :accessor attribute-cache
+ :documentation "Internal cache of table attributes. It is keyed by table-name. Values
+are a list of ACTION specified for table and any cached value of list-attributes-types."))
+ (:documentation
+ "This class is the supertype of all databases handled by CLSQL."))
+
+(defmethod print-object ((object database) stream)
+ (print-unreadable-object (object stream :type t :identity t)
+ (format stream "~A ~A"
+ (if (slot-boundp object 'name)
+ (database-name object)
+ "<unbound>")
+ (database-state object))))
+
+
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;;
+;;;; $Id$
+;;;;
+;;;; Base SQL functions
+;;;;
+;;;; This file is part of CLSQL.
+;;;;
+;;;; 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)
+
+;;; 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 :auto) (flatp nil) (field-names t))
+ (record-sql-command query-expression database)
+ (multiple-value-bind (rows names) (database-query query-expression database result-types
+ field-names)
+ (let ((result (if (and flatp (= 1 (length (car rows))))
+ (mapcar #'car rows)
+ rows)))
+ (record-sql-result result database)
+ (if field-names
+ (values result names)
+ result))))
+
+;;; 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))
+
+;;; 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))
+
;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;; *************************************************************************
-(in-package #:clsql)
+(in-package #:clsql-sys)
(defvar +empty-string+ "''")
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; 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-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)
+
+(defpackage #:cmucl-compat
+ (:use #:common-lisp)
+ (:export
+ #:shrink-vector
+ #:make-sequence-of-type
+ #:result-type-or-lose
+ #:required-argument
+ ))
+(in-package #:cmucl-compat)
+
+#+(or cmu scl)
+(defmacro required-argument ()
+ `(ext:required-argument))
+
+#-(or cmu scl)
+(defun required-argument ()
+ (error "~&A required keyword argument was not supplied"))
+
+#+(or cmu scl)
+(defmacro shrink-vector (vec len)
+ `(lisp::shrink-vector ,vec ,len))
+
+#+sbcl
+(defmacro shrink-vector (vec len)
+ `(sb-kernel::shrink-vector ,vec ,len))
+
+#-(or cmu sbcl scl)
+(defmacro shrink-vector (vec len)
+ "Shrinks a vector. Optimized if vector has a fill pointer.
+Needs to be a macro to overwrite value of VEC."
+ (let ((new-vec (gensym)))
+ `(cond
+ ((adjustable-array-p ,vec)
+ (adjust-array ,vec ,len))
+ ((typep ,vec 'simple-array)
+ (let ((,new-vec (make-array ,len :element-type
+ (array-element-type ,vec))))
+ (check-type ,len fixnum)
+ (locally (declare (optimize (speed 3) (safety 0) (space 0)) )
+ (dotimes (i ,len)
+ (declare (fixnum i))
+ (setf (aref ,new-vec i) (aref ,vec i))))
+ (setq ,vec ,new-vec)))
+ ((typep ,vec 'vector)
+ (setf (fill-pointer ,vec) ,len)
+ ,vec)
+ (t
+ (error "Unable to shrink vector ~S which is type-of ~S" ,vec (type-of ,vec)))
+ )))
+
+
+#-(or cmu scl)
+(defun make-sequence-of-type (type length)
+ "Returns a sequence of the given TYPE and LENGTH."
+ (make-sequence type length))
+
+#+(or cmu scl)
+(if (fboundp 'lisp::make-sequence-of-type)
+ (defun make-sequence-of-type (type len)
+ (lisp::make-sequence-of-type type len))
+ (defun 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)
+ (unless (or type nil-ok)
+ (error "NIL output type invalid for this sequence function"))
+ (case type
+ ((list cons)
+ 'list)
+ ((string simple-string base-string simple-base-string)
+ 'string)
+ (simple-vector
+ 'simple-vector)
+ (vector
+ 'vector)
+ (t
+ (error "~S is a bad type specifier for sequence functions." type))
+ ))
+
+#+(or cmu scl)
+(defun result-type-or-lose (type nil-ok)
+ (lisp::result-type-or-lose type nil-ok))
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: conditions.lisp
+;;;; Purpose: Error conditions for high-level SQL interface
+;;;; Programmers: Kevin M. Rosenberg based on
+;;;; Original code by Pierre R. Mai
+;;;; Date Started: Feb 2002
+;;;;
+;;;; $Id$
+;;;;
+;;;; 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
+;;;; 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)
+
+(defvar *backend-warning-behavior* :warn
+ "Action to perform on warning messages from backend. Default is to :warn. May also be
+set to :error to signal an error or :ignore/nil to silently ignore the warning.")
+
+;;; Conditions
+(define-condition clsql-condition ()
+ ())
+
+(define-condition clsql-error (error clsql-condition)
+ ())
+
+(define-condition clsql-simple-error (simple-condition clsql-error)
+ ())
+
+(define-condition clsql-warning (warning clsql-condition)
+ ())
+
+(define-condition clsql-simple-warning (simple-condition clsql-warning)
+ ())
+
+(define-condition clsql-generic-error (clsql-error)
+ ((message :initarg :message
+ :reader clsql-generic-error-message))
+ (:report (lambda (c stream)
+ (format stream (clsql-generic-error-message c)))))
+
+(define-condition clsql-invalid-spec-error (clsql-error)
+ ((connection-spec :initarg :connection-spec
+ :reader clsql-invalid-spec-error-connection-spec)
+ (database-type :initarg :database-type
+ :reader clsql-invalid-spec-error-database-type)
+ (template :initarg :template
+ :reader clsql-invalid-spec-error-template))
+ (:report (lambda (c stream)
+ (format stream "The connection specification ~A~%is invalid for database type ~A.~%The connection specification must conform to ~A"
+ (clsql-invalid-spec-error-connection-spec c)
+ (clsql-invalid-spec-error-database-type c)
+ (clsql-invalid-spec-error-template c)))))
+
+(defmacro check-connection-spec (connection-spec database-type template)
+ "Check the connection specification against the provided template,
+and signal an clsql-invalid-spec-error if they don't match."
+ `(handler-case
+ (destructuring-bind ,template ,connection-spec
+ (declare (ignore ,@(remove '&optional template)))
+ t)
+ (error () (error 'clsql-invalid-spec-error
+ :connection-spec ,connection-spec
+ :database-type ,database-type
+ :template (quote ,template)))))
+
+(define-condition clsql-access-error (clsql-error)
+ ((database-type :initarg :database-type
+ :reader clsql-access-error-database-type)
+ (connection-spec :initarg :connection-spec
+ :reader clsql-access-error-connection-spec)
+ (error :initarg :error :reader clsql-access-error-error))
+ (:report (lambda (c stream)
+ (format stream "While trying to access database ~A~% using database-type ~A:~% Error ~A~% has occurred."
+ (database-name-from-spec
+ (clsql-access-error-connection-spec c)
+ (clsql-access-error-database-type c))
+ (clsql-access-error-database-type c)
+ (clsql-access-error-error c)))))
+
+(define-condition clsql-connect-error (clsql-access-error)
+ ((errno :initarg :errno :reader clsql-connect-error-errno))
+ (:report (lambda (c stream)
+ (format stream "While trying to connect to database ~A~% using database-type ~A:~% Error ~D / ~A~% has occurred."
+ (database-name-from-spec
+ (clsql-access-error-connection-spec c)
+ (clsql-access-error-database-type c))
+ (clsql-access-error-database-type c)
+ (clsql-connect-error-errno c)
+ (clsql-access-error-error c)))))
+
+(define-condition clsql-sql-error (clsql-error)
+ ((database :initarg :database :reader clsql-sql-error-database)
+ (message :initarg :message :initform nil :reader clsql-sql-error-message)
+ (expression :initarg :expression :initarg nil :reader clsql-sql-error-expression)
+ (errno :initarg :errno :initarg nil :reader clsql-sql-error-errno)
+ (error :initarg :error :initarg nil :reader clsql-sql-error-error))
+ (:report (lambda (c stream)
+ (if (clsql-sql-error-message c)
+ (format stream "While accessing database ~A~%, Error~% ~A~% has occurred."
+ (clsql-sql-error-database c)
+ (clsql-sql-error-message c))
+ (format stream "While accessing database ~A~% with expression ~S:~% Error ~D / ~A~% has occurred."
+ (clsql-sql-error-database c)
+ (clsql-sql-error-expression c)
+ (clsql-sql-error-errno c)
+ (clsql-sql-error-error c))))))
+
+(define-condition clsql-database-warning (clsql-warning)
+ ((database :initarg :database :reader clsql-database-warning-database)
+ (message :initarg :message :reader clsql-database-warning-message))
+ (:report (lambda (c stream)
+ (format stream "While accessing database ~A~% Warning: ~A~% has occurred."
+ (clsql-database-warning-database c)
+ (clsql-database-warning-message c)))))
+
+(define-condition clsql-exists-condition (clsql-condition)
+ ((old-db :initarg :old-db :reader clsql-exists-condition-old-db)
+ (new-db :initarg :new-db :reader clsql-exists-condition-new-db
+ :initform nil))
+ (:report (lambda (c stream)
+ (format stream "In call to ~S:~%" 'connect)
+ (cond
+ ((null (clsql-exists-condition-new-db c))
+ (format stream
+ " There is an existing connection ~A to database ~A."
+ (clsql-exists-condition-old-db c)
+ (database-name (clsql-exists-condition-old-db c))))
+ ((eq (clsql-exists-condition-new-db c)
+ (clsql-exists-condition-old-db c))
+ (format stream
+ " Using existing connection ~A to database ~A."
+ (clsql-exists-condition-old-db c)
+ (database-name (clsql-exists-condition-old-db c))))
+ (t
+ (format stream
+ " Created new connection ~A to database ~A~%, although there is an existing connection (~A)."
+ (clsql-exists-condition-new-db c)
+ (database-name (clsql-exists-condition-new-db c))
+ (clsql-exists-condition-old-db c)))))))
+
+(define-condition clsql-exists-warning (clsql-exists-condition
+ clsql-warning)
+ ())
+
+(define-condition clsql-exists-error (clsql-exists-condition
+ clsql-error)
+ ())
+
+(define-condition clsql-closed-error (clsql-error)
+ ((database :initarg :database :reader clsql-closed-error-database))
+ (:report (lambda (c stream)
+ (format stream "The database ~A has already been closed."
+ (clsql-closed-error-database c)))))
+
+(define-condition clsql-no-database-error (clsql-error)
+ ((database :initarg :database :reader clsql-no-database-error-database))
+ (:report (lambda (c stream)
+ (format stream "~S is not a CLSQL database."
+ (clsql-no-database-error-database c)))))
+
+(define-condition clsql-odbc-error (clsql-error)
+ ((odbc-message :initarg :odbc-message
+ :reader clsql-odbc-error-message)
+ (sql-state :initarg :sql-state :initform nil
+ :reader clsql-odbc-error-sql-state))
+ (:report (lambda (c stream)
+ (format stream "[ODBC error] ~A; state: ~A"
+ (clsql-odbc-error-message c)
+ (clsql-odbc-error-sql-state c)))))
+
+;; Signal conditions
+
+
+(defun signal-closed-database-error (database)
+ (cerror "Ignore this error and return nil."
+ 'clsql-closed-error
+ :database database))
+
+(defun signal-no-database-error (database)
+ (error 'clsql-no-database-error :database database))
+
+(define-condition clsql-type-error (clsql-error clsql-condition)
+ ((slotname :initarg :slotname
+ :reader clsql-type-error-slotname)
+ (typespec :initarg :typespec
+ :reader clsql-type-error-typespec)
+ (value :initarg :value
+ :reader clsql-type-error-value))
+ (:report (lambda (c stream)
+ (format stream
+ "Invalid value ~A in slot ~A, not of type ~A."
+ (clsql-type-error-value c)
+ (clsql-type-error-slotname c)
+ (clsql-type-error-typespec c)))))
+
+(define-condition clsql-sql-syntax-error (clsql-error)
+ ((reason :initarg :reason
+ :reader clsql-sql-syntax-error-reason))
+ (:report (lambda (c stream)
+ (format stream "Invalid SQL syntax: ~A"
+ (clsql-sql-syntax-error-reason c)))))
+
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;;
+;;;; $Id$
+;;;;
+;;;; Base database functions
+;;;;
+;;;; This file is part of CLSQL.
+;;;;
+;;;; 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)
+
+(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.")
+
+(defun is-database-open (database)
+ (eql (database-state database) :open))
+
+(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."
+
+ (unless database-type
+ (error "Must specify a database-type."))
+
+ (when (stringp connection-spec)
+ (setq connection-spec (string-to-list-connection-spec connection-spec)))
+
+ (unless (member database-type *loaded-database-types*)
+ (asdf:operate 'asdf:load-op (ensure-keyword
+ (concatenate 'string
+ (symbol-name '#:clsql-)
+ (symbol-name database-type)))))
+
+ (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
+ (setf (slot-value result 'state) :open)
+ (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*)))
+ (setf (slot-value database 'state) :closed)
+ 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."
+ (let ((db (etypecase database
+ (database database)
+ ((or string list)
+ (let ((db (find-database database :errorp nil)))
+ (when (null db)
+ (if (and database error)
+ (error 'clsql-generic-error
+ :message
+ (format nil "Unable to find database with connection-spec ~A." database))
+ (return-from reconnect nil)))
+ db)))))
+
+ (when (is-database-open db)
+ (if force
+ (ignore-errors (disconnect :database db))
+ (disconnect :database db :error nil)))
+
+ (connect (connection-spec db))))
+
+
+(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."
+ (flet ((get-data ()
+ (let ((data '()))
+ (dolist (db (connected-databases) data)
+ (push
+ (append
+ (list (if (equal db *default-database*) "*" "")
+ (database-name db)
+ (string-downcase (string (database-type db)))
+ (cond ((and (command-recording-stream db)
+ (result-recording-stream db))
+ "Both")
+ ((command-recording-stream db) "Commands")
+ ((result-recording-stream db) "Results")
+ (t "nil")))
+ (when full
+ (list
+ (if (conn-pool db) "t" "nil")
+ (format nil "~A" (length (database-list-tables db)))
+ (format nil "~A" (length (database-list-views db))))))
+ 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 #\-))))
+ (format t "~&CLSQL STATUS: ~A~%" (iso-timestring (get-time)))
+ (let ((data (get-data)))
+ (when data
+ (let* ((titles (if full
+ (list "" "DATABASE" "TYPE" "RECORDING" "POOLED"
+ "TABLES" "VIEWS")
+ (list "" "DATABASE" "TYPE" "RECORDING")))
+ (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)))
+
+(defun create-database (connection-spec &key database-type)
+ (when (stringp connection-spec)
+ (setq connection-spec (string-to-list-connection-spec connection-spec)))
+ (database-create connection-spec database-type))
+
+(defun probe-database (connection-spec &key database-type)
+ (when (stringp connection-spec)
+ (setq connection-spec (string-to-list-connection-spec connection-spec)))
+ (database-probe connection-spec database-type))
+
+(defun destroy-database (connection-spec &key database-type)
+ (when (stringp connection-spec)
+ (setq connection-spec (string-to-list-connection-spec connection-spec)))
+ (database-destroy connection-spec database-type))
+
+(defun list-databases (connection-spec &key database-type)
+ (when (stringp connection-spec)
+ (setq connection-spec (string-to-list-connection-spec connection-spec)))
+ (database-list connection-spec database-type))
+
+(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))
+
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; 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
+;;;; onShoreD to support UncommonSQL front-end
+;;;; Date Started: Feb 2002
+;;;;
+;;;; $Id$
+;;;;
+;;;; 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
+;;;; 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)
+
+(defgeneric database-type-load-foreign (database-type)
+ (:documentation
+ "The internal generic implementation of reload-database-types."))
+
+(defgeneric database-type-library-loaded (database-type)
+ (:documentation
+ "The internal generic implementation for checking if
+database type library loaded successfully."))
+
+(defgeneric database-initialize-database-type (database-type)
+ (:documentation
+ "The internal generic implementation of initialize-database-type."))
+
+(defgeneric database-name-from-spec (connection-spec database-type)
+ (:documentation
+ "Returns the name of the database that would be created if connect
+was called with the connection-spec."))
+
+(defgeneric database-connect (connection-spec database-type)
+ (:documentation "Internal generic implementation of connect."))
+
+(defgeneric database-reconnect (database)
+ (:method ((database t))
+ (signal-no-database-error database))
+ (:documentation "Internal generic implementation of reconnect."))
+
+(defgeneric database-disconnect (database)
+ (:method ((database t))
+ (signal-no-database-error database))
+ (:documentation "Internal generic implementation of disconnect."))
+
+(defgeneric database-query (query-expression database result-types field-names)
+ (:method (query-expression (database t) result-types field-names)
+ (declare (ignore query-expression result-types field-names))
+ (signal-no-database-error database))
+ (:documentation "Internal generic implementation of query."))
+
+
+(defgeneric database-execute-command (sql-expression database)
+ (:method (sql-expression (database t))
+ (declare (ignore sql-expression))
+ (signal-no-database-error database))
+ (:documentation "Internal generic implementation of execute-command."))
+
+;;; Mapping and iteration
+(defgeneric database-query-result-set
+ (query-expression database &key full-set result-types)
+ (:method (query-expression (database t) &key full-set result-types)
+ (declare (ignore query-expression full-set result-types))
+ (signal-no-database-error database)
+ (values nil nil nil))
+ (:documentation
+ "Internal generic implementation of query mapping. Starts the
+query specified by query-expression on the given database and returns
+a result-set to be used with database-store-next-row and
+database-dump-result-set to access the returned data. The second
+value is the number of columns in the result-set, if there are any.
+If full-set is true, the number of rows in the result-set is returned
+as a third value, if this is possible (otherwise nil is returned for
+the third value). This might have memory and resource usage
+implications, since many databases will require the query to be
+executed in full to answer this question. If the query produced no
+results then nil is returned for all values that would have been
+returned otherwise. If an error occurs during query execution, the
+function should signal a clsql-sql-error."))
+
+(defgeneric database-dump-result-set (result-set database)
+ (:method (result-set (database t))
+ (declare (ignore result-set))
+ (signal-no-database-error database))
+ (:documentation "Dumps the received result-set."))
+
+(defgeneric database-store-next-row (result-set database list)
+ (:method (result-set (database t) list)
+ (declare (ignore result-set list))
+ (signal-no-database-error database))
+ (:documentation
+ "Returns t and stores the next row in the result set in list or
+returns nil when result-set is finished."))
+
+(defgeneric database-create (connection-spec type)
+ (:documentation
+ "Creates a database, returns T if successfull or signals an error."))
+
+(defgeneric database-probe (connection-spec type)
+ (:method (spec type)
+ (declare (ignore spec))
+ (warn "database-proe not support for database-type ~A." type))
+ (:documentation
+ "Probes for the existence of a database, returns T if database found or NIL
+if not found. May signal an error if unable to communicate with database server."))
+
+(defgeneric database-list (connection-spec type)
+ (:method (spec type)
+ (declare (ignore spec))
+ (warn "database-list not support for database-type ~A." type))
+ (:documentation
+ "Lists all databases found for TYPE. May signal an error if unable to communicate with database server."))
+
+(defgeneric database-destroy (connection-spec database)
+ (:documentation "Destroys (drops) a database."))
+
+(defgeneric database-truncate (database)
+ (:method ((database t))
+ (signal-no-database-error database))
+ (:documentation "Remove all data from database."))
+
+(defgeneric database-describe-table (database table)
+ (:method ((database t) table)
+ (declare (ignore table))
+ (signal-no-database-error database))
+ (:documentation "Return a list of name/type for columns in table"))
+
+(defgeneric database-destory (connection-spec type)
+ (:documentation
+ "Destroys a database, returns T if successfull or signals an error
+if unable to destory."))
+
+(defgeneric database-create-sequence (name database)
+ (:documentation "Create a sequence in DATABASE."))
+
+(defgeneric database-drop-sequence (name database)
+ (:documentation "Drop a sequence from DATABASE."))
+
+(defgeneric database-sequence-next (name database)
+ (:documentation "Increment a sequence in DATABASE."))
+
+(defgeneric database-list-sequences (database &key owner)
+ (:documentation "List all sequences in DATABASE."))
+
+(defgeneric database-set-sequence-position (name position database)
+ (:documentation "Set the position of the sequence called NAME in DATABASE."))
+
+(defgeneric database-sequence-last (name database)
+ (:documentation "Select the last value in sequence NAME in DATABASE."))
+
+(defgeneric database-start-transaction (database)
+ (:documentation "Start a transaction in DATABASE."))
+
+(defgeneric database-commit-transaction (database)
+ (:documentation "Commit current transaction in DATABASE."))
+
+(defgeneric database-abort-transaction (database)
+ (:documentation "Abort current transaction in DATABASE."))
+
+(defgeneric database-get-type-specifier (type args database)
+ (:documentation "Return the type SQL type specifier as a string, for
+the given lisp type and parameters."))
+
+(defgeneric database-list-tables (database &key owner)
+ (:documentation "List all tables in the given database"))
+
+(defgeneric database-list-views (database &key owner)
+ (:documentation "List all views in the DATABASE."))
+
+(defgeneric database-list-indexes (database &key owner)
+ (:documentation "List all indexes in the DATABASE."))
+
+(defgeneric database-list-table-indexes (table database &key owner)
+ (:documentation "List all indexes for a table in the DATABASE."))
+
+(defgeneric database-list-attributes (table database &key owner)
+ (:documentation "List all attributes in TABLE."))
+
+(defgeneric database-attribute-type (attribute table database &key owner)
+ (:documentation "Return the type of ATTRIBUTE in TABLE. Returns multiple values
+of TYPE_NAME (keyword) PRECISION SCALE NULLABLE."))
+
+(defgeneric database-add-attribute (table attribute database)
+ (:documentation "Add the attribute to the table."))
+
+(defgeneric database-rename-attribute (table oldatt newname database)
+ (:documentation "Rename the attribute in the table to NEWNAME."))
+
+(defgeneric oid (object)
+ (:documentation "Return the unique ID of a database object."))
+
+;;; Database backend capabilities
+
+(defgeneric database-underlying-type (database)
+ (:method (database)
+ (database-type database))
+ (:documentation "Returns the type of the underlying database. For ODBC, needs to query ODBC driver."))
+
+(defgeneric db-type-use-column-on-drop-index? (db-type)
+ (:method (db-type)
+ (declare (ignore db-type))
+ nil)
+ (:documentation "NIL [default] if database-type does not use column name on DROP INDEX."))
+
+(defgeneric db-type-has-views? (db-type)
+ (:method (db-type)
+ (declare (ignore db-type))
+ ;; SQL92 has views
+ t)
+ (:documentation "T [default] if database-type supports views."))
+
+(defgeneric db-type-default-case (db-type)
+ (:method (db-type)
+ (declare (ignore db-type))
+ ;; By default, CommonSQL converts identifiers to UPPER case.
+ :upper)
+ (:documentation ":upper [default] if means identifiers mapped to UPPER case SQL like CommonSQL API. However, Postgresql maps identifiers to lower case, so PostgreSQL uses a value of :lower for this result."))
+
+(defgeneric db-type-has-fancy-math? (db-type)
+ (:method (db-type)
+ (declare (ignore db-type))
+ nil)
+ (:documentation "NIL [default] if database-type does not have fancy math."))
+
+(defgeneric db-type-has-subqueries? (db-type)
+ (:method (db-type)
+ (declare (ignore db-type))
+ t)
+ (:documentation "T [default] if database-type supports views."))
+
+(defgeneric db-type-has-boolean-where? (db-type)
+ (:method (db-type)
+ (declare (ignore db-type))
+ ;; SQL99 has boolean where
+ t)
+ (:documentation "T [default] if database-type supports boolean WHERE clause, such as 'WHERE MARRIED'."))
+
+(defgeneric db-backend-has-create/destroy-db? (db-type)
+ (:method (db-type)
+ (declare (ignore db-type))
+ t)
+ (:documentation "T [default] if backend can destroy and create databases."))
+
+(defgeneric db-type-transaction-capable? (db database)
+ (:method (db database)
+ (declare (ignore db database))
+ t)
+ (:documentation "T [default] if database can supports transactions."))
+
+;;; Large objects support (Marc Battyani)
+
+(defgeneric database-create-large-object (database)
+ (:documentation "Creates a new large object in the database and returns the object identifier"))
+
+(defgeneric database-write-large-object (object-id data database)
+ (:documentation "Writes data to the large object"))
+
+(defgeneric database-read-large-object (object-id database)
+ (:documentation "Reads the large object content"))
+
+(defgeneric database-delete-large-object (object-id database)
+ (:documentation "Deletes the large object in the database"))
+
+
+;; Checks for closed database
+
+(defmethod database-disconnect :before ((database database))
+ (unless (is-database-open database)
+ (signal-closed-database-error database)))
+
+(defmethod database-query :before (query-expression (database database)
+ result-set field-names)
+ (declare (ignore query-expression result-set field-names))
+ (unless (is-database-open database)
+ (signal-closed-database-error database)))
+
+(defmethod database-execute-command :before (sql-expression (database database))
+ (declare (ignore sql-expression))
+ (unless (is-database-open database)
+ (signal-closed-database-error database)))
+
+(defmethod database-query-result-set :before (expr (database database)
+ &key full-set result-types)
+ (declare (ignore expr full-set result-types))
+ (unless (is-database-open database)
+ (signal-closed-database-error database)))
+
+(defmethod database-dump-result-set :before (result-set (database database))
+ (declare (ignore result-set))
+ (unless (is-database-open database)
+ (signal-closed-database-error database)))
+
+(defmethod database-store-next-row :before (result-set (database database) list)
+ (declare (ignore result-set list))
+ (unless (is-database-open database)
+ (signal-closed-database-error database)))
+
+(defmethod database-commit-transaction :before ((database database))
+ (unless (is-database-open database)
+ (signal-closed-database-error database)))
+
+(defmethod database-start-transaction :before ((database database))
+ (unless (is-database-open database)
+ (signal-closed-database-error database)))
+
+(defmethod database-abort-transaction :before ((database database))
+ (unless (is-database-open database)
+ (signal-closed-database-error database)))
+
+(defgeneric describe-table (table &key database)
+ (:documentation "Describes a table, returns a list of name/type for columns in table"))
+
;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;; *************************************************************************
-(in-package #:clsql)
+(in-package #:clsql-sys)
(defgeneric update-record-from-slot (object slot &key database)
(:documentation
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; 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-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
+;;;; 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)
+
+(defvar *loaded-database-types* nil
+ "Contains a list of database types which have been defined/loaded.")
+
+(defmethod database-type-load-foreign (x)
+ (error "No generic function defined for database-type-load-foreign with parameters of ~S" x))
+
+(defmethod database-type-load-foreign :after (database-type)
+ (when (database-type-library-loaded database-type)
+ (pushnew database-type *loaded-database-types*)))
+
+(defun reload-database-types ()
+ "Reloads any foreign code for the loaded database types after a dump."
+ (mapc #'database-type-load-foreign *loaded-database-types*))
+
+(defvar *default-database-type* nil
+ "Specifies the default type of database.")
+
+(defvar *initialized-database-types* nil
+ "Contains a list of database types which have been initialized by calls
+to initialize-database-type.")
+
+(defun initialize-database-type (&key (database-type *default-database-type*))
+ "Initialize the given database-type, if it is not already
+initialized, as indicated by `*initialized-database-types*'."
+ (when (member database-type *initialized-database-types*)
+ (return-from initialize-database-type database-type))
+
+ (let ((system (intern (concatenate 'string
+ (symbol-name '#:clsql-)
+ (symbol-name database-type)))))
+ (when (not (find-package system))
+ (asdf:operate 'asdf:load-op system)))
+
+ (when (database-initialize-database-type database-type)
+ (push database-type *initialized-database-types*)
+ database-type))
+
;;;; This file was extracted from the KMRCL utilities
;;;; *************************************************************************
-(in-package #:clsql)
+(in-package #:clsql-sys)
#+lispworks
(defun intern-eql-specializer (slot)
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: loop-extension.lisp
+;;;; Purpose: Extensions to the Loop macro for CLSQL
+;;;;
+;;;; Copyright (c) 2001-2004 Kevin Rosenberg and (c) 1999-2001 Pierre R. Mai
+;;;;
+;;;; $Id$
+;;;; *************************************************************************
+
+(in-package #:cl-user)
+
+#+(or allegro sbcl)
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defpackage #:ansi-loop
+ (:import-from #+sbcl #:sb-loop #+allegro #:excl
+ #:loop-error
+ #:*loop-epilogue*
+ #:*loop-ansi-universe*
+ #:add-loop-path)))
+
+#+(or allegro sbcl)
+(defun ansi-loop::loop-gentemp (&optional (pref 'loopva-))
+ (gensym (string pref)))
+
+#+(or cmu scl sbcl openmcl allegro)
+(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 '(clsql-sys:*default-database*)))
+
+ (unless (consp variable)
+ (setq variable (list variable)))
+
+ (cond
+ ;; object query
+ ((and (consp (first in-phrase))
+ (string-equal "sql-query" (symbol-name (caar in-phrase)))
+ (consp (second (first in-phrase)))
+ (eq 'quote (first (second (first in-phrase))))
+ (symbolp (second (second (first in-phrase)))))
+
+ (let ((result-var (ansi-loop::loop-gentemp
+ 'loop-record-result-))
+ (step-var (ansi-loop::loop-gentemp 'loop-record-step-)))
+ `(((,variable nil ,@(and data-type (list data-type)))
+ (,result-var (clsql-sys:query ,(first in-phrase)))
+ (,step-var nil))
+ ()
+ ()
+ ()
+ (if (null ,result-var)
+ t
+ (progn
+ (setq ,step-var (first ,result-var))
+ (setq ,result-var (rest ,result-var))
+ nil))
+ (,variable ,step-var)
+ (null ,result-var)
+ ()
+ (if (null ,result-var)
+ t
+ (progn
+ (setq ,step-var (first ,result-var))
+ (setq ,result-var (rest ,result-var))
+ nil))
+ (,variable ,step-var))))
+
+ ((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
+ (clsql-sys:database-dump-result-set ,result-set-var ,db-var))
+ ansi-loop::*loop-epilogue*)
+ `(((,variable nil ,@(and data-type (list data-type)))
+ (,query-var ,(first in-phrase))
+ (,db-var ,(first from-phrase))
+ (,result-set-var nil)
+ (,step-var nil))
+ ((multiple-value-bind (%rs %cols)
+ (clsql-sys:database-query-result-set ,query-var ,db-var :result-types :auto)
+ (setq ,result-set-var %rs ,step-var (make-list %cols))))
+ ()
+ ()
+ (not (clsql-sys:database-store-next-row ,result-set-var ,db-var ,step-var))
+ (,variable ,step-var)
+ (not ,result-set-var)
+ ()
+ (not (clsql-sys:database-store-next-row ,result-set-var ,db-var ,step-var))
+ (,variable ,step-var)))))))
+
+#+(or cmu scl sbcl openmcl allegro)
+(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)
+
+#+lispworks
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (in-package loop))
+
+#+lispworks
+(cl-user::define-loop-method (record records tuple tuples) clsql-loop-method
+ (in of from))
+
+#+lispworks
+(defun clsql-loop-method (method-name iter-var iter-var-data-type
+ prep-phrases inclusive? allowed-preps
+ method-specific-data)
+ (declare (ignore method-name inclusive? allowed-preps method-specific-data))
+ (let ((in-phrase nil)
+ (from-phrase nil))
+ (loop for (prep . rest) in prep-phrases
+ do
+ (cond
+ ((or (eq prep 'in) (eq prep 'of))
+ (when in-phrase
+ (error
+ "Duplicate OF or IN iteration path: ~S." (cons prep rest)))
+ (setq in-phrase rest))
+ ((eq prep 'from)
+ (when from-phrase
+ (error
+ "Duplicate FROM iteration path: ~S." (cons prep rest)))
+ (setq from-phrase rest))
+ (t
+ (error
+ "Unknown preposition: ~S." prep))))
+ (unless in-phrase
+ (error "Missing OF or IN iteration path."))
+ (unless from-phrase
+ (setq from-phrase '(clsql:*default-database*)))
+
+ (unless (consp iter-var)
+ (setq iter-var (list iter-var)))
+
+ (cond
+ ;; object query
+ ((and (consp in-phrase)
+ (string-equal "sql-query" (symbol-name (car in-phrase)))
+ (consp (second in-phrase))
+ (eq 'quote (first (second in-phrase)))
+ (symbolp (second (second in-phrase))))
+
+ (let ((result-var (gensym "LOOP-RECORD-RESULT-"))
+ (step-var (gensym "LOOP-RECORD-STEP-")))
+ (values
+ t
+ nil
+ `(,@(mapcar (lambda (v) `(,v nil)) iter-var)
+ (,result-var (clsql:query ,in-phrase))
+ (,step-var nil))
+ ()
+ ()
+ ()
+ `((if (null ,result-var)
+ t
+ (progn
+ (setq ,step-var (first ,result-var))
+ (setq ,result-var (rest ,result-var))
+ nil)))
+ `(,iter-var ,step-var)
+ `((if (null ,result-var)
+ t
+ (progn
+ (setq ,step-var (first ,result-var))
+ (setq ,result-var (rest ,result-var))
+ nil)))
+ `(,iter-var ,step-var)
+ ()
+ ()
+ )))
+
+ ((consp iter-var)
+ (let ((query-var (gensym "LOOP-RECORD-"))
+ (db-var (gensym "LOOP-RECORD-DATABASE-"))
+ (result-set-var (gensym "LOOP-RECORD-RESULT-SET-"))
+ (step-var (gensym "LOOP-RECORD-STEP-")))
+ (values
+ t
+ nil
+ `(,@(mapcar (lambda (v) `(,v nil)) iter-var)
+ (,query-var ,in-phrase)
+ (,db-var ,(first from-phrase))
+ (,result-set-var nil)
+ (,step-var nil))
+ `((multiple-value-bind (%rs %cols)
+ (clsql-sys:database-query-result-set ,query-var ,db-var :result-types :auto)
+ (setq ,result-set-var %rs ,step-var (make-list %cols))))
+ ()
+ ()
+ `((unless (clsql-sys:database-store-next-row ,result-set-var ,db-var ,step-var)
+ (when ,result-set-var
+ (clsql-sys:database-dump-result-set ,result-set-var ,db-var))
+ t))
+ `(,iter-var ,step-var)
+ `((unless (clsql-sys:database-store-next-row ,result-set-var ,db-var ,step-var)
+ (when ,result-set-var
+ (clsql-sys:database-dump-result-set ,result-set-var ,db-var))
+ t))
+ `(,iter-var ,step-var)
+ ()
+ ()))))))
+
;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;; *************************************************************************
-(in-package #:clsql)
+(in-package #:clsql-sys)
(eval-when (:compile-toplevel :load-toplevel :execute)
(when (>= (length (generic-function-lambda-list
;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;; *************************************************************************
-(in-package #:clsql)
+(in-package #:clsql-sys)
(defclass standard-db-object ()
((view-database :initform nil :initarg :view-database :reader view-database
(defclass ,class ,supers ,slots
,@(if (find :metaclass `,cl-options :key #'car)
`,cl-options
- (cons '(:metaclass clsql::standard-db-class) `,cl-options)))
+ (cons '(:metaclass clsql-sys::standard-db-class) `,cl-options)))
(finalize-inheritance (find-class ',class))
(find-class ',class)))
(let ((qualifier (key-qualifier-for-instance instance :database vd)))
(delete-records :from vt :where qualifier :database vd)
(setf (slot-value instance 'view-database) nil))
- (error 'clsql-base::clsql-no-database-error :database nil))))
+ (error 'clsql-no-database-error :database nil))))
(defmethod update-instance-from-records ((instance standard-db-object)
&key (database *default-database*))
(defmethod database-get-type-specifier (type args database)
(declare (ignore type args))
- (if (clsql-base::in (database-underlying-type database)
+ (if (in (database-underlying-type database)
:postgresql :postgresql-socket)
"VARCHAR"
"VARCHAR(255)"))
database)
(if args
(format nil "VARCHAR(~A)" (car args))
- (if (clsql-base::in (database-underlying-type database)
+ (if (in (database-underlying-type database)
:postgresql :postgresql-socket)
"VARCHAR"
"VARCHAR(255)")))
database)
(if args
(format nil "VARCHAR(~A)" (car args))
- (if (clsql-base::in (database-underlying-type database)
+ (if (in (database-underlying-type database)
:postgresql :postgresql-socket)
"VARCHAR"
"VARCHAR(255)")))
(defmethod database-get-type-specifier ((type (eql 'string)) args database)
(if args
(format nil "VARCHAR(~A)" (car args))
- (if (clsql-base::in (database-underlying-type database)
+ (if (in (database-underlying-type database)
:postgresql :postgresql-socket)
"VARCHAR"
"VARCHAR(255)")))
(declare (ignore database))
(progv '(*print-circle* *print-array*) '(t t)
(let ((escaped (prin1-to-string val)))
- (clsql-base::substitute-char-string
+ (substitute-char-string
escaped #\Null " "))))
(defmethod database-output-sql-as-type ((type (eql 'symbol)) val database)
(defmethod read-sql-value (val (type (eql 'symbol)) database)
(declare (ignore database))
(when (< 0 (length val))
- (unless (string= val (clsql-base:symbol-name-default-case "NIL"))
- (intern (clsql-base:symbol-name-default-case val)
+ (unless (string= val (symbol-name-default-case "NIL"))
+ (intern (symbol-name-default-case val)
(symbol-package *update-context*)))))
(defmethod read-sql-value (val (type (eql 'integer)) database)
;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;; *************************************************************************
-(in-package #:clsql)
+(in-package #:clsql-sys)
;; Keep a hashtable for mapping symbols to sql generator functions,
;; for use by the bracketed reader syntax.
;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
;;;;
-;;;; $Id$
-;;;;
-;;;; Package definitions for CLSQL.
+;;;; Name: package.lisp
+;;;; Purpose: Package definition for SQL interface
;;;;
;;;; This file is part of CLSQL.
;;;;
(in-package #:cl-user)
-(eval-when (:compile-toplevel :load-toplevel :execute)
+;;;; This file makes the required package definitions for CLSQL's
+;;;; core packages.
-#+sbcl
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ #+sbcl
(if (find-package 'sb-mop)
(pushnew :clsql-sbcl-mop cl:*features*)
(pushnew :clsql-sbcl-pcl cl:*features*))
-
+
#+cmu
(if (eq (symbol-package 'pcl:find-class)
(find-package 'common-lisp))
(eval-when (:compile-toplevel :load-toplevel :execute)
- (defpackage #:clsql
- (:use #:common-lisp #:clsql-base
+ (defpackage #:clsql-sys
+ (:use #:common-lisp
#+clsql-sbcl-mop #:sb-mop
#+clsql-cmucl-mop #:mop
#+allegro #:mop
#+allegro
(:shadowing-import-from
#:excl)
- #+lispworks
- (:shadowing-import-from
- #:clos)
- #+clsql-sbcl-mop
- (:shadowing-import-from
- #:sb-pcl
- #:generic-function-lambda-list)
- #+clsql-sbcl-pcl
- (:shadowing-import-from
- #:sb-pcl
- #:name
- #:class-direct-slots
- #:class-of #:class-name #:class-slots #:find-class
- #:slot-boundp
- #:standard-class
- #:slot-definition-name #:finalize-inheritance
- #:standard-direct-slot-definition
- #:standard-effective-slot-definition #:validate-superclass
- #:direct-slot-definition-class #:compute-effective-slot-definition
- #:effective-slot-definition-class
- #:slot-value-using-class
- #:class-prototype #:generic-function-method-class #:intern-eql-specializer
- #:make-method-lambda #:generic-function-lambda-list
- #:class-precedence-list #:slot-definition-type
- #:class-direct-superclasses
- #:compute-class-precedence-list)
- #+clsql-cmucl-mop
- (:shadowing-import-from
- #:pcl
- #:generic-function-lambda-list)
- #+clsql-cmucl-pcl
- (:shadowing-import-from
- #:pcl
- #:class-direct-slots
- #:name
- #:class-of #:class-name #:class-slots #:find-class #:standard-class
- #:slot-boundp
- #:slot-definition-name #:finalize-inheritance
- #:standard-direct-slot-definition #:standard-effective-slot-definition
- #:validate-superclass #:direct-slot-definition-class
- #:effective-slot-definition-class
- #:compute-effective-slot-definition
- #:slot-value-using-class
- #:class-prototype #:generic-function-method-class #:intern-eql-specializer
- #:make-method-lambda #:generic-function-lambda-list
- #:class-precedence-list #:slot-definition-type
- #:class-direct-superclasses
- #:compute-class-precedence-list)
- #+scl
- (:shadowing-import-from
- #:clos
- #:class-prototype ;; note: make-method-lambda is not fbound
- )
-
- (:import-from
- #:clsql-base
- .
- #1=(
- ;; 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-access-error
- #:clsql-access-error-database-type
- #:clsql-access-error-connection-spec
- #:clsql-access-error-error
- #:clsql-connect-error
- #:clsql-connect-error-errno
- #: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
- #:*backend-warning-behavior*
-
- ;; 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-table-indexes
- #:database-list-sequences
- #:database-list-attributes
- #:database-attribute-type
- #:database-add-attribute
- #:database-type
-
- ;; initialize
- #:*loaded-database-types*
- #:reload-database-types
- #:*initialized-database-types*
- #:initialize-database-type
- ;; classes
- #:database
- #:database-name
- #:command-recording-stream
- #:result-recording-stream
- #:database-view-classes
- #:conn-pool
- #:print-object
-
- ;; utils
- #:sql-escape
+ #+lispworks
+ (:shadowing-import-from
+ #:clos)
+ #+clsql-sbcl-mop
+ (:shadowing-import-from
+ #:sb-pcl
+ #:generic-function-lambda-list)
+ #+clsql-sbcl-pcl
+ (:shadowing-import-from
+ #:sb-pcl
+ #:name
+ #:class-direct-slots
+ #:class-of #:class-name #:class-slots #:find-class
+ #:slot-boundp
+ #:standard-class
+ #:slot-definition-name #:finalize-inheritance
+ #:standard-direct-slot-definition
+ #:standard-effective-slot-definition #:validate-superclass
+ #:direct-slot-definition-class #:compute-effective-slot-definition
+ #:effective-slot-definition-class
+ #:slot-value-using-class
+ #:class-prototype #:generic-function-method-class #:intern-eql-specializer
+ #:make-method-lambda #:generic-function-lambda-list
+ #:class-precedence-list #:slot-definition-type
+ #:class-direct-superclasses
+ #:compute-class-precedence-list)
+ #+clsql-cmucl-mop
+ (:shadowing-import-from
+ #:pcl
+ #:generic-function-lambda-list)
+ #+clsql-cmucl-pcl
+ (:shadowing-import-from
+ #:pcl
+ #:class-direct-slots
+ #:name
+ #:class-of #:class-name #:class-slots #:find-class #:standard-class
+ #:slot-boundp
+ #:slot-definition-name #:finalize-inheritance
+ #:standard-direct-slot-definition #:standard-effective-slot-definition
+ #:validate-superclass #:direct-slot-definition-class
+ #:effective-slot-definition-class
+ #:compute-effective-slot-definition
+ #:slot-value-using-class
+ #:class-prototype #:generic-function-method-class #:intern-eql-specializer
+ #:make-method-lambda #:generic-function-lambda-list
+ #:class-precedence-list #:slot-definition-type
+ #:class-direct-superclasses
+ #:compute-class-precedence-list)
+ #+scl
+ (:shadowing-import-from
+ #:clos
+ #:class-prototype ;; note: make-method-lambda is not fbound
+ )
+
+ (: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-disconnect
+ #: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-list-table-indexes
+ #:database-index-exists-p
+ #:database-list-sequences
+ #:database-sequence-exists-p
+ #:database-list-attributes
+ #:database-attribute-type
+ #:database-describe-table
+ #:database-type-library-loaded
+
+ #:db-backend-has-create/destroy-db?
+ #:db-type-has-views?
+ #:db-type-has-subqueries?
+ #:db-type-has-boolean-where?
+ #:db-type-transaction-capable?
+ #:db-type-has-fancy-math?
+ #:db-type-default-case
+ #:db-type-use-column-on-drop-index?
+ #:database-underlying-type
- ;; database.lisp -- Connection
- #:*default-database-type* ; database xx
- #:*default-database* ; database 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 xx
- #:find-database ; database xx
- #:status ; database xx
- #:with-database
- #:with-default-database
- #:create-database
- #:destroy-database
- #:probe-database
-
- ;; pool.lisp
- #:disconnect-pooled
+ ;; Large objects
+ #:database-create-large-object
+ #:database-write-large-object
+ #:database-read-large-object
+ #:database-delete-large-object
+ #:create-large-object
+ #:write-large-object
+ #:read-large-object
+ #:delete-large-object
- ;; basic-sql.lisp
- #:query
- #:execute-command
- #:write-large-object
- #:read-large-object
- #:delete-large-object
- #:describe-table
- #:create-large-object
- #:write-large-object
- #:read-large-object
- #:delete-large-object
+ ;; accessors for database class
+ #:name
+ #:connection-spec
+ #:transaction
+ #:transaction-level
+ #:conn-pool
+ #:command-recording-stream
+ #:result-recording-stream
+ #:record-caches
+ #:view-classes
+ #:database-type
+ #:database-state
+ #:attribute-cache
+
-
- ;; recording.lisp -- SQL I/O Recording
- #:record-sql-command
- #: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
-
- ;; 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
-
- ;; Database capabilities
- #:db-type-use-column-on-drop-index?
- #:db-backend-has-create/destroy-db?
- #:db-type-has-views?
- #:db-type-has-subqueries?
- #:db-type-has-boolean-where?
- #:db-type-transaction-capable?
- #:db-type-has-fancy-math?
- #:db-type-default-case
- #:convert-to-db-default-case
- #:database-underlying-type
+ ;; utils.lisp
+ #:without-interrupts
+ #:make-process-lock
+ #:with-process-lock
+ #:command-output
+ #:symbol-name-default-case
+ #:convert-to-db-default-case
+ #:ensure-keyword
- ;; 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
- #:duration-timestring
- #:extract-roman
- #:format-duration
- #:format-time
- #:get-time
- #:utime->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
- #:parse-yearstring
- #: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
- #:gregorian-to-mjd
- #:mjd-to-gregorian
- ))
- (: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-list-table-indexes
- #:database-index-exists-p
- #:database-list-sequences
- #:database-sequence-exists-p
- #:database-list-attributes
- #:database-attribute-type
- #:database-describe-table
+
+ #:clsql-invalid-spec-error
+ #:clsql-invalid-spec-error-connection-spec
+ #:clsql-invalid-spec-error-database-type
+ #:clsql-invalid-spec-error-template
+ #:clsql-access-error
+ #:clsql-access-error-database-type
+ #:clsql-access-error-connection-spec
+ #:clsql-access-error-error
+ #:clsql-connect-error
+ #:clsql-connect-error-errno
+ #: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-sql-syntax-error
+ #:clsql-type-error
+ #:clsql-odbc-error
+ #:clsql-odbc-error-message
+
+ #:*loaded-database-types*
+ #:reload-database-types
+ #:*initialized-database-types*
+ #:initialize-database-type
+ #:*connect-if-exists*
+ #:*default-database*
+ #:connected-databases
+ #:database
+ #:find-database
+ #:is-database-open
+ #:database-type ; database x
- #:db-backend-has-create/destroy-db?
- #:db-type-has-views?
- #:db-type-has-subqueries?
- #:db-type-has-boolean-where?
- #:db-type-transaction-capable?
- #:db-type-has-fancy-math?
- #:db-type-default-case
- #:database-underlying-type
-
- .
- ;; Shared exports for re-export by CLSQL-USER.
- ;; I = Implemented, D = Documented
- ;; name file ID
- ;;====================================================
- #2=(;;------------------------------------------------
- ;; CommonSQL API
- ;;------------------------------------------------
- ;;FDML
+ ;; utils.lisp
+ #:number-to-sql-string
+ #:float-to-sql-string
+ #:sql-escape-quotes
+ #:in
+
+ .
+ ;; Shared exports for re-export by CLSQL package.
+ ;; I = Implemented, D = Documented
+ ;; name file ID
+ ;;====================================================
+ #1=(;;------------------------------------------------
+ ;; CommonSQL API
+ ;;------------------------------------------------
+ ;;FDML
#:select ; objects xx
#:cache-table-queries ;
#:*cache-table-queries-default* ;
#:print-query ; sql xx
#:do-query ; sql xx
#:map-query ; sql xx
- #:loop ; loop-ext x
+ #:for-each-row
+ #:loop
+
;;FDDL
#:create-table ; table xx
#:drop-table ; table 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
- #:database-type ; database x
- #:is-database-open
;;FDDL
#:list-views ; table xx
#:view-exists-p ; table xx
#:database-get-type-specifier ; objects x
#:database-output-sql ; sql/class xx
+ ;; conditions
+ #:clsql-condition
+ #:clsql-error
+ #:clsql-simple-error
+ #:clsql-warning
+ #:clsql-simple-warning
+
;;-----------------------------------------------
;; Symbolic Sql Syntax
;;-----------------------------------------------
#:sql-view-class
#:sql_slot-value
- #:do-query
- #:map-query
- .
- #1#
+
+ ;; 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
+ #:duration-timestring
+ #:extract-roman
+ #:format-duration
+ #:format-time
+ #:get-time
+ #:utime->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
+ #:parse-yearstring
+ #: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
+ #:gregorian-to-mjd
+ #:mjd-to-gregorian
+
+ ;; recording.lisp -- SQL I/O Recording
+ #:record-sql-command
+ #: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
+ #:disconnect-pooled
+ #:create-database
+ #:destroy-database
+ #:probe-database
+ #:list-databases
+
+ #:describe-table
+ #:*backend-warning-behavior*
+
+ ;; 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."))
-;; 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
+ (:use #:common-lisp)
+ (:import-from #:clsql-sys . #1#)
+ (:export . #1#)
+ (:documentation "This is the user package with CLSQL symbols."))
(defpackage #:clsql-user
(:use #:common-lisp)
- (:import-from #:clsql . #2#)
- (:export . #2#)
+ (:import-from #:clsql-sys . #1#)
+ (:export . #1#)
(:documentation "This is the user package with CLSQL symbols."))
;; This is from USQL's pcl-patch
slot-vars pv-parameters))
,@(mapcar #'(lambda (slot-var) `(declare (ignorable ,slot-var))) slot-vars)
,@body))))
-
-
+
+;; 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=))
+
#+sbcl
(if (find-package 'sb-mop)
(setq cl:*features* (delete :clsql-sbcl-mop cl:*features*))
(if (find-package 'mop)
(setq cl:*features* (delete :clsql-cmucl-mop cl:*features*))
(setq cl:*features* (delete :clsql-cmucl-pcl cl:*features*)))
-
-);eval-when
+) ;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$
+;;;;
+;;;; 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)
+
+(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 pool-database-type :initarg :pool-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 (pool-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
+ :pool-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$
+;;;;
+;;;; CLSQL broadcast streams which can be used to monitor the
+;;;; flow of commands to, and results from, a database.
+;;;;
+;;;; This file is part of CLSQL.
+;;;;
+;;;; 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 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)))))
+
+
+
;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;; *************************************************************************
-(in-package #:clsql)
+(in-package #:clsql-sys)
;;; Basic operations on databases
(defun truncate-database (&key (database *default-database*))
(unless (typep database 'database)
- (clsql-base::signal-no-database-error database))
+ (signal-no-database-error database))
(unless (is-database-open database)
(database-reconnect database))
(when (db-type-has-views? (database-underlying-type database))
(setf (aref result index)
(apply function row))))
(database-dump-result-set result-set database)))))
+
+;;; Row processing macro from CLSQL
+
+(defmacro for-each-row (((&rest fields) &key from order-by where distinct limit) &body body)
+ (let ((d (gensym "DISTINCT-"))
+ (bind-fields (loop for f in fields collect (car f)))
+ (w (gensym "WHERE-"))
+ (o (gensym "ORDER-BY-"))
+ (frm (gensym "FROM-"))
+ (l (gensym "LIMIT-"))
+ (q (gensym "QUERY-")))
+ `(let ((,frm ,from)
+ (,w ,where)
+ (,d ,distinct)
+ (,l ,limit)
+ (,o ,order-by))
+ (let ((,q (query-string ',fields ,frm ,w ,d ,o ,l)))
+ (loop for tuple in (query ,q)
+ collect (destructuring-bind ,bind-fields tuple
+ ,@body))))))
+
+(defun query-string (fields from where distinct order-by limit)
+ (concatenate
+ 'string
+ (format nil "select ~A~{~A~^,~} from ~{~A~^ and ~}"
+ (if distinct "distinct " "") (field-names fields)
+ (from-names from))
+ (if where (format nil " where ~{~A~^ ~}"
+ (where-strings where)) "")
+ (if order-by (format nil " order by ~{~A~^, ~}"
+ (order-by-strings order-by)))
+ (if limit (format nil " limit ~D" limit) "")))
+
+(defun lisp->sql-name (field)
+ (typecase field
+ (string field)
+ (symbol (string-upcase (symbol-name field)))
+ (cons (cadr field))
+ (t (format nil "~A" field))))
+
+(defun field-names (field-forms)
+ "Return a list of field name strings from a fields form"
+ (loop for field-form in field-forms
+ collect
+ (lisp->sql-name
+ (if (cadr field-form)
+ (cadr field-form)
+ (car field-form)))))
+
+(defun from-names (from)
+ "Return a list of field name strings from a fields form"
+ (loop for table in (if (atom from) (list from) from)
+ collect (lisp->sql-name table)))
+
+
+(defun where-strings (where)
+ (loop for w in (if (atom (car where)) (list where) where)
+ collect
+ (if (consp w)
+ (format nil "~A ~A ~A" (second w) (first w) (third w))
+ (format nil "~A" w))))
+
+(defun order-by-strings (order-by)
+ (loop for o in order-by
+ collect
+ (if (atom o)
+ (lisp->sql-name o)
+ (format nil "~A ~A" (lisp->sql-name (car o))
+ (lisp->sql-name (cadr o))))))
+
+
+
;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;; *************************************************************************
-(in-package #:clsql)
+(in-package #:clsql-sys)
(defvar *original-reader-enter* nil)
;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;; *************************************************************************
-(in-package #:clsql)
+(in-package #:clsql-sys)
;; Utilities
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;;
+;;;; $Id$
+;;;;
+;;;; A variety of structures and function for creating and
+;;;; manipulating dates, times, durations and intervals for
+;;;; CLSQL.
+;;;;
+;;;; This file was originally part of ODCL and is Copyright (c) 2002 -
+;;;; 2003 onShore Development, Inc.
+;;;;
+;;;; 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)
+
+;; ------------------------------------------------------------
+;; 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
+
+(defun duration-timestring (duration)
+ (let ((second (duration-second duration))
+ (minute (duration-minute duration))
+ (hour (duration-hour duration))
+ (day (duration-day duration)))
+ (format nil "P~dD~dH~dM~dS" day hour minute second)))
+
+
+;; ------------------------------------------------------------
+;; 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 utime->time (utime)
+ "Return a pair: (GREGORIAN DAY . TIME-OF-DAY)"
+ (multiple-value-bind (second minute hour day mon year)
+ (decode-universal-time utime)
+ (make-time :year year :month mon :day day :hour hour :minute minute
+ :second second)))
+
+(defun get-time ()
+ "Return a pair: (GREGORIAN DAY . TIME-OF-DAY)"
+ (utime->time (get-universal-time)))
+
+(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 (month day year)
+ (mjd-to-gregorian (time-mjd time))
+ (values year month 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 &optional round)
+ (ecase precision
+ (:second
+ (+ (duration-second duration)
+ (* (duration-reduce duration :minute) 60)))
+ (:minute
+ (+ (if round
+ (floor (duration-second duration) 30)
+ 0)
+ (duration-minute duration)
+ (* (duration-reduce duration :hour) 60)))
+ (:hour
+ (+ (if round
+ (floor (duration-minute duration) 30)
+ 0)
+ (duration-hour duration)
+ (* (duration-reduce duration :day) 24)))
+ (:day
+ (+ (if round
+ (floor (duration-hour duration) 12)
+ 0)
+ (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) (setf 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) (setf 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)
+ (name 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!
+ (let ((list (sort-interval-list list)))
+ (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))))))
+
+(defun interval-clear (list time)
+ (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"
+ (let ((*print-circle* nil))
+ (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-month ()
+ (second (mjd-to-gregorian (time-mjd (get-time)))))
+
+(defun current-day ()
+ (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"))))
+
+(defgeneric to-string (val &rest keys)
+ )
+
+(defmethod to-string ((time wall-time) &rest keys)
+ (destructuring-bind (&key (style :daytime) &allow-other-keys)
+ keys
+ (print-date time style)))
+
+(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)
+ (setf doy (- doy (floor (+ 23 (* 4 month)) 10)))
+ (when (leap-year? year)
+ (incf doy)))
+ doy))
+
+(defun parse-yearstring (string)
+ (let ((year (or (parse-integer-insensitively string)
+ (extract-roman string))))
+ (when (and year (< 1500 year 2500))
+ (make-time :year year))))
+
+(defun parse-integer-insensitively (string)
+ (let ((start (position-if #'digit-char-p string))
+ (end (position-if #'digit-char-p string :from-end t)))
+ (when (and start end)
+ (parse-integer (subseq string start (1+ end)) :junk-allowed t))))
+
+(defvar *roman-digits*
+ '((#\M . 1000)
+ (#\D . 500)
+ (#\C . 100)
+ (#\L . 50)
+ (#\X . 10)
+ (#\V . 5)
+ (#\I . 1)))
+
+(defun extract-roman (string &aux parse)
+ (dotimes (x (length string))
+ (let ((val (cdr (assoc (aref string x) *roman-digits*))))
+ (when (and val parse (< (car parse) val))
+ (push (- (pop parse)) parse))
+ (push val parse)))
+ (apply #'+ parse))
+
+
+;; ------------------------------------------------------------
+;; 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))))
+ (setf 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$
+;;;;
+;;;; Transaction support
+;;;;
+;;;; This file is part of CLSQL.
+;;;;
+;;;; 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)
+
+(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)
+ (unless database (error 'clsql-no-database-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)
+ (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)
+ (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)))
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; 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-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 #:clsql-sys)
+
+(defun number-to-sql-string (num)
+ (etypecase num
+ (integer
+ num)
+ (rational
+ (float-to-sql-string (coerce num 'double-float)))
+ (number
+ (float-to-sql-string num))))
+
+(defun float-to-sql-string (num)
+ "Convert exponent character for SQL"
+ (let ((str (write-to-string num :readably t)))
+ (cond
+ ((find #\f str)
+ (substitute #\e #\f str))
+ ((find #\d str)
+ (substitute #\e #\d str))
+ ((find #\l str)
+ (substitute #\e #\l str))
+ ((find #\s str)
+ (substitute #\e #\S str))
+ ((find #\F str)
+ (substitute #\e #\F str))
+ ((find #\D str)
+ (substitute #\e #\D str))
+ ((find #\L str)
+ (substitute #\e #\L str))
+ ((find #\S str)
+ (substitute #\e #\S str))
+ (t
+ str))))
+
+(defun sql-escape (identifier)
+ "Change hyphens to underscores, ensure string"
+ (let* ((unescaped (etypecase identifier
+ (symbol (symbol-name identifier))
+ (string identifier)))
+ (escaped (make-string (length unescaped))))
+ (dotimes (i (length unescaped))
+ (setf (char escaped i)
+ (cond ((equal (char unescaped i) #\-)
+ #\_)
+ ;; ...
+ (t
+ (char unescaped i)))))
+ escaped))
+
+(defmacro without-interrupts (&body body)
+ #+lispworks `(mp:without-preemption ,@body)
+ #+allegro `(mp:without-scheduling ,@body)
+ #+cmu `(system:without-interrupts ,@body)
+ #+sbcl `(sb-sys::without-interrupts ,@body)
+ #+openmcl `(ccl:without-interrupts ,@body))
+
+(defun make-process-lock (name)
+ #+allegro (mp:make-process-lock :name name)
+ #+cmu (mp:make-lock name)
+ #+lispworks (mp:make-lock :name name)
+ #+openmcl (ccl:make-lock name)
+ #+sb-thread (sb-thread:make-mutex :name name)
+ #+scl (thread:make-lock name)
+ #-(or allegro cmu lispworks openmcl sb-thread scl) (declare (ignore name))
+ #-(or allegro cmu lispworks openmcl sb-thread scl) nil)
+
+(defmacro with-process-lock ((lock desc) &body body)
+ #+(or cmu allegro lispworks openmcl sb-thread)
+ (declare (ignore desc))
+ #+(or allegro cmu lispworks openmcl sb-thread)
+ (let ((l (gensym)))
+ `(let ((,l ,lock))
+ #+allegro (mp:with-process-lock (,l) ,@body)
+ #+cmu (mp:with-lock-held (,l) ,@body)
+ #+openmcl (ccl:with-lock-grabbed (,l) ,@body)
+ #+lispworks (mp:with-lock (,l) ,@body)
+ #+sb-thread (sb-thread:with-recursive-lock (,l) ,@body)
+ ))
+ #+scl `(thread:with-lock-held (,lock ,desc) ,@body)
+ #-(or cmu allegro lispworks openmcl sb-thread scl) (declare
+ (ignore lock desc))
+ #-(or cmu allegro lispworks openmcl sb-thread scl) `(progn ,@body))
+
+(defun sql-escape-quotes (s)
+ "Escape quotes for SQL string writing"
+ (substitute-string-for-char s #\' "''"))
+
+(defun substitute-string-for-char (procstr match-char subst-str)
+"Substitutes a string for a single matching character of a string"
+ (let ((pos (position match-char procstr)))
+ (if pos
+ (concatenate 'string
+ (subseq procstr 0 pos) subst-str
+ (substitute-string-for-char
+ (subseq procstr (1+ pos)) match-char subst-str))
+ procstr)))
+
+
+(defun position-char (char string start max)
+ "From KMRCL."
+ (declare (optimize (speed 3) (safety 0) (space 0))
+ (fixnum start max) (simple-string string))
+ (do* ((i start (1+ i)))
+ ((= i max) nil)
+ (declare (fixnum i))
+ (when (char= char (schar string i)) (return i))))
+
+(defun delimited-string-to-list (string &optional (separator #\space)
+ skip-terminal)
+ "Split a string with delimiter, from KMRCL."
+ (declare (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0))
+ (type string string)
+ (type character separator))
+ (do* ((len (length string))
+ (output '())
+ (pos 0)
+ (end (position-char separator string pos len)
+ (position-char separator string pos len)))
+ ((null end)
+ (if (< pos len)
+ (push (subseq string pos) output)
+ (when (or (not skip-terminal) (zerop len))
+ (push "" output)))
+ (nreverse output))
+ (declare (type fixnum pos len)
+ (type (or null fixnum) end))
+ (push (subseq string pos end) output)
+ (setq pos (1+ end))))
+
+(defun string-to-list-connection-spec (str)
+ (let ((at-pos (position-char #\@ str 0 (length str))))
+ (cond
+ ((and at-pos (> (length str) at-pos))
+ ;; Connection spec is SQL*NET format
+ (cons (subseq str (1+ at-pos))
+ (delimited-string-to-list (subseq str 0 at-pos) #\/)))
+ (t
+ (delimited-string-to-list str #\/)))))
+
+#+allegro
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (unless (find-package '#:excl.osi)
+ (require 'osi)))
+
+(defun command-output (control-string &rest args)
+ ;; Concatenates output and error since Lispworks combines
+ ;; these, thus CLSQL can't depend upon separate results
+ (multiple-value-bind (output error status)
+ (apply #'%command-output control-string args)
+ (values
+ (concatenate 'string (if output output "")
+ (if error error ""))
+ status)))
+
+(defun read-stream-to-string (in)
+ (with-output-to-string (out)
+ (let ((eof (gensym)))
+ (do ((line (read-line in nil eof)
+ (read-line in nil eof)))
+ ((eq line eof))
+ (format out "~A~%" line)))))
+
+;; From KMRCL
+(defun %command-output (control-string &rest args)
+ "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
+synchronously execute the result using a Bourne-compatible shell,
+returns (VALUES string-output error-output exit-status)"
+ (let ((command (apply #'format nil control-string args)))
+ #+sbcl
+ (let* ((process (sb-ext:run-program
+ "/bin/sh"
+ (list "-c" command)
+ :input nil :output :stream :error :stream))
+ (output (read-stream-to-string (sb-impl::process-output process)))
+ (error (read-stream-to-string (sb-impl::process-error process))))
+ (close (sb-impl::process-output process))
+ (close (sb-impl::process-error process))
+ (values
+ output
+ error
+ (sb-impl::process-exit-code process)))
+
+
+ #+(or cmu scl)
+ (let* ((process (ext:run-program
+ "/bin/sh"
+ (list "-c" command)
+ :input nil :output :stream :error :stream))
+ (output (read-stream-to-string (ext::process-output process)))
+ (error (read-stream-to-string (ext::process-error process))))
+ (close (ext::process-output process))
+ (close (ext::process-error process))
+
+ (values
+ output
+ error
+ (ext::process-exit-code process)))
+
+ #+allegro
+ (multiple-value-bind (output error status)
+ (excl.osi:command-output command :whole t)
+ (values output error status))
+
+ #+lispworks
+ ;; BUG: Lispworks combines output and error streams
+ (let ((output (make-string-output-stream)))
+ (unwind-protect
+ (let ((status
+ (system:call-system-showing-output
+ command
+ :shell-type "/bin/sh"
+ :output-stream output)))
+ (values (get-output-stream-string output) nil status))
+ (close output)))
+
+ #+clisp
+ ;; BUG: CLisp doesn't allow output to user-specified stream
+ (values
+ nil
+ nil
+ (ext:run-shell-command command :output :terminal :wait t))
+
+ #+openmcl
+ (let* ((process (ccl:run-program
+ "/bin/sh"
+ (list "-c" command)
+ :input nil :output :stream :error :stream
+ :wait t))
+ (output (read-stream-to-string (ccl::external-process-output-stream process)))
+ (error (read-stream-to-string (ccl::external-process-error-stream process))))
+ (close (ccl::external-process-output-stream process))
+ (close (ccl::external-process-error-stream process))
+ (values output
+ error
+ (nth-value 1 (ccl::external-process-status process))))
+
+ #-(or openmcl clisp lispworks allegro scl cmu sbcl)
+ (error "COMMAND-OUTPUT not implemented for this Lisp")
+
+ ))
+
+
+;; From KMRCL
+(defmacro in (obj &rest choices)
+ (let ((insym (gensym)))
+ `(let ((,insym ,obj))
+ (or ,@(mapcar #'(lambda (c) `(eql ,insym ,c))
+ choices)))))
+
+;; From KMRCL
+(defun substitute-char-string (procstr match-char subst-str)
+ "Substitutes a string for a single matching character of a string"
+ (substitute-chars-strings procstr (list (cons match-char subst-str))))
+
+(defun replaced-string-length (str repl-alist)
+ (declare (simple-string str)
+ (optimize (speed 3) (safety 0) (space 0)))
+ (do* ((i 0 (1+ i))
+ (orig-len (length str))
+ (new-len orig-len))
+ ((= i orig-len) new-len)
+ (declare (fixnum i orig-len new-len))
+ (let* ((c (char str i))
+ (match (assoc c repl-alist :test #'char=)))
+ (declare (character c))
+ (when match
+ (incf new-len (1- (length
+ (the simple-string (cdr match)))))))))
+
+
+(defun substitute-chars-strings (str repl-alist)
+ "Replace all instances of a chars with a string. repl-alist is an assoc
+list of characters and replacement strings."
+ (declare (simple-string str)
+ (optimize (speed 3) (safety 0) (space 0)))
+ (do* ((orig-len (length str))
+ (new-string (make-string (replaced-string-length str repl-alist)))
+ (spos 0 (1+ spos))
+ (dpos 0))
+ ((>= spos orig-len)
+ new-string)
+ (declare (fixnum spos dpos) (simple-string new-string))
+ (let* ((c (char str spos))
+ (match (assoc c repl-alist :test #'char=)))
+ (declare (character c))
+ (if match
+ (let* ((subst (cdr match))
+ (len (length subst)))
+ (declare (fixnum len)
+ (simple-string subst))
+ (dotimes (j len)
+ (declare (fixnum j))
+ (setf (char new-string dpos) (char subst j))
+ (incf dpos)))
+ (progn
+ (setf (char new-string dpos) c)
+ (incf dpos))))))
+
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (when (char= #\a (schar (symbol-name '#:a) 0))
+ (pushnew :lowercase-reader *features*)))
+
+(defun symbol-name-default-case (str)
+ #-lowercase-reader
+ (string-upcase str)
+ #+lowercase-reader
+ (string-downcase str))
+
+(defun convert-to-db-default-case (str database)
+ (if database
+ (case (db-type-default-case (database-underlying-type database))
+ (:upper (string-upcase str))
+ (:lower (string-downcase str))
+ (t str))
+ ;; Default CommonSQL behavior is to upcase strings
+ (string-upcase str)))
+
+
+(defun ensure-keyword (name)
+ "Returns keyword for a name"
+ (etypecase name
+ (keyword name)
+ (string (nth-value 0 (intern (symbol-name-default-case name) :keyword)))
+ (symbol (nth-value 0 (intern (symbol-name name) :keyword)))))
(mapcar #'(lambda (ea) (slot-value ea 'address)) (select 'employee-address :flatp t))))
(format *report-stream* "~&~%*** JOINED OBJECT QUERY RETRIEVAL DEFERRED ***~%")
- (let* ((slotdef (find 'address (clsql::class-slots (find-class 'employee-address))
- :key #'clsql::slot-definition-name))
- (dbi (when slotdef (clsql::view-class-slot-db-info slotdef))))
+ (let* ((slotdef (find 'address (clsql-sys::class-slots (find-class 'employee-address))
+ :key #'clsql-sys::slot-definition-name))
+ (dbi (when slotdef (clsql-sys::view-class-slot-db-info slotdef))))
(setf (gethash :retrieval dbi) :deferred)
(time
(dotimes (i (truncate n 10))
;;;; FILE IDENTIFICATION
;;;;
;;;; Name: test-basic.lisp
-;;;; Purpose: Tests for clsql-base and result types
+;;;; Purpose: Tests for clsql string-based queries and result types
;;;; Author: Kevin M. Rosenberg
;;;; Created: Mar 2002
;;;;
(clsql:execute-command
(format nil "INSERT INTO TYPE_TABLE VALUES (~a,~a,~a,'~a')"
test-int
- (clsql-base:number-to-sql-string test-flt)
+ (clsql-sys:number-to-sql-string test-flt)
(transform-bigint-1 test-int)
- (clsql-base:number-to-sql-string test-flt)
+ (clsql-sys:number-to-sql-string test-flt)
)))))
(defun test-basic-forms ()
(deftest :connection/1
(let ((database (clsql:find-database
(clsql:database-name clsql:*default-database*)
- :db-type (clsql:database-type clsql:*default-database*))))
- (eql (clsql:database-type database) *test-database-type*))
+ :db-type (clsql-sys:database-type clsql:*default-database*))))
+ (eql (clsql-sys:database-type database) *test-database-type*))
t)
(deftest :connection/2
- (clsql-base::string-to-list-connection-spec
+ (clsql-sys::string-to-list-connection-spec
"localhost/dbname/user/passwd")
("localhost" "dbname" "user" "passwd"))
(deftest :connection/3
- (clsql-base::string-to-list-connection-spec
+ (clsql-sys::string-to-list-connection-spec
"dbname/user@hostname")
("hostname" "dbname" "user"))
t nil)
;; create a view, list its attributes and drop it
-(when (clsql-base:db-type-has-views? *test-database-underlying-type*)
+(when (clsql-sys:db-type-has-views? *test-database-underlying-type*)
(deftest :fddl/view/2
(progn (clsql:create-view [lenins-group]
:as [select [first-name] [last-name] [email]
("lenin@soviet.org"))
(deftest :fdml/select/6
- (if (db-type-has-fancy-math? *test-database-underlying-type*)
+ (if (clsql-sys:db-type-has-fancy-math? *test-database-underlying-type*)
(mapcar #'(lambda (s) (parse-integer s :junk-allowed t))
(clsql:select [function "trunc" [height]] :from [employee]
:result-types nil
(:base-table "ea_join"))
(defun test-connect-to-database (db-type spec)
- (when (db-backend-has-create/destroy-db? db-type)
+ (when (clsql-sys:db-backend-has-create/destroy-db? db-type)
(ignore-errors (destroy-database spec :database-type db-type))
(ignore-errors (create-database spec :database-type db-type)))
(truncate-database :database *default-database*)
(setf *test-database-underlying-type*
- (clsql:database-underlying-type *default-database*))
+ (clsql-sys:database-underlying-type *default-database*))
*default-database*)
(defun load-necessary-systems (specs)
(dolist (db-type +all-db-types+)
(when (db-type-spec db-type specs)
- (clsql:initialize-database-type :database-type db-type))))
+ (clsql-sys:initialize-database-type :database-type db-type))))
(defun write-report-banner (report-type db-type stream)
(format stream
*rt-ooddl* *rt-oodml* *rt-syntax*))
(let ((test (second test-form)))
(cond
- ((and (null (db-type-has-views? db-underlying-type))
- (clsql-base::in test :fddl/view/1 :fddl/view/2 :fddl/view/3 :fddl/view/4))
+ ((and (null (clsql-sys:db-type-has-views? db-underlying-type))
+ (clsql-sys:in test :fddl/view/1 :fddl/view/2 :fddl/view/3 :fddl/view/4))
(push (cons test "views not supported") skip-tests))
- ((and (null (db-type-has-boolean-where? db-underlying-type))
- (clsql-base::in test :fdml/select/11 :oodml/select/5))
+ ((and (null (clsql-sys:db-type-has-boolean-where? db-underlying-type))
+ (clsql-sys:in test :fdml/select/11 :oodml/select/5))
(push (cons test "boolean where not supported") skip-tests))
- ((and (null (db-type-has-subqueries? db-underlying-type))
- (clsql-base::in test :fdml/select/5 :fdml/select/10))
+ ((and (null (clsql-sys:db-type-has-subqueries? db-underlying-type))
+ (clsql-sys:in test :fdml/select/5 :fdml/select/10))
(push (cons test "subqueries not supported") skip-tests))
- ((and (null (db-type-transaction-capable? db-underlying-type
+ ((and (null (clsql-sys:db-type-transaction-capable? db-underlying-type
*default-database*))
- (clsql-base::in test :fdml/transaction/1 :fdml/transaction/2 :fdml/transaction/3 :fdml/transaction/4))
+ (clsql-sys:in test :fdml/transaction/1 :fdml/transaction/2 :fdml/transaction/3 :fdml/transaction/4))
(push (cons test "transactions not supported") skip-tests))
- ((and (null (db-type-has-fancy-math? db-underlying-type))
- (clsql-base::in test :fdml/select/1))
+ ((and (null (clsql-sys:db-type-has-fancy-math? db-underlying-type))
+ (clsql-sys:in test :fdml/select/1))
(push (cons test "fancy math not supported") skip-tests))
((and (eql *test-database-type* :sqlite)
- (clsql-base::in test :fddl/view/4 :fdml/select/10
+ (clsql-sys:in test :fddl/view/4 :fdml/select/10
:fdml/select/21))
(push (cons test "not supported by sqlite") skip-tests))
((and (eql *test-database-underlying-type* :mysql)
- (clsql-base::in test :fdml/select/22 :fdml/query/5
+ (clsql-sys:in test :fdml/select/22 :fdml/query/5
:fdml/query/7 :fdml/query/8))
(push (cons test "not supported by mysql") skip-tests))
(t
;; Ensure slots inherited from standard-classes are :virtual
(deftest :ooddl/metaclass/1
(values
- (clsql::view-class-slot-db-kind
- (clsql::slotdef-for-slot-with-class 'extraterrestrial
+ (clsql-sys::view-class-slot-db-kind
+ (clsql-sys::slotdef-for-slot-with-class 'extraterrestrial
(find-class 'person)))
- (clsql::view-class-slot-db-kind
- (clsql::slotdef-for-slot-with-class 'hobby (find-class 'person))))
+ (clsql-sys::view-class-slot-db-kind
+ (clsql-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 'clsql::view-class-effective-slot-definition))
- (clsql::class-slots (find-class 'person)))
+ (typep slotd 'clsql-sys::view-class-effective-slot-definition))
+ (clsql-sys::class-slots (find-class 'person)))
(every #'(lambda (slotd)
- (typep slotd 'clsql::view-class-effective-slot-definition))
- (clsql::class-slots (find-class 'employee)))
+ (typep slotd 'clsql-sys::view-class-effective-slot-definition))
+ (clsql-sys::class-slots (find-class 'employee)))
(every #'(lambda (slotd)
- (typep slotd 'clsql::view-class-effective-slot-definition))
- (clsql::class-slots (find-class 'company))))
+ (typep slotd 'clsql-sys::view-class-effective-slot-definition))
+ (clsql-sys::class-slots (find-class 'company))))
t t t)
(deftest :ooddl/join/1
projects / clsql.git / commitdiff