diff options
| author | Kevin M. Rosenberg <kmr@debian.org> | 2020-07-20 21:53:44 +0200 |
|---|---|---|
| committer | Kevin M. Rosenberg <kmr@debian.org> | 2020-07-20 21:53:44 +0200 |
| commit | bb7efd2a2a71a3bc34f84516fd8200ec1a3b36b7 (patch) | |
| tree | b3e7d60637a4bd917f6812a76f44be74b3247e8f | |
Import cl-sql_6.7.0.1.orig.tar.gz
[dgit import orig cl-sql_6.7.0.1.orig.tar.gz]
197 files changed, 56111 insertions, 0 deletions
@@ -0,0 +1,30 @@ +1. SBCL/Postgresql Interaction + +Gabor Melis reported an interaction with SBCL and the postgresql +database backend using a multithreaded program and Portable +AllegroServe. It appears that libpg installs its own SIGPIPE +handler. When a multithreaded program servicing socket requests has +SIGPIPE conditions thrown, the running SBCL instance is killed. The +web page http://linux.com.hk/docs/postgresql/libpq-threading.html has +more information about libpq's SIGPIPE handler. + +2. Object joining + +Aleksandar Bakic reported the documentation says that :home-key and +:foreign-key properties of the :db-info property may contain lists of +symbols. However, update-objects-joins fails in such cases. + +2. configure file +Automatically generate makefiles based on the configuration of an +end-users system + +3. SBCL/MySQL interaction Similar to the postgres interaction noted +above SBCL installs its own SIGPIPE handler but the mysql library +disables it breaking thread interrupts. See also +http://ccl.clozure.com/irc-logs/lisp/2012-02/lisp-2012.02.22.txt Look +for the conversation starting at 20:03:32 between bobbysmith007 and +pkhuong. + +4. Thread safety issues. While clsql attempts to be threadsafe there +are some significant issues with some backends. See +doc/threading-warnings.txt for more info. diff --git a/CONTRIBUTORS b/CONTRIBUTORS new file mode 100644 index 0000000..19c5799 --- /dev/null +++ b/CONTRIBUTORS @@ -0,0 +1,31 @@ +CLSQL Contributors +------------------ +Kevin Rosenberg (main author CLSQL) +Marcus Pearce <m.t.pearce@city.ac.uk> (initial port UncommonSQL, co-developer of CLSQL version 3.0) +Pierre Mai (original author MaiSQL from which CLSQL was based) +Aurelio Bignoli (SQLite backend) +Marc Battyani (Large object support for postgresql, initial connection pool code) +Ryan Davis, Nathan Bird, & Russ Tyndall (sponsored by http://www.acceleration.net/programming/) +Victor (vityok@github), sqlite3 backend updates and clsql_uffi long-long support +Aaron Burrow, clsql_uffi unsigned integer bugs +Ilya Khaprov deadtrickster@github - mysql backend stored-procedure / multiple result set support + + + + +USQL Contributors +----------------- +This is a list of those individuals who have contributed in some way +or other to Uncommonsql. The sources of the attributions are CVS +annotation, patch submission, and original authorship, write us if +we've missed anybody. + +Jesse Bouwman +Craig Brozefsky +Sean Champ +Matthew Danish +Adam Di Carlo +Lyn Headley +John Krug +Pierre Mai (original author) +Christopher J. Vogt diff --git a/COPYING.CLSQL b/COPYING.CLSQL new file mode 100644 index 0000000..d8bdee7 --- /dev/null +++ b/COPYING.CLSQL @@ -0,0 +1,18 @@ +CLSQL is written and Copyright (c) 2002-2009 by Kevin M. Rosenberg and is +based on the MaiSQL package written and Copyright (c) 1999-2001 by +Pierre R. Mai. In addition, CLSQL contains code from the UncommonSQL +project Copyright (C) 1999-2003 by onShore Development, Inc and code +from SQL/ODBC Copyright (C) 1999-2001 by Paul Meurer. + +CLSQL is licensed under the terms of the Lisp Lesser GNU +Public License (http://opensource.franz.com/preamble.html), known as +the LLGPL. The LLGPL consists of a preamble (see above URL) and the +LGPL. Where these conflict, the preamble takes precedence. +CLSQL is referenced in the preamble as the "LIBRARY." + +CLSQL is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + + + diff --git a/COPYING.MaiSQL b/COPYING.MaiSQL new file mode 100644 index 0000000..88c5806 --- /dev/null +++ b/COPYING.MaiSQL @@ -0,0 +1,25 @@ + Copyright (C) 1999-2001 Pierre R. Mai + + Permission is hereby granted, free of charge, to any person obtaining + a copy of this software and associated documentation files (the + "Software"), to deal in the Software without restriction, including + without limitation the rights to use, copy, modify, merge, publish, + distribute, sublicense, and/or sell copies of the Software, and to + permit persons to whom the Software is furnished to do so, subject to + the following conditions: + + The above copyright notice and this permission notice shall be + included in all copies or substantial portions of the Software. + + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, + EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF + MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. + IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY CLAIM, DAMAGES OR + OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, + ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR + OTHER DEALINGS IN THE SOFTWARE. + + Except as contained in this notice, the name of the author shall + not be used in advertising or otherwise to promote the sale, use or + other dealings in this Software without prior written authorization + from the author. diff --git a/COPYING.SQL-ODBC b/COPYING.SQL-ODBC new file mode 100644 index 0000000..b77a944 --- /dev/null +++ b/COPYING.SQL-ODBC @@ -0,0 +1,21 @@ +;;; SQL/ODBC module for MCL, CMUCL, LispWorks, ACL and CormanLisp +;;; Version 0.9 +;;; Copyright (C) Paul Meurer 1999-2001 All rights reserved. +;;; paul.meurer@hit.uib.no +;;; +;;; Use and copying of this software and preparation of derivative works +;;; based upon this software are permitted, so long as the following +;;; conditions are met: +;;; o This copyright notice is included intact. +;;; o No fees or compensation are charged for use, copies, or +;;; access to this software. You may charge a nominal +;;; distribution fee for the physical act of transferring a +;;; copy, but you may not charge for the program itself. +;;; o You are allowed to use this software as part of a commercial +;;; software package, provided that its functionality significantly +;;; exceeds the functionality of this software, and that the use of +;;; this software is explicitly mentioned in your documentation. +;;; +;;; This software is made available AS IS, and no warranty is made about +;;; the software or its performance. + diff --git a/COPYING.USQL b/COPYING.USQL new file mode 100644 index 0000000..e27518e --- /dev/null +++ b/COPYING.USQL @@ -0,0 +1,24 @@ +Copyright (c) 1999 - 2003 onShore Development, Inc. +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. The name of the author may not be used to endorse or promote products + derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES +OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. +IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, +INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT +NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF +THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/ChangeLog b/ChangeLog new file mode 100644 index 0000000..8827550 --- /dev/null +++ b/ChangeLog @@ -0,0 +1,3218 @@ +2016-01-26 Kevin Rosenberg <kevin@rosenberg.net> + * Version 6.7.0 release + * sql/utils.lisp: Apply patch from Martin Simmons for + Lispworks 7 compatiblity + +2016-01-17 Russ Tyndall <russ@acceleration.net> + * applied patches from Javeier Olaechea + * allows unix socket connections in clsql-postgressql-socket3 + * modernize asd slightly + +2015-10-09 Russ Tyndall <russ@acceleration.net> + * add decimals.lisp file https://github.com/tlikonen/cl-decimals + * use this for safe parsing of numeric / decimal / rational types + * Added because newer postgres print money types as currency strings + +2015-08-12 Kevin Rosenberg <kevin@rosenberg.net> + * Version 6.6.3 release + * db-oracle/oracle-sql.lisp: Patch for PostgreSQL socket interface + for unicode characters. Thanks to Jason Melbye. + +2015-06-02 Daniel KochmaÅ„ski <dkochmanski@turtle-solutions.eu> + * clsql.asd, sql/package.lisp: Add ECL compatibility fixes + * sql/db-interface.lisp: Fix declaration typo + +2015-04-06 Russ Tyndall <russ@acceleration.net> + * sql/operations, sql/expressions: add postgresql E-string + operator / expression. Needed for correct regex handling + EG: [E "some string"]=> E'some string' + +2015-03-30 Kevin Rosenberg <kevin@rosenberg.net> + * Version 6.6.2 release + * db-oracle/oracle-sql.lisp: Remove extra hyphen, thanks to + Thomas Vossen + +2015-03-24 Russ Tyndall <russ@acceleration.net> + * sql/oodml.lisp: fixed call-next-method in the base of + read-sql-value and replaced with a continuable + sql-value-conversion-error + * default read-sql-value for list + * tests for sql-value-conversion-errors and list + +2015-03-18 Russ Tyndall <russ@acceleration.net> + * {uffi,db-mysql}/Makefile: remove -pie build hardening for + which caused load issues for Linux Mint + +2015-03-18 Kevin Rosenberg <kevin@rosenberg.net> + * Version 6.6.1 release + * {uffi,db-mysql}/Makefile: Remove pie from build + hardening options for Debian/Ubuntu systems. Thanks to + DJ <jakep@arqux.com> and Russ Tyndall <russ@acceleration.net> + +2015-02-26 Kevin Rosenberg <kevin@rosenberg.net> + * Version 6.6.0 release + * {uffi,db-mysql}/Makefile: Add build hardening for Debian + +2015-02-24 Russ Tyndall <russ@acceleration.net> + * mysql-sql.lisp + an error in type declarations generating a compilation warning + was being treated as an error in recent SBCLs, fixed the type + warning by correcting the type (still a ton of compliation + notes) + +2015-02-23 Russ Tyndall <russ@acceleration.net> + * sql/metaclasses.lisp + made reinitialize-instance return the instance passed to it as + SBCL now expected (mentioned on the SBCL-devel mailing list by + Stas + +2014-12-03 Russ Tyndall <russ@acceleration.net> + * sqlite-sql.lisp + Added database arg to `canonicalize-result-types` so that it could + correctly call `sqlite-aref` with the required number of arguments + Thanks Zach Beane for the bug report. + +2014-07-29 Russ Tyndall <russ@acceleration.net> + * mysql-api.lisp, mysql-sql.lisp, test-connection.lisp + Added code to the mysql backend to pull all result sets as + multiple args. This fixes a bug in the mysql backend where trying + to query after executing a stored procedure (even on a pooled + connection) would raise an error about the connection being out of + sync. The second result set for the stored procedure seems to be + empty, so not sure why we need to iterate past it. + + patch / bugreport provided by: Ilya Khaprov deadtrickster@github + +2014-06-11 Russ Tyndall <russ@acceleration.net> + * databases.lisp, sqlite3-sql.lisp + Similar to and overriding the patch 2014-01-30 937a3d, adds a + default-encoding variable uses that in places where a nil encoding + was being passed. Defaults to :utf-8. This is mostly in place so + that uffi and cffi both work similarly (by moving the default into + clsql instead of clsql-uffi). This allows my automated build + environment to do its job + +2014-06-10 Russ Tyndall <russ@acceleration.net> + + * db-mysql/Makefile - the results of dpkg-buildflags --get LDFLAGS + seem to have changed on my system and and sed was returning + invalid command line arguments to ld. To resolve this I changed + sed to emit valid args, which seems to have resolved the issue. + +2014-04-24 Russ Tyndall <russ@acceleration.net> + * oodml.lisp, test-oodml.lisp Better handling of view-slots of + type symbol/keyword. Better handling of printing and reading + bindings (per mailing list request, always read and write in base + 10) + +2014-03-04 Kevin Rosenberg <kevin@rosenberg.net> + * Version 6.5.0: New release + * makefile.common: Check for /usr/bin/dpkg-buildflags + * {db-mysql,uffi}/Makefile: Use debian buildflags + +2014-02-24 Russ Tyndall <russ@acceleration.net> + * oodml.lisp bind *print-length* to nil before printing + lists/arrays to the database. + +2014-01-30 Russ Tyndall <russ@acceleration.net> + * sqlite3-sql.lisp specify :utf-8 as the default encoding if there + is not one (allows :clsql-cffi to be closer to working for this + backend). + + I ran the test suite successfully once with :clsql-cffi, but there + after I got spurious errors and especially unrecoverable errors + while connecting about the database being locked + +2014-01-30 Russ Tyndall <russ@acceleration.net> + * sqlite3-sql.lisp, fddl.lisp Dont compare database-identifiers + with invalid comparison operators + +2014-01-30 Russ Tyndall <russ@acceleration.net> + * generic-odbc.lisp, ooddl.lisp, generic-postgresql.lisp, + test-init.lisp, ds-nodes.lisp, generic-odbc.lisp, odbc-sql.lisp + + auto-increment-column support improvement (mssql esp, now will + auto-fill after insert). Use +auto-increment-names+ to determine + auto-increment-column-p. + + This triggered much test failing as regards normalized classes / + autoincrement primary key stuff. + + New odbc-postgresql-database sub-type + + POSSIBLY BREAKING CHANGES: + 1 ) Previously all classes in a normalized heirachy had their p-key + marked as "auto-increment". Usually auto-increment means a key + supplied by the database system, so this was decidedly + non-standard usage (clsql is explicitly providing the key for all + normalized subclasses of any given parent see ds-nodes.lisp). Some + RDMS will not allow insertion/updates of autoincrement columns + without hoop jumping and, as it doesnt really make much sense, I + removed the "auto-increment" aspects of normalized sub-classes. + Now the primary keys are chained regardless. The parent-most key + can be autoincrement or not. + + 2 ) ODBC Postgresql connections are now both GENERIC-ODBC-DATABASE + and GENERIC-POSTGRESQL-DATABASE. Probably not a widely used path, + but this change allows most of the previously failing tests to + pass on this backend (we now format stuff correctly for postgres). + I anticipate this probably is not perfect yet (IE: I probably + missed something) + +2014-01-29 Russ Tyndall <russ@acceleration.net> + * oodml.lisp, generics.lisp - added + clsql-sys::view-classes-and-storable-slots generic (added method + previously). Also added to-database-p keyword to allow overrides + to distinguish between the two situations. Mostly so that + clsql-helper:dirty-slots-mixin can filter slots when writing + values to the database but still allow all slots to be read from + the database + +2014-01-17 Russ Tyndall <russ@acceleration.net> + * oodml.lisp, generics.lisp - added filter-select-list generic + to allow fine grained control of generated query/object mappings + +2014-01-07 Russ Tyndall <russ@acceleration.net> + * clsql-uffi.lisp, sqlite3 auto-increment support + * clsql-uffi.lisp, test-basic.lisp, fixes related to unsigned vs + signed ints (thanks Aaron Burrow) + * cleaning and testing + +2013-09-27 Russ Tyndall <russ@acceleration.net> + * fixed bug converting to boolean in db-mysql/mysql-sql.lisp + from github user Sectoid https://github.com/UnwashedMeme/clsql/pull/1 + +2013-06-19 Russ Tyndall <russ@acceleration.net> + * sql/oodml.lisp, db-postgresql-socket3/sql.lisp, + db-mysql/mysql-objects.lisp, sql/generic-odbc.lisp + Refactored read-sql-value similar to the other recent refactorings + + * the symbol case now uses intern instead of read-from-string + (which may not return a symbol and could have security issues + since read-eval was not being unset) + + * read-eval is now off for all cases + + * centralized logic into a single case statement, hopefully making + this more readable and debuggable + + * TODO: make these refactorings to the oracle backend (I cannot + test against oracle and am loathe to change without testing + +2013-06-19 Russ Tyndall <russ@acceleration.net> + * sql/mysql-objects.lisp + Found and refactored a way some more eql specified methods of + database-get-type-specifier in mysql + +2013-06-18 Russ Tyndall <russ@acceleration.net> + * sql/oodml.lisp, sql/mysql-objects.lisp + refactored database-output-sql-as-type in a similar fashion to + the previous refactor of database-get-type-specifier (fewer + methods using case instead of eql specifiers) + + * removed very strange definition of outputing floats as strings + for something sane (it was previously doing silly work like + setting the default read float type (which AFAICT doesnt affect + printing)) + + * half of the cases nil returned "" other times it returned nil, + now if we get a null value we return nil always + + * removed odd-logic (seemingly untouched since the initial import), + that removed null characters from printed lists. If we have #\null + in a printed list, we had probably better figure out what went wrong + there rather than destructively modifying the list output on the way + to the DB ;; removed (substitute-char-string escaped #\Null " ") + +2013-06-18 Russ Tyndall <russ@acceleration.net> + * sql/generic-odbc.lisp, sql/generic-postgresql.lisp, sql/oodml.lisp + tests/test-fddl.lisp + + refactored database-get-type-specifier for postgres and mssql + + Single methods with a case on the symbol arg (similar to the recent + refactoring in oodml.lisp) + + This reduces line count and generally makes it easier to find and + read all the backend-specific types + +2013-06-10 Russ Tyndall <russ@acceleration.net> + * sql/oodml.lisp, sql/generic-postgresql.lisp, doc/ref-fddl.xml, + sql/packages.lisp + + Updated get-database-type-specifier to handle text/longchar type + and refactored + + * added a warning above defaulting to VARCHAR (since its probably + NOT what is expected on a bad type specifier). + + * added a case where the specified type being a string, passes + that string directly (to better/more easily allow db-specific + data-types). + + * added cases where longchar or text converts to text, and + exported those symbols (as this seemed type seemed to be missing + from fddl/oddl anyway). + + * reorganized these default methods into a single method with a + case statement rather than many eql specified methods (about half + the code) + + * updated the docs to use text instead of longchar since text is + a more standard db-type (pg,my,and ms all use text) + +2013-11-23 Kiss Kalman <kami@zalaszam.hu> + * utils/sql.lisp: Commit patch adding ccl getenv support + +2013-04-17 Kevin Rosenberg <kevin@rosenberg.net> + * Version 6.4.1 + * sql/utils.lisp: Patch from Ben Hyde to add weak hash table + support for CCL. + +2013-03-07 Ryan Davis <ryan@acceleration.net> + * db-postgresql-socket/postgresql-socket-api.lisp - bugfix to + adapt to changes in md5:md5sum-sequence. CLSQL now requires a + version of MD5 released on or after 2012-11-25 (the latest version + currenty in quicklisp). Thanks to Nicolas Neuss for the bug + report. + * db-odbc/odbc-sql.lisp - keep a reference to the original + connection spec used to create `odbc-database` connections + +2013-01-09 Russ Tyndall <russ@acceleration.net> + sql/oodml.lisp - changed view-classes-and-storable-slots to a + method (as it was intended to be all along) + +2012-12-19 Kevin Rosenberg <kevin@rosenberg.net> + * Version 6.4 + +2012-11-20 Russ Tyndall <russ@acceleration.net> + ## Large refactoring of sql/oodml.lisp and surrounding code + * cleaned up update-records-from-* to utilize a single codepath + previously there was much duplicate code + * tried to further unify direct/effective slot-defs + * cleaned up much of the normalized classes code to be more + consistent in how it operated, and the code it used (less + copy/paste more functions) + * tried to standardize iteration a bit, previously almost all + of the iteration constructs in CL were used. Tried to + standardize on loop for readability / cohesiveness + * made functions to more easily look up particular slots, since + this was being done differently in each function + * added more doc-strings and updated documentation about + normalized classes + * inner-joins that are referenced in where clauses are no longer + added to the select table list (since they are also referenced + in the join position and this led to sql errors) + * collect-table-references methods added for sql-ident-table and + list + + ## Semantic changes + * disallow where-less updates from objects (ie cannot call + update-records-from* with a keyless object) + * ordered-class-direct-slots now returns direct-slot-definitions + instead of effective-slot-definitions (as per name) + * direct-slot-definitions now contain the db-info hash table (same + as effective slots) + * removed this-class arg from update-instance-from-records - used to + be used for normalized code, no longer needed for that. + * find-all - bug fixes in table references, previously where clauses + surrounded by a list would have none of their references added to + the select. This was being exploited by certain code paths. Now + all where clauses are searched + - No longer includes order-by and distinct as columns in the select + list. The values seemed to be ignored in every code path and distinct + seemed to be intended to be used as a boolean anyway + + +2012-11-20 Nathan Bird <nathan@acceleration.net> + + * update-objects-joins - changed the default of slot from t (which + used to mean :deferred) to :immediate (to match the default + behavior of other parts of the system). It also seemed like a bad + default to pull all the slots that were explicitly specified to be + not pulled by default. This function now accepts more special + values (:immediate, :deferred, :all, or a list of slots). To get + the old behavior call with :slots :deferred. + + +2012-10-30 Russ Tyndall <russ@acceleration.net> + * sql/command-object.lisp - added dates/times to the parameter value + coersion and pulled this into a new generic prepare-sql-parameter + +2012-09-04 Kevin Rosenberg <kevin@rosenberg.net> + * Version 6.3 released + +2012-09-04 Russ Tyndall <russ@acceleration.net> + * sql/expressions.lisp - Try to respect the casing of symbols + where it seems intentional (ie: is not default). This should fix + a failing test case, and I think behaves more understandibly. + + If you specify a casing '|Foo Bar| lets treat that a string "Foo Bar" + and output it escaped + +2012-08-28 Ryan Davis <ryan@acceleration.net> + * db-sqlite3/sqlite3-api.lisp - allow pathnames in the connection + settings, so '("/db/my.sqlite") and '(#P"/db/my.sqlite") are + equivalent. Updated the docs to match. + +2012-08-17 Russ Tyndall <russ@acceleration.net> + * db-postgresql-socket3/package.lisp - shadow + postgresql-notification for compatibility with new + cl-postgres (Thanks Zach) + +2012-07-09 Russ Tyndall <russ@acceleration.net> + * sql/oodml.lisp - fixed a bug where the order by was being + destructively modified, causing odd caching issues when the + selected object was not statically known (eg unreferenced tables + could show up in the query if they were cached by a previous call + through this function. I replaced this code with a + non-destructive variant which should solve this. + + Thanks to Philipp Marek for the bug report + +2012-06-25 Russ Tyndall <russ@acceleration.net> + * sql/util.lisp, sql/metaclasses.lisp + Dequote database-identifiers if needed (passed a quoted symbol) + Metaclass args come through unquoted, so this eases interactions + with them + +2012-06-22 Russ Tyndall <russ@acceleration.net> + * sql/metaclasses.lisp: Changed compute-effective-slot-definition + to correctly copy the autoincrement-sequence slot to the ESD + previously it was being skipped (seemingly by accident). Thanks + to flip214 on #lisp for the bug report + +2012-04-26 Kevin Rosenberg <kevin@rosenberg.net> + * Version 6.2 released: thanks to all the contributors! + +2012-04-25 Nathan Bird <nathan@acceleration.net> + + * doc/threading-warnings.txt: Adding some notes from J.T.Klein + about the current state of thread-safety in clsql. This should be + incorporated into the main docs at some point. + +2012-04-25 Russ Tyndall <russ@acceleration.net> + * sql/expressions.lisp (output-sql): on rendering update/insert + expression values, ensure that *in-subselect* is bound to T + so that the values will be correctly paren delimited + +2012-04-24 Nathan Bird <nathan@acceleration.net> + + * sql/expressions.lisp (output-sql): on mysql CREATE TABLE + statements use 'ENGINE=innodb' instead of 'Type=InnoDB'. This has + apparently been preferred since mysql 4.1 and mysql 5.5 removed + type as a valid keyword. + +2012-03-28 Russ Tyndall <russ@acceleration.net> + + * sql/sequences.lisp: [A Patch FROM 2011-07-28 changed sequences. + They were previously prefixed with _CLSQL_SEQ_ but are now + suffixed with _CLSQL_SEQ. This is likely to break existing + implementations using the default sequence names + + setting *old-sequence-names* to T, should force using the older + naming scheme + +2012-03-27 Ryan Davis <ryan@acceleration.net> + + * sql/expressions.lisp: Fixed bug with subqueries in the where + clause of update-records and delete-records generating invalid + SQL. Previously subselects in where clauses would not have enough + parentheses, for example: "WHERE Id IN SELECT foo_id FROM bar" + vs. "WHERE Id IN (SELECT foo_id FROM bar)" + * tests/test-syntax.lisp: Added tests for using subqueries in the + where clause in update-records and delete-records. Moved asserts + in the test-output-sql/sql-ident-table function into the standard + test framework. + * doc/appendix.xml: added :connection-string to the information on + ODBC connection specs, and added example code connecting to ODBC + databases. + +2012-01-05 Nathan Bird <nathan@acceleration.net> + + * db-odbc/odbc-dbi.lisp: handle sql decimal type in the same way + as numeric type-- read into a double float. + +2011-01-04 Russ Tyndall <russ@acceleration.net> + * sql/operations.lisp + + Fixed bug reported by JTK related to the not-null sql-expression + especially as used in conjunction with the is operator. + + Made null called with more than one argument throw an exception + instead of silently discarding all arguments past the first + +2012-01-04 Nathan Bird <nathan@acceleration.net> + + * db-odbc/odbc-api.lisp (%sql-driver-connect): in the call to + odbc's SQLDriverConnect default the WindowHandle argument to a null ptr so + that connecting with :connection-string will work in the default + case of SQL_DRIVER_NOPROMPT. + + I.e. you can now do things like: + (clsql:connect '("DsnName" "UserName" "" :connection-string + "DRIVER={FreeTDS};SERVER=...;DATABASE=...;UID=...;PWD=...;PORT=1433;TDS_Version=8.0;APP=clsql") + :database-type :odbc) + + I believe the DsnName and Username at that point are only used when + printing the connection information. + +2011-12-20 Kevin Rosenberg <kevin@rosenberg.net> + * Version 6.1.1 + * db-oracle/oracle.lisp: Typo correction (Elias Martenson) + +2011-12-19 Kevin Rosenberg <kevin@rosenberg.net> + * Version 6.1.0 + * db-oracle/oracle.lisp: Change length function to + uffi:foreign-string-length to handle foreign encodings. + Thanks to Elias Martenson. + +2011-11-28 Russ Tyndall <russ@acceleration.net> + * db-odbc/odbc-api.lisp, tests/test-time.lisp + + In ODBC backend, avoid going through the common lisp + universal-time type (because it lacks support for historic dates) + + *time-conversion-function* renamed to *time-format* + + Patch from: Francisco Vides Fernandez + +2011-10-18 Russ Tyndall <russ@acceleration.net> + * db-odbc/odbc-api.lisp + + Added type specifier so MSSQL nvarchar fields can make it through + +2011-09-12 Russ Tyndall <russ@acceleration.net> + * sql/fddl.lisp sql/generic-postgres.lisp db-mysql/mysql-sql.lisp + sql/generic-odbc.lisp sql/odbc-api.lisp sql/odbc-dbi.lisp + + Fix bugs in list-attribute(s|-types) where passing an escaped, + instead of unescaped column name, caused these functions to return + less data than they should have. + +2011-08-03 Kevin Rosenberg <kevin@rosenberg.net> + * CLSQL 6.0.0 released + +2011-07-28 Russ Tyndall <russ@acceleration.net> + + * db-postgresql-socket3/: Added a backend that utilized postgres + socket api version 3. Uses the cl-postgres project (from + postmodern) to handle this. Allows use of parameterized / + prepared queries using clsql:command-object + + * sql/{expressions,fddl, generic-postgresql, ooddl}.lisp: + Change how database identifiers are emitted to hopefully make this + less brittle, and more easily intuitable. + + Previously every code path that wanted to emit a + database identifier was responsible for coercing what was provided + into a correctly escaped string. Sometimes two or three functions + in a row were trying to correctly quote and output that string. I + have tried to centralize this type coercion and logic into a + single code path. + + everything should now call (escaped-database-identifier thing) + immediately before splicing a database identifier into string being + sent to the database + + * sql/oodml.lisp: added method choose-database-for-instance, which + allows overriding which database connections are used based on + object type. Can be used to prevent connection conflicts in + multi-threaded environments + + * sql/syntax.lisp: [foo bar] and [foo.bar] read into the same + clsql expression now (they used to be output the same, but after + the above database-identifier change, they were output separately + + * test/: Better, more tests, better type coercion in tests and + throughout (%get-int) + + [edit 2012-03-28 - RT] + * sql/sequences.lisp: Sequences were previously prefixed with + _CLSQL_SEQ_ but are now suffixed with _CLSQL_SEQ. This is likely + to break existing implementations using the default sequence names + + setting *old-sequence-names* to T, should force using the older + naming scheme + + +2011-07-16 Kevin Rosenberg <kevin@rosenberg.net> + * Version 5.4.0 release + +2011-06-27 Nathan Bird <nathan@acceleration.net> + * db-odbc/: memory management improvements: leak slower + * MSSQL: TOP + DISTINCT work together + +2011-06-20 Nathan Bird <nathan@acceleration.net> + + * sql/time.lisp: Handle parsing already parsed objects. + * sql/oodml.lisp: raise exception if we generate an update with no + where clause; incorporate Ryszard Szopa's patch for functional + expressions in :order-by + * sql/expressions.lisp: (listify nil) => nil instead of (nil). + * db-odbc/: bugfixes for working with older versions of FreeTDS; + support for bigints that works on mssql and postgres + * MSSQL improvements: use top instead of limit, IDENTITY can be a + column constraint, clsql:date becomes 'smalldatetime' + +2011-06-20 Nathan Bird <nathan@acceleration.net> + + * Version 5.3.4 + * db-postgresql-socket/postgresql-socket-api.lisp: Addendum + to Otto Diesenbacher's patch that had a spurious write a 0 + byte (to terminate string) that should have been just CCL. + +2011-06-12 Kevin Rosenberg <kevin@rosenberg.net> + * Version 5.3.3 + * db-postgresql-socket/postgresql-socket-api.lisp: + Patch from Otto Diesenbacher for UTF8 encoded strings + for CCL. FIXME: The best patch would be to use the + user-set encoding from the database object and use + UFFI's encoding strings to/from octet vectors rather + than SB-UNICODE and CCL specific code in this file. + +2011-04-21 Kevin Rosenberg <kevin@rosenberg.net> + * sql/generics.lisp: Add defgeneric for new + database-last-auto-increment-id + +2011-04-01 Kevin Rosenberg <kevin@rosenberg.net> + * Version 5.3.2 + * db-mysql/mysql-client-info.lisp: Add recognition of + version 6 of MySQL client library. + * sql/metaclass.lisp: Fix the fix in the reader conditional + +2011-03-30 Kevin Rosenberg <kevin@rosenberg.net> + * Version 5.3.1 + * sql/metaclasses.lisp: Fix previous patch to work + on non-SBCL systems + +2011-03-29 Kevin Rosenberg <kevin@rosenberg.net> + * Version 5.3.0 + * sql/metaclasses.lisp: Apply one-line patch to fix + for newer SBCL (thanks to Nikodemus Siivola) + * many_files: Applied multiple patches from Holger Schauer + to improve autoincrement capability. + +2010-10-24 Kevin Rosenberg <kevin@rosenberg.net> + * Version 5.2.0 + * db-odbc/odbc-api.lisp: Change from SBCL-specific + to UFFI version of octets-to-strings. Reported by + Daniel Brunner <daniel@dbrunner.de> + * sql/oodml.lisp: Apply patch from Rupert Swarbrick + <rswarbrick@gmail.com>: Fix behaviour with auto-inc + primary keys. + * sql/expressions.lisp, tests/test-syntax.lisp: Apply + patch from Russ Tyndall to quote identifiers with space + or special character. + +2010-09-20 Kevin Rosenberg <kevin@rosenberg.net> + * Version 5.1.4 + * sql/{pool,database}.lisp: Pass encoding argument to + connections made from pool and with reconnect. + +2010-08-16 Kevin Rosenberg <kevin@rosenberg.net> + * Version 5.1.3 + * db-odbc/odbc-{api,dbi}.lisp: Commit patch from + Memet Bilgin to fix issue with unicode and ODBC. + +2010-08-16 Kevin Rosenberg <kevin@rosenberg.net> + * Version 5.1.2 + * uffi/clsql-uffi.lisp: Commit patch from JT Klein fixing + invocation of uffi:convert-from-foreign-string macro. When + time allows, I'll investigate changing UFFI's macro to + a function call and then revert this patch. + +2010-06-15 Kevin Rosenberg <kevin@rosenberg.net> + * Version 5.1.1 + * clsql-{uffi,mysql}.asd: Modify operation-done-p functions + to guard against change introduced in new ASDF traversing. + +2010-04-20 Kevin Rosenberg <kevin@rosenberg.net> + * Version 5.1.0 [DEPENDENCY UPGRADE: UFFI 2.x needed] + * clsql-uffi.asd: Depend on UFFI version >= 2.0 + to support foreign encoding of strings. + +2010-04-16 Kevin Rosenberg <kevin@rosenberg.net> + * Version 5.0.6 + * db-postgresql.lisp, sql/fddl.lisp: Fix typos [Thanks to + Walter C. Pelissero] + * sql/metaclasses.lisp: Work around type-check-function being set + during defclass expansion in SBCL [Thanks to Walter C. Pelissero] + * uffi/clsql-uffi.lisp: In call to uffi:convert-from-foreign-string, + Set null-terminated-p to T when length not specified. + [Thanks to Walter C. Pelissero] + +2010-03-21 Kevin Rosenberg <kevin@rosenberg.net> + * Version 5.0.5 + * sql/fdml.lisp: Fix DO-QUERY to actually return the last value of + the body. + +2010-03-02 Nathan Bird <nathan@acceleration.net> + * doc/: Added a README on how to build doc; now builds on Ubuntu. + * sql/oodml.lisp: READ-SQL-VALUE now has explicit method for + handling double-floats and the default method will no longer + attempt to convert values that have already been converted. + * sql/syntax.lisp: Introduce file-enable-sql-reader-syntax which + enables the syntax for the scope of the file without trying to + keep track of the current syntax state. + * sql/pool.lisp: Introduce + clsql-sys:*db-pool-max-free-connections* which is a heuristic + threshold for when to disconnect a connection rather than + returning it to the pool. + * sql/pool.lisp: Check connections for validity before returning + to the user. + +2010-03-01 Kevin Rosenberg <kevin@rosenberg.net> + * db-mysql/mysql-api.lisp: Remove spurious enumeration + +2010-02-16 Kevin Rosenberg <kevin@rosenberg.net> + * Version 5.0.4 + * db-mysql/mysql-api.lisp: Fix mysql_options UFFI parameter list + * doc/ref-connect.xml: Document the MySQL options parameter as + part of the connection-spec. + +2010-02-15 Kevin Rosenberg <kevin@rosenberg.net> + * db-mysql/mysql-{api,sql}.lisp: Support sending options + to MySQL using mysql_options, which occurs between the API calls + of mysql_init and mysql_real_connect. + +2010-02-11 Kevin Rosenberg <kevin@rosenberg.net> + * Version 5.0.3 + * multiple-files: Further internationalization. Change + UFFI:CONVERT-RAW-FIELD and UFFI:CONVERT-FROM-FOREIGN-STRINGS + invocations to use the foreign character set encoding of the + database object. Requires UFFI v.1.8.6 + * Makefile.common: Fix OS_DARWIN64 setting + +2010-02-11 Nathan Bird <nathan@acceleration.net> + * MSSQL: better support for fddl 'date type. + +2010-02-11 Kevin Rosenberg <kevin@rosenberg.net> + * Makefile.common, uffi/Makefile, db-mysql/Makefile: + Better support OS X Snow Leopard by building universal + (x86_64,i386) dylib bundles + +2010-02-08 Kevin Rosenberg <kevin@rosenberg.net> + * Version 5.0.2 + * sql/database.lisp: Fix missing slot-accessor + (Thanks to Stelian Ionescu) + * sql/generics.lisp: Add missing keyword to defgeneric + (Thanks to Stelian Ionescu) + +2010-02-07 Kevin Rosenberg <kevin@rosenberg.net> + * Version 5.0.1 + * sql/{base-classes,database}.lisp: Add encoding slot for + non-ASCII strings. + * db-mysql/mysql-sql.lisp: Use UFFI:FOREIGN-ENCODED-OCTET-COUNT. + Requires UFFI version 1.8.2 or above. + +2010-02-06 Kevin Rosenberg <kevin@rosenberg.net> + * Version 5.0.0: First release of CLSQL to formally and + consistently support non-ASCII strings with encoding of external + formats for SQL strings. UFFI version 1.8.1 is higher is required. + + This change may introduce some differences in string handling for + people who are using non-ASCII encoded characters. Thus, because + of the risk of BACKWARD INCOMPATIBILITY, the major version number + was incremented with this release. + +2010-02-06 Kevin Rosenberg <kevin@rosenberg.net> + * tests/test-i18n.lisp: Bind UFFI:*DEFAULT-EXTERNAL-FORMAT* + for testing multibyte encodings. + * uffi/clsql-uffi.lisp: Changes for UFFI 1.7.4's new support + for encoding foreign strings with a specified external format. + +2010-02-06 Kevin Rosenberg <kevin@rosenberg.net> + * sql/metaclasses.lisp: If no declared slot type in + compute-lisp-type-from-specified-type, then use t as lisp type. + Issue noted when testing Clozure CL 1.4. + +2010-02-06 Kevin Rosenberg <kevin@rosenberg.net> + * tests/test-init.lisp: Turn off the benign console notices for + testing on postgres. + +2010-02-05 Kevin Rosenberg <kevin@rosenberg.net> + * clsql-test.asd, tests/{test-i18n,test-init}.lisp: + Load test-i18n.lisp and use its tests as long as 'uffi:no-i18n is + not present in cl:*features*. This requires UFFI 1.7.2 or above. + +2010-02-05 Kevin Rosenberg <kevin@rosenberg.net> + * sql/utils.lisp: Reading #\no-break_space causes an + error for non-unicode SBCL. Conditionalize read of + #\no-break_space for non-unicode SBCL and 8-bit string + Allegro. + +2010-02-03 Kevin Rosenberg <kevin@rosenberg.net> + * tests/test-init.lisp: Add *test-report-width* variable + and word-wrap skipped test reason field. + +2010-01-29 Kevin Rosenberg <kevin@rosenberg.net> + * Version 4.3.3 + * clsql-cffi.asd: New file that causes CLSQL to use + CFFI-UFFI-COMPAT library rather than UFFI. Perform 'asdf:load-op + on CLSQL-CFFI rather than CLSQL system to use CFFI-UFFI-COMPAT. + +2010-01-29 Nathan Bird <nathan@acceleration.net> + * tests/*.lisp: A lot more tests and test setup tweaks. + * sql/expressions.lisp: output-sql on sql-relational-exp does + better arity checking now. (apply #'sql-and some-list) gives + better results. + +29 Jan 2009 Kevin Rosenberg <kevin@rosenberg.net> + * sql/oodml.lisp: Fix for UPDATE-RECORD-FROM-SLOTS for normalized + view classes + +28 Jan 2009 Kevin Rosenberg <kevin@rosenberg.net> + * Version 4.3.2 + * Change "normalise" from British spelling for consistency with + other American spellings in CLSQL. + +28 Jan 2009 Kevin Rosenberg <kevin@rosenberg.net> + * db-mysql/Makefile: Add directory for Fedora 11/12 on 64-bit + platform (Thanks to Michael Pheasant) and remove a 32-bit directory + +28 Jan 2009 Kevin Rosenberg <kevin@rosenberg.net> + * Version 4.3.1 + * sql/utils.lisp: Ensure Lispworks 6 lock is created in sharing mode + +20 Jan 2009 Nathan Bird <nathan@acceleration.net> + * Version 4.3.0 + * Rewrite tests to use datasets + +07 Jan 2009 Kevin Rosenberg <kevin@rosenberg.net> + * sql/utils.lisp: Changes to support Lispworks 6 + +10 Dec 2009 Kevin Rosenberg <kevin@rosenberg.net> + * Version 4.2.0 + * doc/ref-ooddl.lisp: Add needed CDATA escapes + * doc/clsql.pdf, doc/html.tar.gz: Build new manuals with + normalized view classes. + +10 Dec 2009 Kevin Rosenberg <kevin@rosenberg.net> + Large patch from Thijs Oppermann <thijso+clsql@gmail.com> to add + support for normalized view classes. When having view class that + inherit from others, CLSQL by default builds tab all the columns + from the parent in the child. This patch is meant to normali so + that a join is done on the primary keys of the concerned tables to + get a set. + +10 Dec 2009 Kevin Rosenberg <kevin@rosenberg.net> + * sql/time.lisp: Patch from Oleg Tihonov to SYNTAX-PARSE-ISO-8601 + to properly parse fractions of seconds. + +10 Dec 2009 Kevin Rosenberg <kevin@rosenberg.net> + * sql/time.lisp: Patch from Oleg Tihonov to roll function + to properly use USEC argument. + +21 Nov 2009 Kevin Rosenberg <kevin@rosenberg.net> + * Version 4.1.2 + * Makefiles: On 64-bit Linux systems, try to build both 32 and 64-bit + interface libraries. This requires the installation of multiarch build tools + as well as 32-bit support libraries (libc, libz and libmysqlclient). + +04 Sep 2009 Kevin Rosenberg <kevin@rosenberg.net> + * Version 4.1.1 + * sql/fdml.lisp: Rework do-query to use supplied database + parameter when passed a sql-object-query + (thanks to JTK <jetmonk@gmail.com>) + * sql/generic-postgresql.lisp: Allow optional connect + parameters for postgresql databases (thanks to Stephen Compall) + * doc/ref-{clsql,connect}.xml, sql/db-interfaces.lisp: + Fix transposed letters (thanks to Stephen Compall) + * db-mysql/Makefile: Add directory for MacPorts mysql5 port + (thanks to Stephen Compall) + * sql/database.lisp: Have database-type default be + *default-database-type* (thanks to Desmond O. Chang) + * sql/transactions.lisp: Improved handlining of nested + transactions (thanks to Eli Naeher) + * sql/time.lisp: Commit patch to fix parse-iso-8601-duration + (thanks to Stephen Compall) + * sql/database.lisp: Use :verbose nil for asdf:operate + invocation (Thanks to Mackram Raydan) + * sql/metaclasses.lisp: Rework initialize-instance for + view-class-direct-slot-definition (thanks to Stephen Compall) + +31 Aug 2009 Kevin Rosenberg <kevin@rosenberg.net> + * sql/db-interface.lisp: Fix spelling error (thanks to + David Thompson) + * clsql-mysql.asd/db-mysql/mysql-loader.lisp: Commit + patch from Andreas Franke to honor windows drive letter + when loading clsql_mysql C library. + +31 Aug 2009 Kevin Rosenberg <kevin@rosenberg.net> + * Version 4.1.0 + * db-mysql/mysql-{sql,api}.lisp,db-mysql/clsql_mysql.c: + Latest version of mysqlclient once again changed the C + structures from which the mysql backend reads data. + Rather than adding yet another structure definition which + is enabled by the client version as read by mysql-client-info.lisp, + the mysql backend has been re-written to ignore in the internal + C structures. Instead, C wrapper functions for slot access have + been added to clsql_mysql.c and are used by mysql-sql.lisp to + access the internals of C structures. This adds a bit of overhead, + but completely separates the lisp code from trying to keep up + with the continually changing internal C structure of mysql. + All tests in the test suite executed correctly with this change. + +31 Aug 2009 Kevin Rosenberg <kevin@rosenberg.net> + * Version 4.0.6 + * sql/database.lisp: Fix syntax on process-lock (thanks to + Stian Sletner) + * db-mysql/mysql-sql.lisp: Allow use of database parameter + in database-list function (thanks to Michael Pheasant) + * sql/oodml.lisp: Allow NULL values for floating-point fields + (thanks to Jan Rychter) + +02 Jun 2009 Kevin Rosenberg <kevin@rosenberg.net> + * Version 4.0.5 + * sql/database.lisp: Add process-lock for deleting database from + a pool (thanks to Ralf Mattes). + +25 Feb 2008 Kevin Rosenberg <kevin@rosenberg.net> + * Version 4.0.4 + * sql/expressions.lisp: Remove stray form (thanks to Samuel Ward) + +12 Dec 2007 Kevin Rosenberg <kevin@rosenberg.net> + * sql/expressions.lisp: Bind *in-subselect* when outputting + selections (patch from unknown source). + +11 Dec 2007 Kevin Rosenberg <kevin@rosenberg.net> + * Version 4.0.3 + * sql/metaclasses.lisp: Unify base-table processing by extracting + the correct code from initialize-instance :around into the helper + function set-view-table-slot. Call that function also in + reinitialize-instance :around replacing erroneous code discovered + by Josh Feinstein. + +17 Nov 2007 Kevin Rosenberg <kevin@rosenberg.net> + * BUGS: Add note about benefit of using configure file to create + Makefiles (suggestion from Joe Corneli) + +22 Oct 2007 Kevin Rosenberg <kevin@rosenberg.net> + * Version 4.0.2 + * db-postgresql/postgresql-sql.lisp: Patch from Gabriele Favalessa based on + Andrew Golding suggestion for more informative :error-id slot. + +17 Sep 2007 Kevin Rosenberg <kevin@rosenberg.net> + * Version 4.0.1 + * db-mysql/mysql-sql.lisp: Convert query to uffi cstring (thanks to + Albert Krewinkel). + * doc/Makefile, doc/html.xsl: Change output encoding from ISO-8859-1 to UTF-8 + +14 Sep 2007 Kevin Rosenberg <kevin@rosenberg.net> + * Version 4.0.0: Major version increase to warn of potential + backwards incompatibility. + * NEWS: Document potentional backward incompatible changes + * db-mysql/mysql-sql.lisp: Changes session SQL mode to ANSI immediately + after connecting. This may break compatibility with some applications + who are using non-ANSI features with MySQL. This change is required to + properly support view-classes using a string as their :base-table + attribute. This allows users to specify the case of table names. + This is feature is even more essential for MySQL itself since MySQL + uses case-sensitive table names. Use connection-based database-create + and database-destroy rather than trying to invoke command-line mysql + utility. Remove automatic upcasing of strings from list-indices. + * db-postgresql/postgresql-sql.lisp: Use connection-based + database-create and database-destroy rather than trying to invoke + command-line utilities. + * db-postgresql-socket/postgresql-socket-sql.lisp: Use + database-execute-command rather than execute-command for + database-{create,destroy}. Connect to postgres database + rather than template1 for those database creation/deletion. + * sql/metaclasses.lisp: Store the string value of :base-table if a + string is provided. Perform sql-escape at time of view-table name + creation. + * tests/test-init.lisp: Use "ej_join" as a string, rather than a + symbol, since "ej_join" is specified as :base-table. Clear the + expression output-cache in case the code for generating sql output + has changed. + * test/test-oodml.lisp: whitespace fix + * sql/ooddl.lisp: Use quoted string for primary key constraint if + table name is specified as a string. + * sql/oodml.lisp: Don't convert a string view-table name to database's + default case. + * sql/expressions.lisp: Properly handle table and attribute identifiers + when they are a string. Do not change case of symbols to match database + default case. + * sql/operations.lisp: Change multiword symbols to upper case. + * sql/fddl.lisp: Quote base-table if a string to preserve case + for drop-table and create-table. + * tests/test-syntax.lisp: Add tests of low-level string attribute + identifiers. + +20 Jul 2007 Kevin Rosenberg <kevin@rosenberg.net> + * Version 3.8.6 + * db-oracle/oracle-loader.lisp: Rework use of ORACLE_HOME directory + (problem noted on clsql-devel by icardo Boccato Alves) + * sql/pool.lisp: Remove incorrect keyword + * sql/database.lisp: Rework WITH-DATABASE to not make the database the + default database (reported by Saurabh Nanda and Chaitanya Gupta) + * doc/ref-connect.lisp: Update the documentation to WITH-DATABASE to + emphasis that make-default has a default value of nil. + * sql/transaction.lisp: Adjust commit/rollback messages for Microsoft + SQL Server. (patch from Nathan Bird) + * sql/metaclasses.lisp: Use finalize-inheritance hack on SBCL because + of trouble with def-view-class compilations (patch from Nathan Bird) + +15 Jul 2007 Kevin Rosenberg <kevin@rosenberg.net> + * Version 3.8.5 + * db-mysql/mysql-loader.lisp: Revert previous change since libmysql is + not dynamically loaded on Windows + +22 Jun 2007 Kevin Rosenberg <kevin@rosenberg.net> + * Version 3.8.4 + * db-mysql/mysql-loader.lisp: Do not bother loading libmysqlclient since + that library is dymically linked to clsql-mysql library. Thus, the mysql + library will be automatically loaded. This has only been tested on Linux, + thus far. + +29 May 2007 Kevin Rosenberg <kevin@rosenberg.net> + * tests/test-fddl.lisp: Add :order-by for :fddl/big/1 as + reported by Ricardo Boccato Alves + +02 May 2007 Kevin Rosenberg <kevin@rosenberg.net> + * sql/database.lisp: Add ability of WITH-DATABASE to return + multiple values (patch from Liam Healy) + +25 Apr 2007 Kevin Rosenberg <kevin@rosenberg.net> + * Version 3.8.3 + * doc/connect.xml: variable description fix by Liam Healy + * db-sqlite3/sqlite3-api.lisp, uffi/clsql-uffi-loader.lisp: + Apply patches from Marcus Pierce to reduce load-time warnings + * sql/package.lisp: Export iso-timestring as requested by Kevin Blaisdell + +23 Mar 2007 Kevin Rosenberg <kevin@rosenberg.net> + * Version 3.8.2 + * sql/db-postgresql-socket-api.lisp: Change read-socket-sequence to + disable wide characters for crypt salt sequence on SBCL, based + on patch from Lars Nostdal. + +26 Jan 2007 Kevin Rosenberg <kevin@rosenberg.net> + * Version 3.8.1 + * sql/pool.lisp: Test pooled connection when popped from + the pool to ensure the connection still works. Currently, implemented + only for MySQL. + +17 Jan 2007 Kevin Rosenberg <kevin@rosenberg.net> + * db-mysql/Makefile: Add potential mysql directories + +31 Dec 2006 Kevin Rosenberg <kevin@rosenberg.net> + * sql/metaclasses.lisp: Remove usused saved-initargs + * clsql.asd: Also check ~/.clsql-init.lisp at load-time (usually used to + push search libraries) + +30 Dec 2006 Kevin Rosenberg <kevin@rosenberg.net> + * Version 3.8.0: BACKWARD INCOMPATABLE CHANGE! + * db-postgresql/postgresql-{api,loader,sql,package}.lisp: + Apply patch from Edi Weitz to avoid conflict with new Lispworks 5 + POSTGRESQL package name. CLSQL's new package will be PGSQL, however + on non-Lispworks platforms, the nickname POSTGRESQL will still be + available. Applications directly using low-level POSTGRESQL package + are recommended to use the new PGSQL name. + * db-oracle/oracle-{api,sql}.lisp, sql/{expressions,loop-extension}.lisp, + Apply patch from Edi Weitz to reduce compiler warnings. + +28 Dec 2006 Kevin Rosenberg <kevin@rosenberg.net> + * Version 3.7.9 + * sql/expressions.lisp: Commit patch from Edi Weitz to + use *default-database* for SQL-OUTPUT if no database is + explicitly passed to function. + * uffi/clsql-uffi-loader.lisp: Change load order to first try + plain name/type before attempting user-specified paths (patch + from Edi Weitz) + * uffi/ptrbits.c: New file to return number of bits in an pointer + * uffi/Makefile: use intbits to name .so file based on bit size. + Build both 32-bit and 64-bit libraries on 64-bit platform. + +30 Nov 2006 Kevin Rosenberg <kevin@rosenberg.net> + * Version 3.7.8 + * db-sqlite3/sqlite3-sql.lisp: Commit patch from Edi Weitz fixing + error display + +16 Oct 2006 Kevin Rosenberg <kevin@rosenberg.net> + * Version 3.7.7 + * db-postgresql/postgresql-sql.lisp: Remove + uffi:convert-foreign-to-native wrapper since using cstring for + PQresultErrorField + +16 Oct 2006 Kevin Rosenberg <kevin@rosenberg.net> + * Version 3.7.6 + * db-postgresql/postgresql-api.lisp: Fix UFFI return type for + PQresultErrorField foreign function. + +16 Oct 2006 Kevin Rosenberg <kevin@rosenberg.net> + * Version 3.7.5 + * doc/intro.xml: Update supported platforms. + * db-postgresql/postgresql-{package,api,sql}.lisp: Apply + changes from Andew Golding to use a more-specific error code + from PostgreSQL than the generic fatal error code of the result set. + +03 Oct 2006 Kevin Rosenberg <kevin@rosenberg.net> + * sql/syntax.lisp: Commit patch from Marcus Pearce to improve + readtable modifications + +02 Oct 2006 Kevin Rosenberg <kevin@rosenberg.net> + * sql/syntax.lisp: Check that original reader syntax functions + stored before trying to restore them. + +20 Sep 2006 Kevin Rosenberg <kevin@rosenberg.net> + * sql/syntax.lisp: Apply patch from Marcus Pearce to correctly + display sql reader syntax. + +06 Sep 2006 Kevin Rosenberg <kevin@rosenberg.net> + * uffi/clsql-uffi-loader.lisp, db-mysql/mysql-loader.lisp: Change from using *features* + to decide on 64-bit platform and check size of most-positive-fixnum instead. + Needed to support clisp amd64. + +03 Sep 2006 Kevin Rosenberg <kevin@rosenberg.net> + * Version 3.7.1 + * sql/metaclasses.lisp: Rework slot type's to be more AMOP + compatibile. Add warning for a metaclass condition that should + not occur. + * sql/time.lisp: Fixed symbol case inconsistency causing problem + in AllegroCL's modern lisp. First sign of bug noted by + Joel Reymond on clsql-devel. + * clsql.asd: Make time.lisp depend on utils.lisp + +31 Aug 2006 Kevin Rosenberg <kevin@rosenberg.net> + * db-mysql/mysql-loader.lisp: Apply patch from Marcus Pearce to push + *library-file-dir* to CLSQL's library path. + +30 Aug 2006 Kevin Rosenberg <kevin@rosenberg.net> + * Version 3.7.0: New platforms supported: SBCL/Win32, CLISP/Win32, CLISP/Cygwin, + CLISP/Linux x86, CLISP/Linux amd64, OpenMCL amd64. CLISP support requires the + latest development versions of CLISP, cffi, and cffi-uffi-compat packages. + * Makefile.common: Add OS detection + * uffi/make.sh, db-mysql/make.sh: Remove files + * uffi/Makefile, db-mysql/Makefile: Add support for cygwin compilation. + Refactor to remove need to make.sh shell scripts. + * clsql.asd: Add support for loop extensions for clisp. Support clisp via cffi. + * sql/loop-extension.lisp: Define loop-record-iteration-path in CLSQL-SYS + package rather than CL-USER. Add support for ansi-loop on clisp. + * sql/ansi-loop.lisp: New file to support iteration on clisp. + * db-mysql/mysql-api.lisp: Remove old mysql C API functions that no + longer exist in the mysql client library. + * doc/ref-fdml.lisp: Correct default field-type. + * sql/expressions.lisp: Use database-output-as-type if value exists for boolean output. + Fixed bug with noted with MySQL 5.0.24 and boolean values. + +28 Aug 2006 Kevin Rosenberg <kevin@rosenberg.net> + * Version 3.6.7 + * sql/oodml.lisp: Remove high debugging level declaration + +14 Aug 2006 Kevin Rosenberg <kevin@rosenberg.net> + * Version 3.6.6 + * sql/generic-postgresql.lisp: Fix assumption that postgres user id + is always 1. Fixes problem noted with PostgreSQL 8.1. + +12 Aug 2006 Kevin Rosenberg <kevin@rosenberg.net> + * Version 3.6.5 + * sql/generic-postgresql.lisp: Add slot for has-table-pg_roles to + lazily cache if pg_roles tables exist. Selectively use SQL from + Joel's previous patch if pg_roles table exists. Should now work + with both postgresql 7.4 and 8.x. + +12 Aug 2006 Kevin Rosenberg <kevin@rosenberg.net> + * Version 3.6.4 + * clsql.asd: Add support for c:\etc\clsql-init.lisp as possible + local initialization file + * db-mysql/mysql-loader.lisp: Remove former method of using pathnames + as name candidates. + * db-odbc/odbc-api.lisp: Work-around Allegro/Windows FFI bug + that generates incorrect integer return type + * sql/generic-postgresql.lisp: Revert patch from Joel Reymont since + it fails on versions of postgresql that lack the pg_role table + +07 Jul 2006 Kevin Rosenberg <kevin@rosenberg.net> + * Version 3.6.3 + * sql/transactions.lisp: Important typo fix from Alexey Antipov + for database-start-transaction + +04 Jul 2006 Kevin Rosenberg <kevin@rosenberg.net> + * Version 3.6.2 + * db-postgresql/postgresql-sql.lisp: Apply patch from Vladimir Sekissov + to close connection when failing to connect to database. + * sql/generic-postgresql.lisp: Apply patch from Joel Reymont + to avoid dropping system views. + * sql/oodml.lisp: Apply patch from Joel Reymont to avoid listify + a nil value [patch sponsored by Flektor] + * clsql-uffi.asd, uffi/make.sh: Patch from Richard Kreuter + for netbsd compilation + +15 May 2006 Kevin Rosenberg <kevin@rosenberg.net> + * doc/ref-ooddl.xml: Add documentation for :db-reader and :db-writer + slots for def-view-class macro [as reported missing by Thomas Fischbacher]. + +09 May 2006 Kevin Rosenberg <kevin@rosenberg.net> + * db-postgresql-socket/postgresql-socket-api.lisp: + Apply patch from Marko Kocic adding the socket creation + function needed for CLISP. + +08 May 2006 Kevin Rosenberg <kevin@rosenberg.net> + * Version: 3.6.0 (requires UFFI v1.5.11 or greater) + * db-oracle/metaclasses.lisp: Patch from James Bielman for + checking slot constraints. + * db-oracle/oracle-{api,sql}.lisp: Avoid dead pointers on loading + saved openmcl images (based on patch from James Bielman) + +06 May 2006 Kevin Rosenberg <kevin@rosenberg.net> + * doc/ref-fdml.xml: Documentation patch from Marcus Pearce for limit keyword + +03 May 2006 Kevin Rosenberg <kevin@rosenberg.net> + * Version 3.5.7 + * sql/time.lisp: Apply patch from Aleksandar Bakic to extended + duration parsing and unparsing to include year and month. + * clsql-uffi.asd, uffi/clsql-uffi-loader.lisp: Apply patch from Nathan Bird + improving library search on Windows platform. + * doc/ref-fdml.xml, /doc/TODO, tests/test-fdml.lisp, tests/test-init.lisp: + Apply patch from Marcus Pearce documenting and testing :limit and :offset for SELECT + +20 Mar 2006 Kevin Rosenberg <kevin@rosenberg.net> + * Version 3.5.6 + * clsql-postgresql-socket.asd, + * db-postgresql-socket/postgresql-socket-package.lisp: + Use the cl-md5 package on all platforms. Based on report + from Alan Caulkins. + +09 Mar 2006 Kevin Rosenberg <kevin@rosenberg.net> + * Version 3.5.5 + * uffi/make.sh, db-mysql/make.sh: Add GNU uname + +28 Feb 2006 Kevin Rosenberg <kevin@rosenberg.net> + * Version 3.5.4 + * sql/metaclasses.lisp: Apply patch from Friedrich Dominicus to + fix accessor for new versions of SBCL + * db-oracle/oracle-sql.lisp: Apply patch from James Bielman + to improving parsing of time. + * db-db2/db2-constants.lisp: Change NULL_HANDLE has suggested + by Harold Lee. + * db-oracle/oracle-dbi.lisp: Add support for SQL BIT type + as noted by Russ Tyndall. + +16 Jan 2006 Kevin Rosenberg <kevin@rosenberg.net> + * Version 3.5.3 + * sql/time.lisp: Commit patch from Aleksandar Bakic + to properly handle destructive flag + * db-postgresql-socket/postgresql-socket-api.lisp: Apply patch + from Steven Harris for socket files with SBCL. + * sql/pool.lisp: Apply patch from Vladimir Sekissov so that + new connections added to the pool do not become the *default-database* + * sql/connect.lisp: Optionally set *default-database* for pooled + connection when make-default is generalized true. + +23 Dec 2005 Kevin Rosenberg <kevin@rosenberg.net> + * Version 3.5.1 + * sql/expressions.lisp: Ensure table names are properly escaped + before comparing -- fixes bug reported by Asbjørn Bjørnstad + on CLSQL-Devel. + +02 Dec 2005 Kevin Rosenberg <kevin@rosenberg.net> + * sql/generic-postgresql.lisp: improved decoding of table attribute + parameters [from Vladimir Sekissov] + * sql/metaclasses.lisp: check that metaclass is standard-db-class or + it's subclass to prevent adding standard-db-object to supers if + somebody in the path has it already when metaclass inherited from + standard-db-class. [from Vladimir Sekissov] + +26 Nov 2005 Kevin Rosenberg <kevin@rosenberg.net> + * Version 3.5.0 + * tests/test-init.lisp, tests/test-fddl.lisp, tests/test-fdml.lisp, + * db-odbc/odbc-api.lisp, db-odbc/odbc-ff-interface.lisp, + * db-odbc/odbc-package.lisp, db-odbc/odbc-constants.lisp + * db-odbc/odbc-dbi.lisp, db-odbc/odbc-sql.lisp + * sql/fddl.lisp, sql/generic-odbc.lisp, sql/db-interface.lisp + * sql/transaction.lisp, sql/package.lisp, sql/time.lisp + Commit patch from Dominic Robinson providing support for + Microsoft SQL Server + * doc/csql.lisp: Fix typo in slot name + +24 Nov 2005 Kevin Rosenberg <kevin@rosenberg.net> + * Version 3.4.7 + * sql/time.lisp: Commit patch from Aleksandar Bakic for + correct handling of decode-time usec value + * clsql-mysql.asd: Commit patch from Harald Hanche-Olsen to + correct the name of the shared library file. + +16 Nov 2005 Kevin Rosenberg <kevin@rosenberg.net> + * version 3.4.6 + * sql/metaclasses.lisp: Avoid calling change-class on + effective-slot-definitions on sbcl to conform to sbcl 0.9.6.38 + changes. + +15 Nov 2005 Kevin Rosenberg <kevin@rosenberg.net> + * Version 3.4.5 + * sql/expressions.lisp: Patch from James Biel to add subselects + +14 Nov 2005 Kevin Rosenberg <kevin@rosenberg.net> + * Version 3.4.4 [ Requires UFFI 1.5.7+] + * db-oracle/oracle-{api,sql}.lisp: Patch from James Biel + to fix lifetime of foreign strings for Oracle calls + +13 Nov 2005 Kevin Rosenberg <kevin@rosenberg.net> + * Version 3.4.3 + * db-oracle/oracle-{api,sql}.lisp: Patch from James Biel + to improve performance + +12 Nov 2005 Kevin Rosenberg <kevin@rosenberg.net> + * Version 3.4.2 + * clsql-uffi.asd: Patch from James Biel improving loading + * db-oracle/oracle-{api,sql}.lisp: Patch from James Biel + to support 64-bit lisps + +12 Nov 2005 Kevin Rosenberg <kevin@rosenberg.net> + * Version 3.4.1 + * sql/expressions.lisp: Escape numbers to SQL strings + at expression level. + +11 Nov 2005 Kevin Rosenberg <kevin@rosenberg.net> + * Version 3.4: Add MySQL 5 support + * db-mysql/mysql-client-info.lisp: Recognize MySQL 5 + * db-mysql/mysql-sql.lisp: Add support for views in MySQL 5 + * doc/mysql-macosx-notes.txt: New document from Martin Brooks + +7 Nov 2005 Kevin Rosenberg <kevin@rosenberg.net> + * src/time.lisp: Apply patch from Aleksandar Bakic for ROLL + function. + * BUGS: Added report for update-object-joins by Aleksandar Bakic + +4 Nov 2005 Kevin Rosenberg <kevin@rosenberg.net> + * Version 3.3.4 [UFFI >= 1.5.5 needed] + * db-odbc/odbc-api.lisp: Apply patch from Yaroslav Kavenchuk + to add missing #\' character. + * clsql.asd: Add support for CLSQLINIT environmental variable, + based on patch from Yaroslav Kavenchcuk. New version of UFFI + required. + +30 Oct 2005 Kevin Rosenberg <kevin@rosenberg.net> + * Version 3.3.3 + * sql/oodml.lisp: Apply patch from Drew Crampsie to fix + update-objects-joins when using the :target-slot attribute + +26 Oct 2005 Kevin Rosenberg <kevin@rosenberg.net> + * Version 3.3.2 + * sql/expressions.lisp: Avoid parenthesis on multiple group-by fields + as noted by Harald Hanche-Olsen. + * tests/test-syntax.lisp: Add test for multiple field group-by + +25 Oct 2005 Kevin Rosenberg <kevin@rosenberg.net> + * Version 3.3.1 + * sql/time.lisp: Commit patch from Alan Shields to + display escape string on wall-time display only when *print-escape* + is true. + +11 Oct 2005 Kevin Rosenberg <kevin@rosenberg.net> + * sql/metaclasses.lisp: Commit patch from Will to + properly set db-reader slot in effective-slot-definition + * sql/expressions.lisp: Commit patch from Alan Shields + adding make-load-form for sql-relational-exp + * sql/generic-postgresql.lisp: Commit patch from Aleksandar Bakic + adding support for new NUMBER type + +17 Sep 2005 Kevin Rosenberg <kevin@rosenberg.net> + * Version 3.3.0 + * sql/time.lisp: Apply patch from Alan Shields adding DATE type. + * doc/ref-ooddl.xml: Documentation of new type + * notes/add-type-hints.txt: New file from Alan Shields + * sql/fddl.lisp: Add owner keyword to drop-table as suggested + by Francis Leboutte + * db-postgresql-socket/postgresql-socket-sql.lisp: Fix database-probe + as noted by Francis Leboutte. Similar fix applied to db-mysql and + db-postgresql. + * sql/expressions.lisp: Allow string table names for output as + contributed by Francis Leboutte. + * examples/clsql-tutorial.lisp: Support :postgresql-socket as noted + by Francis Leboutte + +08 Sep 2005 Kevin Rosenberg <kevin@rosenberg.net> + * Version 3.2.4 + * doc/into.xml: Change download from ftp to http protocol + +08 Sep 2005 Kevin Rosenberg <kevin@rosenberg.net> + * Version 3.2.3 + * db-oracle/oracle-sql.lisp: Correction for v3.2.2 changes by + Edi Weitz + +08 Sep 2005 Kevin Rosenberg <kevin@rosenberg.net> + * Version 3.2.2 + * db-oracle/oracle-sql.lisp: Add check for zero increment as + suggested by Edi Weitz. Add missing database-sequence-last function + as noted and tested by Edi Weitz. Ensure that UFFI buffer is freed + in handle-oci-error. Add unwind-protect to sql-stmt-exec. Free UFFI + stmthp object when query cursor is freed with OCI. + +22 Aug 2005 Kevin Rosenberg <kevin@rosenberg.net> + * uffi/clsql-uffi-loader.lisp: Commit patch from astor@pvv.ntnu.no to + display search path when error occurs loading foreign library. + +05 Jul 2005 Kevin Rosenberg <kevin@rosenberg.net> + * Version 3.2.1 + * doc/appendix.xml: Incorporate Edi Weitz's notes into documentation + with changes to support case-sensitive lisp implementations. Add + paragraph on using /etc/clsql-init.lisp site initialization file. + * clsql.asd: Load file /etc/clsql-init.lisp, if it + exists, after package is loaded to set site-specific configuration + +2005-06-24 Edi Weitz <edi@agharta.de> + * sql/db-interface.lisp: Added new special variable + *FOREIGN-LIBRARY-SEARCH-PATHS* and function PUSH-LIBRARY-PATH to + manipulate it. + * sql/package.lisp: Export these. + * uffi/clsql-uffi-loader.lisp: Used new variable; changed order of + libs. + * db-mysql/mysql-loader.lisp: Changed order of libs. + +09 Jun 2005 Kevin Rosenberg <kevin@rosenberg.net> + * Version 3.2.0: REQUIRES UFFI VERSION 1.4.38 OR HIGHER + * clsql-mysql.asd: Renamed clsql/mysql interface library from + mysql to clsql_mysql + * clsql-uffi.asd: Renamed clsql/uffi interface library from + mysql to clsql_uffi + * uffi/clsql_uffi.c: Renamed from uffi.c + * db-mysql/clsql_mysql.c: Renamed from mysql.c + * db-mysql/Makefile, db-mysql/Makefile.msvc, db-mysql/mysql-loader.lisp: Rename shared library + * uffi/Makefile, uffi/Makefile.msvc, uffi/uffi-loader.lisp: Rename shared library + * db-*/*-loader.lisp: Commit big patch from Edi Weitz to remove + absolute pathnames when searching for foreign libraries. + foreign library loading. + +07 Jun 2005 Kevin Rosenberg <kevin@rosenberg.net> + * Version 3.1.16 + * db-mysql/mysql-api.lisp: Commit patch from Espen Wiborn + to support UTF-8 on sbcl unicode. + +18 May 2005 Kevin Rosenberg <kevin@rosenberg.net> + * Version 3.1.15 + * sql/time.lisp: Fix bug in roll that caused failure in test suite + +17 May 2005 Kevin Rosenberg <kevin@rosenberg.net> + * Version 3.1.14 + * sql/oodml.lisp: Properly handle when db-writer is NIL + +11 May 2005 Kevin Rosenberg <kevin@rosenberg.net> + * sql/expressions.lisp: Avoid using simple-string declaration when + a non-simple string may be encountered. [issue noted by + will@cesmail.net] Add a simple-string declaration for a local + string generated. + +06 May 2005 Kevin Rosenberg <kevin@rosenberg.net> + * sql/oodml.lisp: Change db-writer and db-reader processing to accept + a symbol as well as function to serve as a function designator + [issue noted by will@cesmail.net] + +05 May 2005 Kevin Rosenberg <kevin@rosenberg.net> + * Version 3.1.13 + * sql/time.lisp: Fix error in submitted patch which caused error + in timestrings with 19 or less characters. + +27 Apr 2005 Kevin Rosenberg <kevin@rosenberg.net> + * Version 3.1.12 + * db-postgresql-socket/postgresql-api.lisp: Commit patch from Tim Howe + to fix read-socket-sequence on non-sb-unicode sbcl. + +26 Apr 2005 Kevin Rosenberg <kevin@rosenberg.net> + * Version 3.1.12 + * sql/time.lisp: Commit patch from Daniel Lowe which adds support + for fractional seconds which is required by PostgreSQL + * db-postgresql/postgresql-loader.lisp: Add library path for Windows + +25 Apr 2005 Kevin Rosenberg <kevin@rosenberg.net> + * sql/csql.lisp: Update URL for "SQL for Web Dummies" [Sean Champ] + +24 Apr 2005 Kevin Rosenberg <kevin@rosenberg.net> + * Version 3.1.11 + * sql/syntax: Commit patch from Alan Shields to supress reader + macros when *read-supress* is T. + +13 Apr 2005 Kevin Rosenberg <kevin@rosenberg.net> + * Version 3.1.10 + * db-postgresql-socket/postgresql-socket-api.lisp: Commit patch + from Janis Dzerins to support unicode on SBCL + * sql/syntax: Commit patch from Alan Shields to improve reporting + of invalid syntax statements. + +06 Apr 2005 Kevin Rosenberg <kevin@rosenberg.net> + * Version 3.1.9 + * db-mysql/mysql-sql.lisp: Add port to connection specification + based on patch from Dave Watson + * doc/appendix.xml: Document MySQL port parameter to connection spec + +03 Apr 2005 Kevin Rosenberg <kevin@rosenberg.net> + * Version 3.1.8 + * sql/time.lisp: Patch from Keith James for parsing ISO-8601 timestamps + +18 Mar 2005 Kevin Rosenberg <kevin@rosenberg.net> + * sql/oodml.lisp: Add missing database argument [Patch from + Alan Caulkins] + +03 Mar 2005 Kevin Rosenberg <kevin@rosenberg.net> + * sql/oodml.lisp: Improve database priority in + update-records-from-instance [Patch from Walter C. Pelissero] + +17 Feb 2005 Kevin Rosenberg <kevin@rosenberg.net> + * Version 3.1.7 + * sql/package.lisp: Export database-reconnect from clsql-sys + +08 Feb 2005 Kevin Rosenberg <kevin@rosenberg.net> + * sql/oodml.lisp: Use explicit database in fault-join-target-slot + [Patch from Walter Pelissero] + +29 Jan 2005 Kevin Rosenberg <kevin@rosenberg.net> + * db-postgresql/postgresql-loader.lisp: Add additional + directories to Fink on darwin [patch from Cyrus Harmon]. + +29 Jan 2005 Kevin Rosenberg <kevin@rosenberg.net> + * Version 3.1.6 + * sql/oodml.lisp: Clear view instance cache when delete-instance-records + is invoked [suggested by Alan Shutko]. + * uffi/clsql-uffi-loader.lisp: Improvements for loading with SBCL X86-64 + * sql/metaclasses.lisp: Don't change case of a :base-table string supplied + to def-view-class [fix suggested by Fred Gilham]. + +25 Jan 2005 Kevin Rosenberg <kevin@rosenberg.net> + * tests/*.lisp: Change Vladamir to Vladimir per Cyrus Harmon's + suggestion. + * sql/utils.lisp: Fix unnecessary consing noted by Fred Gilham. + * doc/*.xml: Fix spelling of Vladimir + +24 Jan 2005 Kevin Rosenberg <kevin@rosenberg.net> + * doc/bookinfo.xml, doc/csql.xml, doc/intro.xml: Update links + now that LispWorks is an independant company [noted by + Martin Thornquist] + +22 Jan 2005 Kevin Rosenberg <kevin@rosenberg.net> + * db-sqlite/sqlite-sql.lisp, db-sqlite3/sqlite3-sql.lisp: + Better support for 64 bit environments + +05 Jan 2005 Kevin Rosenberg <kevin@rosenberg.net> + * Version 3.1.5 + * sql/metaclass.lisp: Make t the default value of :set + [noted by Cyrus Harmon] + +28 Dec 2004 Kevin Rosenberg <kevin@rosenberg.net> + * Version 3.1.4 + * uffi/clsql-uffi.lisp: Add support for unsigned integers + * db-mysql/mysql-sql.lisp: Add support for detecting/marking + unsigned integers. Apply patch from Yannick Gingras to + implement database-sequence-last. + +26 Dec 2004 Kevin Rosenberg <kevin@rosenberg.net> + * doc/ref-fdml.lisp: Fix variable tag name to varname + [noted by Eduardo Munoz] + * db-mysql/mysql-loader.lisp: Handle library paths for 64-bit systems + +06 Dec 2004 Kevin Rosenberg <kevin@rosenberg.net> + * Version 3.1.2 + * sql/ooddl.lisp: Accept patch from Klaus Harbo for + update-object-joins. + * sql/metaclass.lisp: Remove unnecssary (and runtime error + causing) change-class invocation when running on CLISP. + * db-mysql/mysql-api.lisp: Commit patch from Paul Werkowski + to fix structure name. + * sql/database.lisp: More specific error message with trying + to use a database value of NIL. + * sql/expressions.lisp: Accept a string for the table name + in (sql-output sql-delete database) [suggested by Ed Symanzik]. + +11 Nov 2004 Kevin Rosenberg <kevin@rosenberg.net> + * Version 3.1.1 + * sql/generic-postgresql.lisp: Commit patch from Chris Capel to + ignore columns which have been dropped. + * clsql-postgresql-socket.asd, db-postgresql-socket/postgresql-socket-package.lisp: + Use sb-md5 package on SBCL, recommended by Chris Capel + +09 Nov 2004 Kevin Rosenberg <kevin@rosenberg.net> + * Version 3.1.0 released: New SQLite3 backend by Aurelio Bignoli + * doc/appendix.xml: Document SQLITE3 backend, patch by Aurelio Bignoli + * sql/operations.lisp: Add lower and upper SQL functions [Daniel Lowe]. + +08 Nov 2004 Kevin Rosenberg <kevin@rosenberg.net> + * sql/expressions.lisp: Fix slot name [thanks to Daniel Lowe] + +31 Oct 2004 Kevin Rosenberg <kevin@rosenberg.net> + * clsql-sqlite3, db-sqlite3/*: NEW BACKEND + contributed by Aurelio Bignoli + +23 Oct 2004 Kevin Rosenberg <kevin@rosenberg.net> + * sql/oodml.lisp: Commit patch from Walter Pelis + to use an object's database for a select on its slot. + +20 Oct 2004 Kevin Rosenberg <kevin@rosenberg.net> + * uffi/uffi.c, uffi/clsql-uffi.lisp: Commit patch from + Aurelio Bignoli to fix negative 64-bit integers + +07 Oct 2004 Kevin Rosenberg <kevin@rosenberg.net> + * db-mysql/mysql.c: Fix parameters in bind_param call + +07 Oct 2004 Kevin Rosenberg <kevin@rosenberg.net> + * uffi/clsql-uffi.lisp: Add support for :blob result-type + * db-mysql/mysql-sql.lisp: Add support for :blob + result-type + +04 Oct 2004 Kevin Rosenberg <kevin@rosenberg.net> + * db-mysql/mysql-sql.lisp, db-db2/db2-sql.lisp: Add + missing quotes for types in code that is still in development + (thanks to Joerg Hoehle) + +03 Oct 2004 Kevin Rosenberg <kevin@rosenberg.net> + * Version 3.0.8 released + * db-sqlite/sqlite-*.lisp: Apply patch from + Aurelio Bignoli with improvements + +01 Oct 2004 Kevin Rosenberg <kevin@rosenberg.net> + * multiple: Apply patch from Joerg Hoehle with multiple + improvements. + +01 Oct 2004 Kevin Rosenberg <kevin@rosenberg.net> + * Version 3.0.7 released + * sql/oodml.lisp, sql/package.lisp, db-mysql/mysql-objects.lisp: + Add support for mediumint. + * sql/metaclass.lisp: Rework CLISP MOP handling + * sql/ooddl.lisp: Work-around to have CLISP finalize standard-db-class + +28 Sep 2004 Kevin Rosenberg <kevin@rosenberg.net> + * sql/metaclass.lisp: Support CLISP's attribute name + for the type field in direct class slots + +27 Sep 2004 Kevin Rosenberg <kevin@rosenberg.net> + * Version 3.0.6 released + * BUGS: New file. Document suspected SIGPIPE + interaction between SBCL and libpq used in + postgresql backend. + * doc/ref-fdml.lisp: Document the :caching and :refresh + keywords of the SELECT function. + * doc/ref-ooddml.lisp: Document the new *default-caching* + variable. + * sql/package.lisp: Export *default-caching* + * sql/oodml.lisp: Use *default-caching* to + control default caching behavior. + +21 Sep 2004 Kevin Rosenberg <kevin@rosenberg.net> + * Version 3.0.5 release + * doc/appendix.xml: Add note about loading Oracle8 version + * db-oracle/oracle-loader.lisp: Support Oracle8 based on + data from David Young. + +10 Sep 2004 Kevin Rosenberg <kevin@rosenberg.net> + * doc/Makefile, doc/catalog-darwin.xml: Apply + patch from Cyrus Harmon for building docs on Mac OS X + * sql/package.lisp: Add new (pre-release) clisp MOP package + +09 Sep 2004 Kevin Rosenberg <kevin@rosenberg.net> + * Version 3.0.4 Release + * multiple: Remove superfluous quotes in UFFI def-type + and def-foreign-type forms. + +07 Sep 2004 Kevin Rosenberg <kevin@rosenberg.net> + * Version 3.0.3 Release + * db-postgresql-socket/postgresql-socket-api.lisp: Commit patch + from Tagore Smith to call force-output after sending authentication + * db-odbc/odbc-api.lisp: Move ODBC v3 conversons + * db-odbc/odbc-sql.lisp: Load mysql or postgresql package when connecting + to a database of that type so that functions that indicate capabilities of + database are available. + +02 Sep 2004 Kevin Rosenberg <kevin@rosenberg.net> + * db-odbc/odbc-api.lisp: More conversions to ODBC v3 + +02 Sep 2004 Kevin Rosenberg <kevin@rosenberg.net> + * Version 3.0.2 Release + * TODO: Add note about ODBC on Windows + * db-odbc/odbc-loader.lisp: Add /winnt/system32/ to + search directories + * db-odbc/odbc-ff-interface.lisp: Change the return type + of SQLSetEnvAttr to :short + +02 Sep 2004 Marcus Pearce <m.t.pearce@city.ac.uk> + * examples/clsql-tutorial.lisp: added missing initarg for the COMPANYID + slot of the employee View Class definition [reported by Franz Deuzer]. + +01 Sep 2004 Kevin Rosenberg <kevin@rosenberg.net> + * Version 3.0.1 Release + * tests/test-init.lisp: Add second join class to employee-address + to test a class with two join slots. + * sql/oodml.lisp: Fix find-all function for a class with multiple + join slots + * TODO: Remove need to test/fix multiple join classes + +27 Aug 2004 Kevin Rosenberg <kevin@rosenberg.net> + * db-mysql/Makefile, db-mysql/mysql-loader.lisp: accept patch + from Jon Buffington for file locations on Darwin. + +17 Aug 2004 Kevin Rosenberg <kevin@rosenberg.net> + * sql/db-interface.lisp: Improve messages when functions + are passed a database object, but the method is not specialized + for that database type. + * sql/metaclasses.lisp: Fix inline declaration (reported by + Cyrus Harmon) + +14 Aug 2004 Kevin Rosenberg <kevin@rosenberg.net> + * TODO: Add bug report about SQL generation with a table + containing two join slots. + * sql/oodml.lisp: Add optional size to VARCHAR type + +3 Aug 2004 Kevin Rosenberg <kevin@rosenberg.net> + * Version 3.0.0 Release + * sql/expressions.lisp: Change declaration that + caused error on openmcl + * db-aodbc/aodbc-sql.lisp: Fix storage location + of odbc connection. Specialize database-query since + dbi's :types keyword is different than generic-odbc's + :result-types keyword + * sql/db-interface.lisp: Add warnings for methods + not specialized by a db backends + * tests/test-fddl.lisp: Fix case of symbols to support + case-sensitive Allegro + * db-oracle/oracle-sql.lisp: Rework errbuf in handle-oci-error + * tests/test-init.lisp: Note that odbc driver for postgresql + doesn't properly handle table ownership + * LATEST-TEST-RESULTS: update with version 3.0.0 + +1 Aug 2004 Marcus Pearce <m.t.pearce@city.ac.uk> + * sql/expressions.lisp: conditionalise escaping of backslash in + generated SQL strings on backend. + * tests/test-fdml.lisp: test for escaping of backslash. + * sql/oodml.lisp: minor tidying in FIND-ALL. + +26 Jul 2004 Kevin Rosenberg <kevin@rosenberg.net> + * NEWS: Initial 3.0 announcement draft + * README: Expand acknowledgements of incorporated projects + * CONTRIBUTORS: Further document Marcus Pearce contributions + +23 Jul 2004 Marcus Pearce <m.t.pearce@city.ac.uk> + * sql/oodml.lisp: add DATABASE-OUTPUT-SQL-AS-TYPE method specialisation + to print floats with the exponent markers removed. + * tests/test-oodml.lisp: add tests for updating records with floats. + +22 Jul 2004 Marcus Pearce <m.t.pearce@city.ac.uk> + * db-oracle/oracle-sql.lisp: enable :OWNER :ALL in DATABASE-LIST-* for + CommonSQL compatibility. + * tests/test-init.lisp: skip test :FDDL/TABLE/6 on Oracle since + this column constraint syntax is not supported. + * tests/test-fddl.lisp: change column indexed in test :FDDL/INDEXES/2 + from EMPLID to LAST_NAME since Oracle complains that EMPLID is already + indexed. + +17 Jul 2004 Marcus Pearce <m.t.pearce@city.ac.uk> + * doc/ref-fdml.xml: document CACHE-TABLE-QUERIES. + * tests/test-fdml.xml: add test for CACHE-TABLE-QUERIES. + * doc/ref-ooddl.xml: minor changes to syntax and examples entries + for uniformity. + * doc/ref-oodml.xml: add examples for OODML. + * sql/oodml.lisp: ensure SELECT passes on its REFRESH argument + to FIND-ALL. + * sql/metaclasses.lisp: update docstrings. + * tests/test-init.lisp: change :db-constraints for emplid to + (:not-null :unique) as a temporary test for multiple column constraints + in DEF-VIEW-CLASS. + * tests/test-oodml.lisp: add tests for *DB-AUTO-SYNC* and + return type of (SETF SLOT-VALUE-USING-CLASS). + * TODO, doc/TODO: remove items done. + * README: fix typo. + +16 Jul 2004 Marcus Pearce <m.t.pearce@city.ac.uk> + * sql/oodml.lisp: on Lispworks, use weak valued hash tables for + object caching. + * sql/expressions.lisp: Fix SQL generation for the symbol NIL. + +16 Jul 2004 Marcus Pearce <m.t.pearce@city.ac.uk> + * sql/expressions.lisp: reactivate caching of generated SQL strings. + Move methods for DATABASE-OUTPUT-SQL, OUTPUT-SQL and SQL-HASH-KEY + here from sql/fdml.lisp. Rationalise behaviour of SQL-OUTPUT, + OUTPUT-SQL and DATABASE-OUTPUT-SQL. + * sql/fdml.lisp: remove disabled method ADD-STORAGE-CLASS. Move + methods for DATABASE-OUTPUT-SQL, OUTPUT-SQL and SQL-HASH-KEY to + sql/expressions.lisp. + * sql/ooddl.lisp: replace call to DATABASE-OUTPUT-SQL in + DATABASE-PKEY-CONSTRAINT with call to SQL-OUTPUT. + * sql/generics.lisp: add docstrings. + +15 Jul 2004 Kevin Rosenberg <kevin@rosenberg.net> + * Version 2.11.16 + * db-oracle/oracle-sql.lisp: Remove OpenMCL specific + code in favor of fixing UFFI with James Bielman's patch + +14 Jul 2004 Kevin Rosenberg <kevin@rosenberg.net> + * Version 2.11.15 + * db-oracle/oracle-sql.lisp: Apply patch for OpenMCL/OSX + from James Bielman + +14 Jul 2004 Marcus Pearce <m.t.pearce@city.ac.uk> + * README, INSTALL: update URLs. Minor updates to descriptions. + * tests/README: remove stuff about editing contexts. + +12 Jul 2004 Kevin Rosenberg <kevin@rosenberg.net> + * db-oracle/oracle-objects.lisp: Change *default-varchar-length* to + *default-string-length* + +12 Jul 2004 Marcus Pearce <m.t.pearce@city.ac.uk> + * tests/test-syntax.lisp, tests/test-fdml.lisp: add tests for escaping + of single quotes. + * tests/test-fddl.lisp: add tests for column and table constraints + in CREATE-TABLE. Add test for OWNER keyword parameter to + LIST-TABLES (assuming same underlying machinery in other FDDL + functions). + * tests/test-init.lisp: restrict above test to postgresql and oracle. + +12 Jul 2004 Kevin Rosenberg <kevin@rosenberg.net> + * db-sqlite/sqlite-sql.lisp: Fix condition as reported by Aurelio + Bignoli. + +11 Jul 2004 Kevin Rosenberg <kevin@rosenberg.net> + * sql/oodml.lisp, sql/package.lisp, doc/ref-ooddl.lisp, db-mysql/mysql-objects.lisp: Add tinyint type + +10 Jul 2004 Kevin Rosenberg <kevin@rosenberg.net> + * Version 2.11.14 + * doc/*.xml: documentation additionals and fixes so + that docbook passes xmllint. + +9 Jul 2004 Kevin Rosenberg <kevin@rosenberg.net> + * Version 2.11.13 + * sql/fdml.lisp: Apply patch from Kim Minh Kaplan + to change escaping of single quotes. Mild optimizations + for escaped string output. + * doc/ref-ooddl.lisp: documentation additions + * doc/ref-oodml.lisp: Add purpose to functions + * TODO: Add need to test single quote escaping + +7 Jul 2004 Kevin Rosenberg <kevin@rosenberg.net> + * doc/ref-ooddl.xml, doc-ref-oodml.xml: documentation additions + * sql/ooddl.lisp: Added SMALLINT type + * sql/generic-postgresql.lisp: Added INT2 as SMALLINT type + * db-mysql/mysql-objects.lisp: Added SMALLINT type + * sql/package.lisp: Export SMALLINT + * sql/expressions.lisp: Add MYSQL's UNSIGNED and ZEROFILL as + db-constraints + +6 Jul 2004 Marcus Pearce <m.t.pearce@city.ac.uk> + * sql/expressions.lisp: add AUTO-INCREMENT and UNIQUE to the + recognised column constraints for CREATE-TABLE and the :DB-CONSTRAINTS + View Class slot option. + * sql/ooddl.lisp: fix bug preventing the :DB-CONSTRAINTS View Class + slot option accepting a list of constraints [reported by Travis Cross]. + * doc/ref-fddl.xml: add some examples of specifying column and + table constraints to the documentation for CREATE-TABLE. + * TODO: add note about adding tests for table/column constraints. Add + optimisation note about using cached attribute types in insert/update + operations. + +3 Jul 2004 Marcus Pearce <m.t.pearce@city.ac.uk> + * doc/appendix.xml: add notes about idiosyncrasies/unsupported + features and so on the documentation for each backend. + * doc/TODO: remove items done. + * doc/ref-transaction.xml: add note in introduction about + autocommit mode as a difference from CommonSQL. + * doc/ref-syntax.xml: add notes about SQL syntax state functions + being macros in CLSQL. Add note about SQL operators which are + CLSQL extensions. + +2 Jul 2004 Marcus Pearce <m.t.pearce@city.ac.uk> + * Version 2.11.12 released + * doc/ref-recording.xml: document SQL I/O recording. + * doc/ref-prepared.xml: new file for documenting prepared statements. + * doc/clsql.xml: comment out include for large object and CLSQL-SYS + documentation. + * doc/ref-conditions.xml: complete documentation of condition system. + * doc/global-index.xml: add symbols from condition system and remove + those from LOB and prepared statement APIs. + * doc/ref-fdml.xml: complete documentation of FDML. + * doc/glossary.xml: add View Class. + * doc/TODO: remove items done. + * sql/conditions.lisp: make SQL-CONDITION a parent of SQL-ERROR. + * sql/package.lisp: remove FOR-EACH-ROW from exports list. Export + additional slot accessors for condition classes. + +1 Jul 2004 Kevin Rosenberg <kevin@rosenberg.net> + * doc/ref-ooddl.lisp: Add documentation + * doc/ooddl.lisp: Move *DEFAULT-VARCHAR-LENGTH* from oodml.lisp + and rename to *DEFAULT-STRING-LENGTH*. Add docstring. + * doc/oodml.lisp: Rename references to new name of + *DEFAULT-STRING-LENGTH* + +1 Jul 2004 Marcus Pearce <m.t.pearce@city.ac.uk> + * doc/ref-transaction.xml: document transaction handling. + * sql/transaction.lisp: ensure that COMMIT, ROLLBACK and + START-TRANSACTION return NIL as per the CommonSQL spec. Modify + ADD-TRANSACTION-{ROLLBACK|COMMIT}-HOOK such that a database is + passed as a keyword argument defaulting to *DEFAULT-DATABASE*. + Added docstrings. + +30 Jun 2004 Marcus Pearce <m.t.pearce@city.ac.uk> + * doc/ref-fdml.xml: document the FDML. + * doc/ref-fddl.xml: move documentation for TRUNCATE-DATABASE here. + * sql/ooddl.lisp: moved *default-varchar-length* to here from + oodml.lisp and renamed to *default-string-length* + +23 Jun 2004 Kevin Rosenberg <kevin@rosenberg.net> + * sql/oodml.lisp: Add keyword :transactions to def-view-from-class + to allow specifying transactionless table creation + * doc/ref-oodml.lisp: Add new keyword to signature of + DEF-VIEW-FROM-CLASS + +18 Jun 2004 Marcus Pearce <m.t.pearce@city.ac.uk> + * Version 2.11.11 + * sql/expressions.lisp: when removing duplicate table identifiers + in the FROM clause of a query, check both table name and alias + are equivalent. + * sql/fdml.lisp: remove DESCRIBE-TABLE. + * sql/db-interface.lisp: remove generics DESCRIBE-TABLE and + DATABASE-DESCRIBE-TABLE. + * sql/package.lisp: remove DESCRIBE-TABLE, DATABASE-DESCRIBE-TABLE + and LIST-TABLE-INDEXES. + * sql/generic-postgresql.lisp: add reader conditional #+nil for + DATABASE-DESCRIBE-TABLE and comment about its uses for + re-implementing LIST-ATTRIBUTE-TYPES with a single SQL query + returning type info for all attributes. + Fix DATABASE-SEQUENCE-LAST. + * sql/fddl.lisp: remove LIST-TABLE-INDEXES and redefine + LIST-INDEXES with additional keyword parameter :ON. + * tests/test-fddl.lisp: replace LIST-TABLE-INDEXES in :fddl/index/3 + with LIST-INDEXES (with :ON parameter). + * doc/global-index.xml: remove DESCRIBE-TABLE and LIST-TABLE-INDEXES. + * doc/ref-connect.xml: minor tidying. + * doc/ref-fddl.xml: document the FDDL. + * doc/TODO: removed items done. Moved note about transaction handling + from TODO to here. + * TODO: move note about transaction handling to doc/TODO. Added + optimization note about LIST-ATTRIBUTE-TYPES and LIST-INDEXES. + +13 Jun 2004 Marcus Pearce <m.t.pearce@city.ac.uk> + * Version 2.11.10 + * sql/syntax.lisp: updated docstrings. + * sql/package.lisp: exported DATABASE-NAME-FROM-SPEC from CLSQL + package. + * sql/database.lisp: add docstrings for CREATE-DATABASE, + DESTROY-DATABASE, TRUNCATE-DATABASE and LIST-DATABASES. Replace + CLSQL-GENERIC-ERROR signalled in RECONNECT with SQL-CONNECTION-ERROR. + * doc/ref-syntax.xml, doc/global-index.xml: minor tidying. + * doc/ref-connect.xml: document connection/initialisation. + * doc/ref-fdml.xml: move TRUNCATE-DATABASE reference entry here. + * doc/TODO: remove items done. + * Makefile: add db-oracle to to SUBDIRS. + +13 Jun 2004 Kevin Rosenberg <kevin@rosenberg.net> + * sql/oodml.lisp: Add new serialization functions: + WRITE-INSTANCE-TO-STREAM and READ-INSTANCE-FROM-STREAM + * sql/expressions.lisp: Avoid duplicate FROM names when selecting + from a table that has more than one primary index. + * sql/conditions.lisp: Fix printing of closed-database error + +13 Jun 2004 Kevin Rosenberg <kevin@rosenberg.net> + * Version 2.11.9 + * sql/conditions.lisp: Set initial slot value for message in SQL-WARNING + * sql/transactions.lisp: Correctly set slots of SQL-WARNING + +12 Jun 2004 Marcus Pearce <m.t.pearce@city.ac.uk> + * sql/package.lisp: export DATABASE-TYPE from CLSQL and subclasses + of SQL-EXPRESSION from CLSQL-SYS. + * sql/syntax.lisp: make error signalled in SQL-OPERATION an + SQL-USER-ERROR. Make SQL-OPERATOR return just one value. + * doc/Makefile: added Mandrake linux. + * doc/catalog-redhat.xml, doc/catalog-mandrake.xml: new files. + * doc/appendix.xml: fixed little typo (adsf). + * doc/glossary.xml: removed closed-database and note about + sql-expression, added some entries. + * doc/ref-syntax.xml: documented the symbolic SQL syntax. + +10 Jun 2004 Kevin Rosenberg <kevin@rosenberg.net> + * Version 2.11.8 + * db-mysql/mysql-loader.lisp: Remove load of unnecessary zlib library + * multiple: Add generalized-boolean type as requested by + Edi Weitz + * TODO: Added need for test of generalized-boolean + +9 Jun 2004 Kevin Rosenberg <kevin@rosenberg.net> + * Version 2.11.7 released + * uffi/clsql-uffi-loader.lisp: Apply patch from Edi Weitz + for loading with clc-register-user-package. Remove personal + directory from path lisp. + * db-mysql/mysql-loader.lisp: Similar changes + +8 Jun 2004 Kevin Rosenberg <kevin@rosenberg.net> + * Version 2.11.6 released + * sql/oodml.lisp: Commit patch from Edi Weitz + to fix symbol writing/reading + * TODO: Add need for symbol slot test + +7 Jun 2004 Marcus Pearce <m.t.pearce@city.ac.uk> + * sql/package.lisp: remove duplicate export of + *CACHE-TABLE-QUERIES-DEFAULT*. + * doc/ref-*.xml, doc/global-index.xml: new files documenting + the CommonSQL compatible api. + * tests/test-fdml.lisp: modified the test :fdml/transaction/3 to + reflect changes in return values of WITH-TRANSACTION. + +04 Jun 2004 Kevin Rosenberg <kevin@rosenberg.net> + * tests/README: Fix filename [reported by Bill Clementson] + * sql/transactions.lisp: Apply return value patch from + Edi Weitz for WITH-TRANSACTION + * tests/README: Remove ptester package requirement (as noted + by Bill Clementson) + +03 Jun 2004 Kevin Rosenberg <kevin@rosenberg.net> + * Version 2.11.5 released + * examples/clsql-tutorial.lisp: Remove obsolete :nulls-ok attribute, + Select connection-spec based on connection type. Bugs reported by + Bill Clementson. + * uffi/uffi.dll, uffi/uffi.lib: Recompile with Visual Studio 2003 + * db-mysql/mysql-loader.lisp: Update check for zlibwapi library + name on Windows, add \bin\ directory to search path + +31 May 2004 Marcus Pearce <m.t.pearce@city.ac.uk> + * db-odbc/odbc-sql.lisp: DB-TYPE replaced with DATABASE-TYPE in + DATABASE-CONNECT. + * sql/operations.lisp: substr now generates SUBSTR for use on + Oracle; added a new operator SUBSTRING for use elsewhere. minus + now generates MINUS for use on Oracle. Nvl signals an error if + not called with exactly 2 arguments. Add concat function for use + instead of the || operator on MySQL and Oracle. + * sql/syntax.lisp: changed internal symbol for the || operator to + CONCAT-OP. + * sql/expressions.lisp: removed redundant and unused functions + GENERATE-SQL (cf. SQL-OUTPUT) and DATABASE-CONSTRAINT-DESCRIPTION + (cf. MAKE-CONSTRAINTS-DESCRIPTION). + * sql/generics.lisp: removed generic function for + DATABASE-CONSTRAINT-DESCRIPTION (see above). + * tests/test-syntax.lisp: modified/added tests according to changes + in sql/operations.lisp. + * tests/test-fdml.lisp: changed SUBSTR to SUBSTRING in test + :fdml/select/21. + * sql/package.lisp: added the operators SQL-SUBSTRING, SQL-CONCAT-OP + and SQL-USERENV to the shared exports list. Removed + ROLLBACK-TRANSACTION, COMMIT-TRANSACTION, DATABASE-START-TRANSACTION, + DATABASE-ABORT-TRANSACTION, DATABASE-COMMIT-TRANSACTION, + TRANSACTION-LEVEL, TRANSACTION, RECORD-SQL-COMMAND and + RECORD-SQL-RESULT from shared exports list. + +30 May 2004 Kevin Rosenberg <kevin@rosenberg.net> + * db-postgresql/postgresl-sql.lisp: Avoid computing + result-types lisp when nil result-types. Return only + one value when field-types nil. + * db-mysql/mysql-sql.lisp: Simple queries now + working with prepared statements. + +30 May 2004 Kevin Rosenberg <kevin@rosenberg.net> + * Version 2.11.4: MySQL 4.1 now passes all tests + * sql/package.lisp: Add API for prepared statments. + * sql/fdml.lisp: Change implicit flatp processing + for string map-query for greater CommonSQL conformance. + Add high-high API for prepared statements. + * tests/test-basic.lisp: Add test for map-query and + single argument. + * sql/transactions.lisp: Change name/semantics of + autocommit to set-autocommit. + * sql/generic-postgresql.lisp: Add support for + prepared statements. + * tests/test-internal.lisp: New file + * sql/odbc-api.lisp: Update to using ODBC V3 protocol + * clsql-mysql.asd, clsql-uffi.asd: Remove check and Common Lisp + Controller invocation. + * db-mysql/mysql-api.lisp: Add support for MySQL 4.1 field structure + * sql/expressions.lisp: Avoid emitting double parenthesis when a + function contains a subselect. + +27 May 2004 Kevin Rosenberg <kevin@rosenberg.net> + * Version 2.11.3 + * sql/ooddl.lisp: Commit patch from Edi Weitz fixing return + type (setf slot-value-using-class) + * TODO: add not that need a test case for the above fix + * db-sqlite: Remove clisp support since clisp can not run CLSQL + with its MOP usage + * db-oracle/oracle-sql.lisp: By default, use OCIEnvCreate as + introduced in Oracle8. Leave older code selectable by a reader macro + for Oracle7 and prior. Avoid use of OCIServerAttach since CLSQL + uses OCILogon and does not the more complex session management. + +26 May 2004 Kevin Rosenberg <kevin@rosenberg.net> + * sql/oodml.lisp: Commit universal-time typo patch from Edi Weitz + * test/test-init.lisp: Add universal-time slot to person. + * test/test-fddl.lisp: Add tests of universal-time slot + * test/test-ooddl.lisp: Test universal-time slot in an object + * TODO: Remove need for universal-time test + * debian/rules, debian/control: Add cl-sql-oracle binary package + * doc/appendix.xml: Add Oracle backend information + * db-oracle/oracle-objects.lisp: Add database-get-type-specifier for + universal-time. Convert BIGINT CLSQL type to CHAR SQL type + * db-mysql/mysql-sql.lisp: Fix condition name to sql-connection-error + * doc/ref-clsql.xml: Renamed from ref_clsql.xml. Change the documentation + for map-query to reflect changed in arguments to be CommonSQL compatible. + Updated old clsql conditions to new CommonSQL compatible conditions. + +25 May 2004 Kevin Rosenberg <kevin@rosenberg.net> + * sql/oodml.lisp: (string n) now produces a CHAR field. Add new VARCHAR + type. Added *default-varchar-length* rather than previous hard-coded + varchar length. Remove 'simple-string and 'simple-base-string since they + are subtypes of 'string. + * db-oracle/oracle-sql.lisp: Use *default-varchar-length* rather than + local hard-coded value. + * sql/metaclasses.lisp: Convert specified type VARCHAR and (VARCHAR n) to Lisp + type string. Convert specified-type (CHAR n) to string. Convert specified-type + CHAR to lisp type character. + * sql/generic-postgresql.lisp: (string n) => (CHAR n) + * sql/operations.lisp: Add userenv + * doc/TODO: Add AUTOCOMMIT. Remove need for large table and bigint + slot tests + * sql/oracle-sql.lisp: Add 64-bit bigint direct conversion + * uffi/clsql-uffi.lisp: Handle signed 64-bit integers + * test/test-init.lisp: Add large table with bigint slot + +25 May 2004 Kevin Rosenberg <kevin@rosenberg.net> + * Version 2.11.1 released: Much simpler Oracle client library loading. + Now uses ORACLE_HOME environmental variable as well as tests default + path for Oracle Instant Client. + +25 May 2004 Kevin Rosenberg <kevin@rosenberg.net> + * Version 2.11.0 released: Full Oracle support. All tests pass + * db-oracle/oracle-sql.lisp: Add declaration so that SBCL runs efficiently. + * tests/test-init.lisp: capitalize odbc backend name in banner + * CONTRIBUTORS: Add note about Marcus' excellent work + * sql/oodml.lisp: Removed old stub function + * clsql.asd: Use module names in current package rather than keyword package + * db-oracle/oracle-sql.lisp: Don't trim trailing spaces. Prevent interrupts + in setting sequence position. Make autocommits more efficient. + * tests/test-init.lisp: Skip 2 tests on Oracle which have unsupported syntax + * sql/oodml.lisp: Get rid of undocumented raw-string type. CommonSQL + strings are raw (non-trimmed trailing whitespace). Add database-get-type-specifier + and read-sql-value for NUMBER and CHAR. + * sql/base-classes.lisp: Add autocommit slot + * sql/transaction.lisp: Added autocommit processing, mild cleaning. + * doc/intro.xml: Add Oracle + +24 May 2004: Marcus Pearce (m.t.pearce@city.ac.uk) + * db-postgresql-socket/postgresql-socket-sql.lisp: replace + CLSQL-SIMPLE-WARNING with SQL-WARNING. + * db-sqlite/sqlite-sql.lisp: replace CLSQL-SIMPLE-WARNING with + SQL-WARNING. + * db-aodbc/aodbc-sql.lisp: replace CLSQL-ERROR with SQL-ERROR. + * clsql.asd: reworked module structure in package definition and + file names to better reflect component functionality. + * sql/package.lisp: added SQL-FATAL-ERROR and SQL-TIMEOUT-ERROR to + exports list. Removed duplicate and obsolete exports. Exported + remaining SQL operations: SQL-SOME, SQL-<>, SQL-BETWEEN, SQL-DISTINCT, + SQL-NVL and SQL-FUNCTION. Organised exports by functionality/file and + according to whether they are specified by CommonSQL or CLSQL + extensions. + * sql/transaction.lisp: replace CLSQL-SIMPLE-WARNING with + SQL-WARNING. + * sql/generics.lisp: moved generics for QUERY and EXECUTE-COMMAND + here from basic-sql.lisp. + * sql/expressions.lisp: NEW FILE: renamed from classes.lisp (deleted). + * sql/fddl.lisp: NEW FILE: renamed from table.lisp (deleted). + * sql/fdml.lisp: NEW FILE: merger of basic-sql.lisp and sql.lisp + (both deleted). + * sql/ooddl.lisp: NEW FILE: ooddl from objects.lisp (deleted). + * sql/oodml.lisp: NEW FILE: oodml from objects.lisp (deleted). + +23 May 2004 Kevin Rosenberg <kevin@rosenberg.net> + * Version 2.10.22 released + * sql/kmr-mop.lisp, sql/objects.lisp: Since SBCL is the only implementation that + has reversed class slots, change the default for ordered-class-slots so that slots + are now in the same order an in the def-view-class. + * sql/sql.lisp: Honor case of string table identifier to INSERT-RECORDS + * test/test-fddl.lisp: Add two tests for mixed case names + * db-oracle/oracle-sql.lisp: Add missing database qualifier. Return NUMBER (double) + for computed fields, this will require some adjustment to the test suite which + in many cases expects integers. + * test/test-fdml.lisp: Accomodate that Oracle returns doubles for computed columns + +22 May 2004 Kevin Rosenberg <kevin@rosenberg.net> + * Version 2.10.21 released + * sql/sequences.lisp: Move generic sequence functions here from db-sqlite, + db-odbc, and db-aodbc. + * sql/*.lisp: Add db-type parameter to generic functions READ-SQL-VALUE, + DATABASE-GET-TYPE-SPECIFIER, and OUTPUT-SQL-VALUE-AS-TYPE. Update methods to use these. + * sql/generic-postgresql.lisp, sql/generic-odbc.lisp: New files + * db-odbc/odbc-sql.lisp, db-aodbc/aodbc-sql.lisp: Move common code to + sql/generic-odbc.lisp + * db-postgresql/postgresql-sql.lisp, db-postgresql-socket/postgresql-socket-sql.lisp: + Move common code to sql/generic-postgresql.lisp + * sql/classes.lisp: honor case of string tables when outputting queries + * sql/objects.lisp: Add database type to default database-get-type-specifier method + * sql/sql.lisp: Add database type to default database-abort-transaction method + * db-mysql/mysql-objects.lisp: New file + * sql/objects.lisp: Move MySQL specific code to mysql-objects.lisp + * sql/utils.lisp: Add GETENV function which will be used to get ORACLE_HOME + from environment + * test/test-fdml.lisp: String table names are now case sensitive, so convert to + default db case for FDML/SELECT/25 + +22 May 2004 Kevin Rosenberg + * Version 2.10.20 released: Oracle backend now fails 6 out of 200 tests + * TODO: Added 2 variances from CommonSQL. Add tests for owner phrases + and string identifiers with non-default case + * sql/table.lisp: Don't convert string table name to a symbol. + * sql/classes.lisp: Honor case of string identifiers + * sql/sql.lisp: Ensure recyclebin is purged for Oracle in + TRUNCATE-DATABASE + * db-oracle/oracle-sql.lisp: Add sequence functions, fix use of + of owner phrases. Obtain server and client versions. + * db-oracle/oracle-objects.lisp: Fix type specifiers + * tests/test-fddl.lisp: Allow :varchar2 and :number as data types + * tests/test-init.lisp: Properly get username from Oracle connection-spec + +22 May 2004 Marcus Pearce (m.t.pearce@city.ac.uk) + * sql/generics.lisp: reworked docstrings. Remove generics for + ADD-TO-RELATION and REMOVE-FROM-RELATION. + * sql/objects.lisp: reworked docstrings. Changed UPDATE-OBJECT-JOINS + to UPDATE-OBJECTS-JOINS for CommonSQL compatibility. + * sql/package.lisp: Changed UPDATE-OBJECT-JOINS to UPDATE-OBJECTS-JOINS + for CommonSQL compatibility. Remove ADD-TO-RELATION and + REMOVE-FROM-RELATION. + * tests/test-oodml.lisp: Changed UPDATE-OBJECT-JOINS to + UPDATE-OBJECTS-JOINS for CommonSQL compatibility. + * doc/TODO: added notes about extra slot options to DEF-VIEW-CLASS. + * sql/conditions.lisp: add documentation for conditions. Add + SQL-TIMEOUT-ERROR and SQL-FATAL-ERROR for CommonSQL compatibility. + +21 May 2004 Marcus Pearce (m.t.pearce@city.ac.uk) + * sql/basic-sql.lisp: reworked docstrings. + * sql/transactions.lisp: reworked docstrings. + * sql/sql.lisp: reworked docstrings. + * sql/initialize.lisp: reworked docstrings. INITIALIZE-DATABASE-TYPE + sets *DEFAULT-DATABASE-TYPE* for CommonSQL compatibility. + * sql/database.lisp: reworked docstrings. + * doc/TODO: added notes about START-TRANSACTION and IN-TRANSACTION-P + and FDML extensions and database extensions. + +20 May 2004 Kevin Rosenberg (kevin@rosenberg.net) + * db-oracle/oracle-sql: Use clsql-specific error conditions. Use owner keyword. + * db-oracle/make9.sh: add makefile for building with Oracle 9 client + libraries + * sql/table.lisp: Add logic for dealing with Oracle 10g vs. previous + Oracle versions with the PURGE option required for drop table. This needs + to be converted to a generic function and moved to db-oracle/oracle-sql.lisp + +20 May 2004 Marcus Pearce (m.t.pearce@city.ac.uk) + * sql/classes.lisp: remove unused PARAMS slot in SQL-IDENT-ATTRIBUTE. + * sql/syntax.lisp: remove unused PARAMS keyword arg to SQL-EXPRESSION. + * sql/table.lisp: reworked docstrings. + * sql/objects.lisp: moved *default-update-objects-max-len* here from + table.lisp. + * doc/TODO: notes about :if-does-not-exist arg to DROP-TABLE, + DROP-VIEW and DROP-INDEX and the use of the :transactions and + :constraints keyword args to CREATE-TABLE. + * sql/classes.lisp: the DESCRIPTION argument to CREATE-TABLE is now + CommonSQL compatible with respect to column constraints. + +20 May 2004 Kevin Rosenberg (kevin@rosenberg.net) + * sql/oracle-sql.lisp: Now compiles and runs on SBCL. + Requires UFFI 1.5.0 or higher + +20 May 2004 Kevin Rosenberg (kevin@rosenberg.net) + * Version 2.10.19 + * sql/conditions.lisp: Fix cerror + +19 May 2004 Kevin Rosenberg (kevin@rosenberg.net) + * Version 2.10.18 released: New condition hierarchy to be compatible + with CommonSQL -- not backward compatible with previous CLSQL. + * sql/db-interface.lisp: Add more default methods + * sql/objects.lisp: Add explicit table name to order-by parameters + in find-all when only one table to avoid selecting a duplicate row. + Fix error in FIND-ALL when using :order-by such as (([foo] :asc)) + as previous logic was adding two fields (foo asc) to SELECT query. + Make :result-types :auto be the default for object selections. + Properly handle caching key when using multiple order-by with asc/desc + directions. + * db-oracle/*.lisp: Much improvements, now passes 90% of test suite + +19 May 2004 Marcus Pearce (m.t.pearce@city.ac.uk) + * sql/recording.lisp: reworked docstrings. + * sql/syntax.lisp: reworked docstrings. + * doc/TODO: added notes about extensions to SQL-RECORDING-P and the + SQL syntax state functions being macros. + +19 May 2004 Kevin Rosenberg (kevin@rosenberg.net) + * sql/package.lisp: Export initialize-database-type and + *initialize-database-types* from CLSQL package. + * sql/conditions.lisp: Add new CommonSQL compatible conditions, + remove old CLSQL conditions. + * sql/loop-extensions.lisp: Make errors of type sql-user-error + * */*.lisp: Convert to from old to new conditions + +18 May 2004 Kevin Rosenberg (kevin@rosenberg.net) + * sql/table.lisp: Add PURGE to drop command for oracle 10g backend. + To handle this difference, will need to add a new database-drop-table + generic function. + * db-oracle/oracle-sql.lisp: Move server-version and + major-version-number to database object to allow multiple connections + to Oracle servers of different versions. + +18 May 2004 Marcus Pearce (m.t.pearce@city.ac.uk) + * TODO: moved notes about backends to doc/TODO. + * doc/TODO: added notes about backends and select extensions. + * sql/base-classes.lisp: remove obsolete schema slot in database + class. + +16 May 2004 Kevin Rosenberg (kevin@rosenberg.net) + * db-oracle/oracle-api: Add OCIServerVersion + * db-oracle/oracle-sql: Query and store server version on connect + * sql/db-interface.lisp: Add new db-type-has-bigint? generic + function to handle OCI's lack of bigint support + * test/test-basic.lisp: Separate bigint testing + * test/test-utils.lisp: Add oracle to specs and list of backends + * doc/TODO: New file + * test/test-fdml.lisp: Added FDML/SELECT/34 to test + run-time instantiation of variables in reader macros. + * TODO: Remove item already complete. Add note about + condition variances + +16 May 2004 Marcus Pearce (m.t.pearce@city.ac.uk) + * sql/syntax.lisp: added condition to the reader macro to treat [*] + as a column identifier (rather than an operation) for CommonSQL + compatibility. + * tests/test-fdml.lisp: add tests for ORDER-BY and SET-OPERATION + keword args to SELECT, [*] as column identifier, new MAP-QUERY + behaviour and the ANY and ALL operators in subqueries. + * tests/test-init.lisp: add set-operation and subquery tests to + appropriate skip lists. + * sql/objects.lisp: remove redundant and non CommonSQL compatible + ORDER-BY-DESCENDING keyword argument for SELECT. + * sql/classes.lisp: remove redundant and non CommonSQL compatible + ORDER-BY-DESCENDING keyword argument for SELECT. + * tests/test-oodml.lisp: add test for ORDER-BY keyword to SELECT + with object queries. + +15 May 2004 Kevin Rosenberg (kevin@rosenberg.net) + * sql/db-interface.lisp: Add new db-type-has-union? + since Mysql 3.23 does not support unions. + * sql/test-init.lisp: Don't try union tests on database + backends which do not support it. + * db-oracle/*.lisp: initial port to UFFI + * sql/objects.lisp: implement UPDATE-OBJECT-JOINS, + implement REFRESH for SELECT. + * tests/test-oodml.lisp: Add tests for deferred retrieval, + caching, refresh, and update-object-joins + * tests/test-init.lisp: Add deferred-employee-address class + +15 May 2004 Marcus Pearce (m.t.pearce@city.ac.uk) + * sql/operations.lisp: make MINUS operator a synonym for EXCEPT. Add + COALESCE operator and make NVL a synonym for this. Make ANY, SOME, + ALL and EXISTS generate function expressions so they output the + correct SQL. + * sql/classes.lisp: SELECT now generates appropriate SQL when + passed the SET-OPERATION and ALL keyword arguments. + * sql/classes.lisp: the ORDER-BY keyword argument to SELECT now + accepts ordering constraints as pairs of the form (column direction) + where direction may be :ASC or :DESC. + * tests/test-syntax.lisp: added tests for MINUS and COALESCE/NVL. + Correct tests for ANY, SOME, ALL and EXISTS. + * tests/test-fdml.lisp: added test for COALESCE. + * sql/sql.lisp: MAP-QUERY now applies FUNCTION to QUERY-EXPRESSION + using funcall unless QUERY-EXPRESSION returns one column and its + FLATP slot is not nil in which case apply is used. + * tests/test-basic.lisp: modified calls to MAP-QUERY to reflect the + changes. + * TODO: remove items done. + * db-postgresql/postgresql-sql.lisp: no need to reverse results in + DATABASE-LIST-ATTRIBUTES. + * db-postgresql-socket/postgresql-socket-sql.lisp: no need to reverse + results in DATABASE-LIST-ATTRIBUTES. + +15 May 2004 Marcus Pearce (m.t.pearce@city.ac.uk) + * sql/classes.lisp: SELECT now accepts table identifiers as strings + for CommonSQL compliance. Add support for qualified sql identifiers + with aliased table names. + * tests/test-fdml.lisp: added tests for table identifiers as strings + in SELECT and for aliased definitions. + * tests/test-syntax.lisp: added tests for alias definitions. + +15 May 2004 Marcus Pearce (m.t.pearce@city.ac.uk) + * sql/sql.lisp: PRINT-QUERY now calls QUERY with result-types and + field-names set to nil. + * sql/sql.lisp: PRINT-QUERY now computes column sizes correctly + with null attribute values. + * sql/operations.lisp: modify SQL concatenation operator to accept + unescaped || symbol. + * sql/syntax.lisp: modify sql reader macro function to accept + unescaped sql concatenation operator. + * tests/test-fdml.lisp: unescape sql concatenation operator. + * tests/test-syntax.lisp: unescape sql concatenation operator. + * TODO: remove items done. Add notes about SQLITE/MYSQL backends. + Note to add test for universal-time. Note about difference from + CommonSQL in transaction handling. + +13 May 2004 Kevin Rosenberg (kevin@rosenberg.net) + * tests/test-init.lisp: Add deferred-employee-address + class + * tests/test-oodml.lisp: Add deferred retrieval testgs + +12 May 2004 Kevin Rosenberg (kevin@rosenberg.net) + * Version 2.10.17 + * LATEST-TEST-RESULTS: Run on all platforms, add AMD64 + * sql/sql.lisp: Add FOR-EACH-ROW macro from clsql-classic/sql.lisp + * db-sqlite/sqlite-uffi-api.lisp: Fix row-pointer type + * *: Fix minor style warnings + * clsql-classic: Remove system and subdirectory + * clsql-base: Remove system and subdirectory and + fold into clsql system + * doc/intro.xml: Remove reference to old clsql-base. Add x86_64 + as supported platform. + +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 + Allegro 7.0beta AMD64 + * db-odbc/*.lisp: Add a layer of indirection to foreign-type + of ODBC longs since this type can vary on 64-bit platforms depending + upon the compilation options of unixODBC. + * db-mysql/mysql-api.lisp: Fix int vs. long slots in foreign + structures found by testing with AllegroCL 7.0b AMD64. + * db-*/*-loader.lisp: Load 64-bit libraries on 64-bit platorms + * sql/objects.lisp: Simple implementation of UPDATE-OBJECT-JOINS. + Initial caching support for SELECT + * tests/test-oodml.lisp: Avoid using cache when testing select. + * sql/kmr-mop.lisp: Explicitly check slot order and + store as a cl:*feature* + * sql/recording.lisp: Remove additional types to + increase CommonSQL conformance. + * tests/test-init.lisp: Change a :column attribute + to test symbols as value + * sql/relations.lisp: Remove functions since they don't support + many to many relationships. + * examples/clsql-tutorial.lisp, doc/csql.lisp: Remove use + of add-to-relations function and replace with explicit field settings. + * base/classes.lisp: Remove obsolute query-stream. Add record-caches slot. + +9 May 2004 Kevin Rosenberg (kevin@rosenberg.net) + * Version 2.10.15 + * LATEST-TEST-RESULTS: results with current version + * sql/kmr-mop.lisp: Make CMUCL reader macros specific for cmu18 + since cmu19 has opposite order of class slots. + * sql/objects.lisp: Fix (setf slot-value-using-class) for Lispworks + * tests/test-fdml.lisp: Renumber SELECT tests to avoid overwriting + a previous test + * tests/test-init.lisp: Check test-database-underlying-type for + ODBC/MySQL tests + +8 May 2004 Marcus Pearce (m.t.pearce@city.ac.uk) + * sql/operations.lisp: complete remaining operations for the sql + syntax: SUBSTR, SOME, ORDER-BY, GROUP-BY, NULL, DISTINCT, EXCEPT, + UNION, INTERSECT, BETWEEN. + * sql/classes.lisp: add new classes: SQL-BETWEEN-EXPRESSION, + SQL-QUERY-MODIFIER-EXPRESSION and SQL-SET-EXPRESSION. + * tests/test-syntax.lisp: add tests for new operations. + * tests/test-fdml.lisp: add tests for queries based on new operations. + * tests/test-init.lisp: add select/20 to tests skipped for sqlite and + select/20, query/5, query/7 and query/8 to tests skipped by mysql. + * TODO: removed entries done. + +8 May 2004 Kevin Rosenberg (kevin@rosenberg.net) + * tests/benchmarks.lisp: Add immediate vs. deferred + join test. + +8 May 2004 Kevin Rosenberg (kevin@rosenberg.net) + * Version 2.10.13: Now works on openmcl 0.14.2 + * sql/objects.lisp: Add :retrieval :immediate for + object selections + * tests/test-init.lisp: Add non-index fields for testing + join class employee-addresss + * test/test-oodml.lisp: Add tests for retrieval immediate + * sql/metaclasses.lisp: Handle differences in direct-slot-definition + values which are now listifed by openmcl 14.2. + * sql/objects.lisp: more framework for supporing immediate retrieval + +7 May 2004 Kevin Rosenberg (kevin@rosenberg.net) + * docs/intro.xml: Upload location of a README file + * sql/metaclass.lisp: Work-around openmcl's CHANGE-CLASS + changing the type-specifier. Use a lisp type of (OR NULL FOO) + for a specified-type of FOO unless :db-constraints :not-null. + No need to specialize finalize-inheritance for openmcl. + * tests/test-*.lisp: Rename fields so that joins occur on + fields with different names. This ensures that join code is + selecting the proper name. + * test/test-init.lisp: Add :base-table for employee-address + view class for testing. + * sql/objects.lisp: Use view-table rather than name of table + in a number of places to fix errors noted with using :base-table. + +6 May 2004 Marcus Pearce (m.t.pearce@city.ac.uk) + * sql/objects.lisp: replace *update-records-on-make-instance* with + *db-auto-sync* which also controls both automatic creation of + new records on creation of new instance and updating of record + fields on setting of instance slots (as suggested by Edi Weitz). + * tests/test-init.lisp: replace *update-records-on-make-instance* + with *db-auto-sync*. + * sql/package.lisp: replace *update-records-on-make-instance* + with *db-auto-sync*. + * TODO: replace *update-records-on-make-instance* with *db-auto-sync*. + * sql/objects.lisp: remove redundant rebindings of *db-initializing* + and *default-database* in FIND-ALL. + * sql/package.lisp: import time functions from CLSQL-BASE. + * tests/test-time.lisp: replace CLSQl-BASE package qualifier with CLSQL. + * tests/test-fdml.lisp: replace CLSQl-BASE package qualifier with CLSQL. + * tests/test-init.lisp: replace CLSQl-BASE package qualifier with CLSQL. + * tests/test-ooddl.lisp: replace CLSQl-BASE package qualifier with + CLSQL. + +4 May 2004 Kevin Rosenberg (kevin@rosenberg.net) + * sql/classes.lisp: Add SQL-OBJECT-QUERY type. Have [select 'class] + now return a sql-object-query type rather than directly performing a query. + This improves CommonSQL conformance. + * sql/sql.lisp: Add new QUERY method for SQL-OBJECT-QUERY. Move + from basic/basic-sql.lisp the DO-QUERY and MAP-QUERY since they now + depend on sql-object-query-type. + * sql/loop-extensions.lisp: Move from base package + * classic/package.lisp: remove references to map-query and do-query + +4 May 2004 Kevin Rosenberg (kevin@rosenberg.net) + * TODO: New section on optimizations, especially optimizing JOINs. + * sql/objects.lisp: Have :target-slot return of list of lists rather + than a list of cons pairs to be conformant with CommonSQL. + Make :target-slot much more efficient by using a SQL inner join + statement and just requiring one SQL query. Add :retrieval :deferrred + to target-slot joins. Add placeholder for update-objects-join. + * sql/classes.lisp: Add :inner-join and :on slots to sql-query class + and process them for query output-sql. + +4 May 2004 Kevin Rosenberg (kevin@rosenberg.net) + * Version 2.10.11 + * base/basic-sql.lisp: Avoid multiple evaluation + of query-expression in DO-QUERY + * sql/objects.lisp: Make SELECT a normal function. + SELECT now accepts type-modified database identifiers, such as + [foo :string] which means that the values in column foo are returned + as Lisp strings. Add new *update-records-on-make-instance* special + variable controlling automatic creation of new instances. Add missing + RESULT-TYPES keyword to FIND-ALL. Add :target-slot support. + * sql/packages.lisp: Export *update-records-on-make-instance* + * test/test-oodml.lisp: Add tests for :target-slot and many-to-many + selections. + * test/test-fdml.lisp: Add tests for type-modified + database identifiers. + * test/test-init.lisp: Stop using add-relation since implementing + many-to-many joins. Use *update-records-on-make-instance* + to automatically store records on instance creation. Add many-to-many + employee-address view-class. + +4 May 2004 Kevin Rosenberg (kevin@rosenberg.net) + * Version 2.10.10 + * base/loop.lisp: Add object iteration. Use :result-type + :auto for result-set. Remove + duplicate (and non-correct) code for non-list variables by + simply making an atom variable into a list. + * sql/package.lisp: Remove unnecessary clsql-sys package + and replace it with clsql. + * sql/metaclasses.lisp: Properly store specified-type from + direct-slot-definition and then store translated type in + effective-slot-definition + * sql/classes.lisp: Don't output type in sql-output + for SQL-IDENT-ATTRIBUTE. This is in preparation for supporting + [foo :integer] as fields in SELECT. + * sql/query.lisp: Set default for :result-types to :auto in + FDML QUERY. + * sql/objects.lisp: Use specified-type when invocating + database-get-type-specifier. def-view-class macro now returns + the class instance. + * base/basic-sql.lisp: Make :AUTO the default value for + :RESULT-TYPES for MAP-QUERY and DO-QUERY. + * sql/objects.lisp: Add bigint type + * test/tests-basic.lisp: Add tests for :result-types for + MAP-QUERY and DO-QUERY + * test/test-fdml.lisp: Add test for result-types in LOOP + and also using single symbol rather than a list for variables. + Add test that default :result-types is auto for FDML QUERY. + * test/test-syntax.lisp: Don't expect TYPE in the SQL-OUTPUT + of SQL-IDENT-ATTRIBUTE. + * test/test-oodml.lisp: Enable OO loop iteration test, + modify it so it doesn't depend on boolean where. + +4 May 2004 Marcus Pearce (m.t.pearce@city.ac.uk) + * Version 2.10.9 + * sql/objects.lisp: added derived type specifier for universal time. + * sql/package.lisp: added #:universal-time to clsql-sys exports. + * tests/test-oodml.lisp: added test for translation of boolean slots + in SELECT with object queries. + +3 May 2004 Kevin Rosenberg (kevin@rosenberg.net) + * db-odbc/odbc-api.lisp: Fix changing nil to "NIL" + for odbc/postgresql backend. + * db-odbc/odbc-sql.lisp: Fix ATTRIBUTE-TYPE so that + it can handle NIL values from the ODBC driver + * tests/benchmarks.lisp: New file with initial + benchmark suite + * sql/relations.lisp: fix to add subclassing support, + minor optimizations [Edi Weitz] + +3 May 2004 Kevin Rosenberg (kevin@rosenberg.net) + * Version 2.10.8 + * base/conditions.lisp: Add *backend-warning-behavior* + special variable. + * db-postgresql-socket/postgresql-socket-sql.lisp: + Honor value of *backend-warning-behavior* + * tests/test-fdml.lisp: Remove test of raw boolean value + since different backends handle this differently. Add + test for :column attribute. + * tests/test-oodml.lisp: Add tests for boolean slot value + and for :void-value attribute + * tests/test-init.lisp: Use *backend-warning-behavior* + to suppress warnings from postgresql about implicitly + creating primary key in tables. Add new address table. + +3 May 2004 Kevin Rosenberg (kevin@rosenberg.net) + * Version 2.10.7 + * db-odbc/odbc-dbi.lisp: Convert TINYINT to integers when + result-types is :auto + * sql/objects.lisp: Properly handled writing/reading Boolean + values from SQL database when retrieving objects. + * test/test-fdml.lisp: Add another test for boolean results + * test/utils.lisp: Fix incorrect declaration + +2 May 2004 Marcus Pearce (m.t.pearce@city.ac.uk) + * Version 2.10.6 + * sql/generics.lisp: add generic function for SELECT. + * sql/objects.lisp: make SELECT a method specialisation. + * sql/classes.lisp: MAKE-QUERY now calls SELECT if the selections + referred to are View Classes. + * base/basic-sql.lisp: in DO-QUERY and MAP-QUERY, if the + query-expression arg evaluates to a list, then we have an object + query. + * tests/test-oodml.lisp: add tests for DO-QUERY and MAP-QUERY with + object queries. + * TODO: remove items done and add a todo for SELECT. + * sql/objects.lisp: SELECT takes a :field-names arg to pass on to + QUERY. + * sql/sql.lisp: add :field-names arg to QUERY. + * tests/test-fdml.lisp: minor rework to use :field-names arg to + SELECT. + +2 May 2004 Marcus Pearce (m.t.pearce@city.ac.uk) + * sql/objects.lisp: fix bug in FIND-ALL when SELECT called with 2 + or more View Classes. + * sql/objects.lisp: make the :flatp argument to SELECT work with + object queries. + * sql/objects.lisp: make SELECT accept a :result-types argument + (defaults to :auto) which is passed on to QUERY. + * sql/objects.lisp: SELECT returns field-names as a second value. + * tests/test-ooddl.lisp: add flatp arg to SELECT calls as appropriate. + * tests/test-fdml.lisp: add flatp/result-types arguments to calls + to SELECT and take only first value as appropriate. + * tests/test-fdml.lisp: add two new tests for query result coercion + and the field-names returned as a second value from SELECT. + * tests/test-oodml.lisp: add flatp arg to SELECT calls as appropriate. + +1 May 2004 Kevin Rosenberg (kevin@rosenberg.net) + * Version 2.10.6-pre1 + * sql/metaclasses.lisp: Add void-value slot + * doc/csql.xml: Update def-view-class documentation + * test/test-init.lisp: Change old :db-type to :db-kind. + Remove old :nulls-ok attributes. + * sql/objects.lisp: Add new universal-time and bigint + types. Optimize reading of integers using parse-integer + rather than read-from-string. + * */*.lisp: Merge clsql-base-sys and clsql-base packages + into clsql-base package + * classic/sql.lisp: Move large object support into base, leaving + classic without any functionality that is provided in the clsql + system. + * classic/package.lisp: Rename clsql-classic-sys package to + its former nickname of clsql-classic + +1 May 2004 Kevin Rosenberg (kevin@rosenberg.net) + * Version 2.10.5: SQLite backend now passes all result-types tests + * clsql-sqlite.asd: Depend on clsql-uffi system + * db-sqlite/sqlite-sql.lisp: Use clsql-uffi:convert-raw-field + for efficiency and code reuse. + * db-sqlite/sqlite-api-uffi.lisp: Change (* :char) to (* :unsigned-char) + for better cross-implementation compatibility. + +1 May 2004 Kevin Rosenberg (kevin@rosenberg.net) + * Version 2.10.4 + * sql/tables.lisp: Fix typo in CACHE-TABLE-QUERIES + [Marcus Pearce] + * db-postgresql/postgresql-sql.lisp: Fix foreign-string vs. cstring + bug on SBCL in result-field-names function as reported by Marcus Pearce + * db-sqlite/sqlite-sql.lisp: Fix in database-store-next-row + manifest in SBCL testing + +1 May 2004 Kevin Rosenberg (kevin@rosenberg.net) + * Version 2.10.3 + * sql/database.lisp: Conform more to CommonSQL output + for STATUS command [Marcus Pearce] + * sql/sqlite-sql.lisp: Rework to use result-types + * sql/sqlite-api-clisp.lisp: Add compatibility layer + with sqlite-api-uffi.lisp so that sqlite-sql.lisp can + be cleaned up of most clisp reader conditionals + * sql/test-init.lisp: Now run field type tests on sqlite + backend + +30 Apr 2004 Kevin Rosenberg (kevin@rosenberg.net) + * Version 2.10.2 + * base/basic-sql.lisp: Set default value of :result-types + to :auto for more CommonSQL conformance. + * test/test-fdml.lisp: Add tests for numeric value of fields + + +30 Apr 2004 Kevin Rosenberg (kevin@rosenberg.net) + * Version 2.10.1: New API function: CACHE-TABLE-QUERIES. + * base/basic-sql.lisp, db-*/*-sql.lisp: More CommonSQL conformance. + Return field names as second value for QUERY. This can be overridden + for efficiency with the new keyword :FIELD-NAMES set to NIL + in the QUERY invocation. + * test/test-fdml.lisp: Add tests for new field-name feature + * sql/metaclass.lisp: Remove old Lispworks cruft + and replace it with invocation of new code in kmr-mop.lisp + which actually works with Lispworks 4.2 + * doc/ref_clsql.xml: Document new :FIELD-NAMES keyword to + QUERY function + * base/db-interface.lisp: Document the multiple values + returned by DATABASE-ATTRIBUTE-TYPE so matches the + undocumented CommonSQL behavior. + * sql/table.lisp: Add *CACHE-TABLE-QUERIES-DEFAULT* and + *DEFAULT-UPDATE-OBJECTS-MAX-LEN* variables and export them. + LIST-ATTRIBUTE-TYPES now conforms to CommonSQL spec. + Implement CACHE-TABLE-QUERIES. + * db-odbc/odbc-sql.lisp: Fix attribute-type function + * test/test-fddl.lisp: Add tests for attribute type + * db-mysql/mysql-sql.lisp: Mild optimization in accessing + field structures. + * base/classes.lisp: Add attribute-cache slot to database clas + * base/initialize.lisp: initialize-database-type now automatically + loads database-type backend as needed. + * base/test-init.lisp: Utilize new initialize-database-type functionality. + * TODO: remove items done + +30 Apr 2004 Marcus Pearce (m.t.pearce@city.ac.uk) + * Version 2.9.6 + * sql/objects.lisp: remove create/drop-sequence-from-class. + * sql/objects.lisp: add INSTANCE-REFRESHED generic function. + * sql/objects.lisp: improved CommonSQL compatibility for + UPDATE-RECORD-FROM-SLOT, UPDATE-RECORD-FROM-SLOTS, + UPDATE-RECORDS-FROM-INSTANCE and DELETE-INSTANCE-RECORDS. + * sql/generics.lisp: move generics from objects.lisp to here. + +29 Apr 2004 Kevin Rosenberg (kevin@rosenberg.net) + * Version 2.9.6-pre1 + * db-mysql/mysql-client-info.lisp: Add client version 4.1 + detection + * sql/sql.lisp: Make *default-database* the default for + TRUNCATE-DATABASE + +28 Apr 2004 Kevin Rosenberg (kevin@rosenberg.net) + * Version 2.9.5 + * db-mysql/mysql-sql.lisp: Fix bug in transaction capability + detection + * sql/objects.lisp: Commit patch from Slawek Zak to allow specifying + :metaclass in DEF-VIEW-CLASS invocation. This allows defining classes + on a metaclass specialized from standard-db-class. + + +24 Apr 2004 Kevin Rosenberg (kevin@rosenberg.net) + * Version 2.9.4: Multiple changes to support Allegro's "modern" + lisp which uses a lowercase reader and has case-sensitive symbols + * sql/classes.lisp: Fix make-load-form bug for sql-ident-table + exposed by case-sensitive mlisp. + +22 Apr 2004 Kevin Rosenberg (kevin@rosenberg.net) + * Version 2.9.3: All tests now pass on all platforms! + * LATEST-TEST-RESULTS: New file with summary of test results + * sql/generics.lisp: New file for generic function definitions. + * test/test-init.lisp: Display names of skipped tests. + Use unwind-protect to ensure disconnect + * sql/objects.lisp: Change database-type to database-underlying-type + so that actual database engine is properly identified + * db-odbc/odbc-api.lisp: Have default *time-conversion-function* + return an ISO timestring for compatibility with other drivers. + Workaround bug in MyODBC for LIST-TABLE-INDEXES + * test/test-fdml.lisp: Accomodate that odbc-postgresql driver + returns floating-point values for floor and truncate operations + * db-aodbc/aodbc-sql.lisp: Implement DATABASE-LIST-VIEWS + * tests/test-basic.lisp: Port to regression tester + * test/test-init.lisp: Output to *report-stream* + * docs/appendix.xml: Document ODBC and SQLite backends. + * sql/classes.lisp: Make output-sql require a database parameter. + This allows SQL generation to have the proper case to support + the differences in case handling between CommonSQL API, + Postgresql, MySQL, Oracle. + +21 Apr 2004 Kevin Rosenberg (kevin@rosenberg.net) + * Version 2.9.2: Improvments in database capability introspection + and querying. Support transactions in MySQL where available. + All tests now pass on MySQL and SQLite in addition to postgresql + and postgresql-socket. ODBC fails only with OODDL/TIME/1 and OODDL/TIME/2. + * db-odbc/odbc-sql.lisp: Add DATABASE-LIST-VIEWS. Better support + DATABASE-LIST-SEQUENCES. + * clsql-uffi.asd, clsql-mysql.asd: Improve shared library loading + * Database_capabilies: add HAS-VIEWS, HAS-CREATE/DESTROY-DB, + HAS-BOOLEAN-WHERE, TRANSACTION-CAPABLE + * tests/*.lisp: Check database capabilities and remove tests which + the database backend does not support + * sql/table.lisp: Add :TRANSACTIONS keyword to create table which + controls whether InnoDB tables will be created when supported on + the underlying MySQL server. + +20 Apr 2004 Kevin Rosenberg (kevin@rosenberg.net) + * Version 2.9.0: New API function: LIST-TABLE-INDEXES, + supported by all database backends (except AODBC since + AODBC doesn't support index querying) + * db-obdc/odbc-sql.lisp: Support DATABASE-LIST-INDEXES + * db-odbc/odbc-api.lisp: Add %TABLE-STATISTICS function + to support index queries + * db-aodbc/aodbc-sql.lisp: Filter driver manager + "information_schema" tables from LIST-TABLES + * tests/test-basic.lisp: Remove table after testing + * tests/test-fddl.lisp: Test LIST-TABLE-INDEXES + * base/db-interface.lisp: Add DATABASE-UNDERLYING-TYPE + which gets the underlying type of database -- required + when dealing with ODBC databases and want to query + database capabilities. Added DB-USE-COLUMN-ON-DROP-TABLES? + as first database-backend specific feature. Is T on + :mysql, NIL on other backends. Change DROP-TABLE to + query this. + +19 Apr 2004 Kevin Rosenberg (kevin@rosenberg.net) + * Version 2.8.2: Build changes for FreeBSD [Slawek Zak] + +19 Apr 2004 Kevin Rosenberg (kevin@rosenberg.net) + * Version 2.8.1 + * db-odbc/odbc-sql.lisp: Add DATABASE-LIST function + * db-odbc/odbc-dbi.lisp: Add LIST-ALL-DATA-SOURCES function + +19 Apr 2004 Kevin Rosenberg (kevin@rosenberg.net) + * Version 2.8.0: New API function: LIST-DATABASES + * base/utils.lisp: Fix command-output on CMUCL/SBCL + * db-*/*-sql.lisp: Add new database-list function + * base/database.lisp: Add new LIST-DATABASES command + +18 Apr 2004 Kevin Rosenberg (kevin@rosenberg.net) + * Version 2.7.9 + * db-sqlite/sqlite-sql.lisp: Fix sequence functions. + * db-sqlite/sqlite-api-uffi.lisp: Print error string + correctly. + +18 Apr 2004 Kevin Rosenberg (kevin@rosenberg.net) + * Version 2.7.7 + * doc/csql.xml, examples/clsql-tutorial.lisp: Patch for db-kind + from Eduardo Munoz. + +17 Apr 2004 Kevin Rosenberg (kevin@rosenberg.net) + * Version 2.7.6 + * base/objects.lisp, base/classes.lisp: Patch + for db-kind from Eduardo Munoz + +16 Apr 2004 Kevin Rosenberg (kevin@rosenberg.net) + * Version 2.7.5 + * base/basic-sql.lisp: Fix FLATP in QUERY + +16 Apr 2004 Kevin Rosenberg (kevin@rosenberg.net) + * Version 2.7.3: Implement RECONNECT + +15 Apr 2004 Kevin Rosenberg (kevin@rosenberg.net) + * Version 2.7.2: Fix ODBC on Lispworks Windows + +15 Apr 2004 Kevin Rosenberg (kevin@rosenberg.net) + * Version 2.7.1: Fix for new ODBC backend. + clsql-odbc now works on SBCL, CMUCL, OpenMCL + in addition to AllegroCL and Lispworks. + +15 Apr 2004 Kevin Rosenberg (kevin@rosenberg.net) + * Version 2.7.0: New backend: ODBC. Tests as + well as AODBC backend on Allegro,Lispworks. + SBCL and CMUCL don't work quite yet. Requires UFFI v1.4.11+ + * db-odbc/*.lisp: Add ODBC3 function SQLSetEnvAttr + to explicitly set ODBC2 support. Add BIGINT support. + Add result-types support. Added SQLTables. + Fix array type in fetch-all-rows. Make width + changable by database or query. + * base/utils.lisp: Add process functions + * base/package.lisp: Export utils to CLSQL-BASE-SYS + * db-aodbc: Implement sequence functions, + database-list-tables, database-list-attributes + * tests/utils.lisp: Add support for ODBC backend, + rework READ-SPECS to use +all-db-types+ + * db-mysql/mysql-sql.lisp: Use WITHOUT-INTERRUPTS + for SEQUENCE-NEXT + +13 Apr 2004 Kevin Rosenberg (kevin@rosenberg.net) + * Version 2.6.13. Requires UFFI version 1.4.9 + * db-odbc/*.lisp: Further porting. + Pre-alpha code! But, basic query is now working. + +13 Apr 2004 Kevin Rosenberg (kevin@rosenberg.net) + * Version 2.6.12 + * base/transactions.lisp: Add quote for macro + expansion of WITH-TRANSACTIONS [Time Howe] + * db-sqlite/sqlite-sql.lisp: Support memory database + in database-probe [Ng Pheng Siong] + * db-odbc/*.lisp: Initial port to UFFI of SQL-ODBC. + The DBI layer is not finished. + +12 Apr 2004 Kevin Rosenberg (kevin@rosenberg.net) + * Version 2.6.11 + * sql/objects.lisp: add :root-class functionality for + list-classes and add duration type support [Marcus Pearce] + * db-odbc: Add mid-level [DBI] layer + +12 Apr 2004 Kevin Rosenberg (kevin@rosenberg.net) + * Version 2.6.10 + * db-aodbc: Add methods for generic functions, some are + not yet implemented. + * clsql-odbc.asd, db-odbc/*.lisp: Initial start of ODBC + support + +12 Apr 2004 Kevin Rosenberg (kevin@rosenberg.net) + * Version 2.6.9 + * base/package.lisp: Add missing symbols [Marcus Pearce] + +12 Apr 2004 Kevin Rosenberg (kevin@rosenberg.net) + * Version 2.6.8 + * test/test-fddl.lisp: Cleanup fix [Marcus Pearce] + * utils/time.lisp: Multiple fixes [Marcus Pearce] + * sql/sql.lisp: Fix for truncate-database [Marcus Pearce] + +12 Apr 2004 Kevin Rosenberg (kevin@rosenberg.net) + * Version 2.6.7 + * sql/*.lisp: Remove schema versioning cruft + [Marcus Pearce] + * Makefile: Add classic subdirectory + +12 Apr 2004 Kevin Rosenberg (kevin@rosenberg.net) + * Version 2.6.6 + * sql/sql.lisp: Fix TRUNCATE command, bug reported + by Marcus Pearce + * sql/sql.lisp: Remove EXPLAIN function. Postgresql/Oracle + specific and easy for an application to directly support. + Idea from Marcus Pearce. + * base/basic-sql.lisp: Remove DESCRIBE-TABLE top-level + API as duplicates LIST-ATTRIBUTE-TYPES [Marcus Pearce]. + Keep low-level interface for future optimization + supporting LIST-ATTRIBUTE-TYPES command. + * Makefile: Add to db-sqlite and test directories. + Include them in top-level Makefile + +12 Apr 2004 Kevin Rosenberg (kevin@rosenberg.net) + * Version 2.6.5 + * sql/relations.lisp: Add missing file + * utils/time.lisp: Fixes/extensions [Marcus Pearce] + * test/test-time.lips: New file [Marcus Pearce] + +10 Apr 2004 Kevin Rosenberg (kevin@rosenberg.net) + * Version 2.6.4 + * test/test-init.lisp: Properly handle object + creation. Close database after use. + * sql/sql.lisp: Make DESCRIBE-TABLE a generic + function so can have methods specialized on + table being a string or an sql-table object. + * base/pool.lisp: Really fix CMUCL locking + +10 Apr 2004 Kevin Rosenberg (kevin@rosenberg.net) + * Version 2.6.3 + * test/test-init.lisp: Signal correctly + if any errors occurred in any test suite + * base/loop-extensions.lisp: Fix error + introduced for Lispworks + * base/pool.lisp: Fix locking for CMUCL + * base/objects.lisp: Remove schema-version cruft + +10 Apr 2004 Kevin Rosenberg (kevin@rosenberg.net) + * Version 2.6.2: New CLSQL API functions: + DESCRIBE-TABLE AND TRUNCATE-DATABASE + Currently, this are only supported on :postgresql + and :postgresql-socket + * base/database.lisp: automatically load ASDF system + in CONNECT if not already loaded + * base/tests.lisp: disconnect database after testing + * base/*.lisp: Remove CLOSED-DATABASE type in favor + of storing open/closed status in slot of database + * base/pool.lisp: Support locks for CMUCL, OpenMCL, SBCL + * db-postgresql/postgresql-sql.lisp: add DATABASE-RECONNECT, + DATABASE-DESCRIBE-TABLE + * db-sqlite/sqlite-sql.lisp: Add missing slots in database + * base/conditions: Remove duplicate condition + * db-*/*-sql.lisp: Fill new database slot DATABASE-TYPE + * base/recording.lisp: Add new :QUERY type for recording + +10 Apr 2004 Kevin Rosenberg (kevin@rosenberg.net) + * Version 2.6.1: documentation fixes, merged + classic-tests into tests + +10 Apr 2004 Kevin Rosenberg (kevin@rosenberg.net) + * Version 2.6.0 released: New API functions + CREATE-DATABASE, DESTORY-DATABASE, PROBE-DATABASE + * doc/ref_clsql.xml: Document new functions + * base/database.lisp: New API functions + * base/conditions.lisp: Added CLSQL-ACCESS-ERROR + * base/utils.lisp: Fix use of position-char. + Add COMMAND-OUTPUT used by backends for running + external programs. Fix parsing of SQL*NET-compatible + connection-specs. + * base/loop-extension.lisp: Simplify package use + for Lispworks and Allegro + * db-*/*-sql.lisp: Added DATABASE-CREATE, + DATABASE-DESTORY, PROBE-DATABASE methods + * tests/test-init.lisp, clasic-tests/tests.lisp: + Use destroy-database and create-database to ensure + testing with empty database + * tests/test-connection.lisp: Add tests for + parsing of string connection-specs + * examples/run-tests.sh: New file for running + test suite on all installed CL implementations + * examples/clsql-tutorial.lisp: moved from + doc directory + * examples/dot.clsql-tests.config: New file + giving an example test configuration + * test/README: Add notes about rtest/ptester + downloads and link to sample test configuration file. + +10 Apr 2004 Kevin Rosenberg (kevin@rosenberg.net) + * Version 2.5.1 released: + * tests/*.lisp: Rework so tests are run + on multiple backends automatically based + on the contents of ~/.clsql-tests.config. + Reuse helper functions from classic-tests. + * base/database.lisp: Support connection-spec + as string for CONNECT + * classic-tests/tests.lisp: Automatically + load database backends as needed. + +09 Apr 2004 Kevin Rosenberg (kevin@rosenberg.net) + * Version 2.5.0 released: + All tests for CLSQL and CLSQL-CLASSIC pass + on all platforms. + * base/loop-extension.lisp: Add Lispworks + loop-extension. Improve type specifying on + other platforms. + +09 Apr 2004 Kevin Rosenberg (kevin@rosenberg.net) + * Version 2.4.2 released: + loop extension now supported on Allegro, all + CLSQL-TESTS pass on Allegro. + * sql/metaclasses.lisp: Some optimization + of compute-slots, be selective when + ordered-class-slots needs to be called + instead of class-slots + * TODO: add URL with documentation on + extending Lispworks LOOP form + +09 Apr 2004 Kevin Rosenberg (kevin@rosenberg.net) + * Version 2.4.1 released: CLSQL-TESt suite passes + all tests for postgresql and CMUCL, SBCL, OpenMCL. + Allegro and Lispworks pass all tests except for + FDML/LOOP/1 since the loop extension have not yet + been ported to those implementions. + * sql/metaclasses.lisp: Added new slot to standard-db-class + to hold user-specified type. OpenMCL adjustments to compensate + for its type-predicate function. Since AllegroCL, Lispworks, + and OpenMCL have different slot orders, added compute-slots + and ordered-class-slots functions so their slot order matches + SBCL/CMUCL. + +08 Apr 2004 Kevin Rosenberg (kevin@rosenberg.net) + * Version 2.4.0 released: All tests for clsql-classic now finish + correctly on Allegro, Lispworks, CMUCL, SBCL, OpenMCL for + mysql, postgresql, postgresql-sockets, and sqlite backends. + * db-mysql/mysql-sql.lisp: Fix array dereferencing + * classic-tests/tests.lisp: Fix package name of + number-to-sql-string. + * clsql.asd/clsql-tests.asd: Add support for asdf:test-op + * db-sqlite/sqlite-api-{uffi,sql}.lisp: Multiple UFFI fixes, + now passes tests on all support UFFI platforms. + * db-postgresql-socket/postgresql-socket-api.list: Ported to + SBCL and OpenMCL + * multiple: Finish renaming of :types keyword to :result-types for + greater CommonSQL compatibility, including documentation + * sql/basic-cmds.lisp: Remove obsolete file + +08 Apr 2004 Kevin Rosenberg (kevin@rosenberg.net) + * Version 2.3.3 released + * Fixes for sequences on mysql and sqlite [Marcus Pearce] + * Fixes for uffi sqlite backend [Aurelio Bignoli / Kevin Rosenberg] + * Fix for schema table [Marcus Pearce] + * Add loop extension support for SBCL and OpenMCL [Marcus Pearce] + * Fixes to test suite [Marcus Pearce] + +06 Apr 2004 Kevin Rosenberg (kevin@rosenberg.net) + * db-*/*-sql.lisp: Ensure that expr in + database-query-result-set is a string + * Documentation integration + +06 Apr 2004 Kevin Rosenberg (kevin@rosenberg.net) + * With for Marcus Pearce's excellent work, I've merged + his clsql-usql port into clsql. The original clsql + interface is available in the clsql-classic package. + +02 Apr 2004 Kevin Rosenberg (kevin@rosenberg.net) + * Integrate patch from Marcus Pearce <ek735@soi.city.ac.uk> + adding further support for providing backend for UncommonSQL + +10 Mar 2004 Kevin Rosenberg (kevin@rosenberg.net) + * Integrate patch from Aurelio Bignoli for SQLite backend + +11 Nov 2003 Kevin Rosenberg (kevin@rosenberg.net) + * Converted documentation to XML format + * Made package installable with asdf-install + +23 Jul 2003 Kevin Rosenberg (kevin@rosenberg.net) + * Add for-each-row macro + +12 Dec 2002 Kevin Rosenberg (kevin@rosenberg.net) + * uffi/clsql-uffi.lisp: return NIL for numeric fields that are NULL + +16 Oct 2002 Kevin Rosenberg (kevin@rosenberg.net) + * Add support for SBCL, OpenMCL, and SCL + * Add *load-truename* to search path for clsql's + compiled libraries. + +01 Sep 2002 Kevin Rosenberg (kevin@rosenberg.net) + * Rework use of file types in .asd files + +17 Aug 2002 Kevin Rosenberg (kevin@rosenberg.net) + * Add .asd definition files for ASDF users + +31 Jul 2002 Kevin Rosenberg (kevin@rosenberg.net) + * Restructure directories for Common Lisp Controller v3 compatibility + +25 Jul 2002 Kevin Rosenberg (kevin@rosenberg.net) + * Also change case of logical host in loader files + * Rework handling of logical pathnames + +05 Jul 2002 Kevin Rosenberg (kevin@rosenberg.net) + * Change case of logical host + +14 May 2002 Kevin Rosenberg (kevin@rosenberg.net) + * clsql-base.system: Added base package that can be used without + high-level SQL commands. Used for adding support for UncommonSQL. + * *.system: Reworked logical pathnames to be more consistent with + Common Lisp Controller. + * debian/*: Completed initial Debian support + +10 May 2002 Marc Battyani (marc.battyani@fractalconcept.com) + * sql/classes.cl: + * sql/transactions.cl: + Added transaction support. Functions/macros added: + with-transaction, commit-transaction, rollback-transaction, + add-transaction-commit-hook, add-transaction-rollback-hook + +04 May 2002 Marc Battyani (marc.battyani@fractalconcept.com) + * sql/sql.cl: + * sql/pool.cl: + * sql/functional.cl: + Added pool support in connect/disconnect and with-database. + Removed with-db-from-pool as with-database can now works with the connections pool + +01 May 2002 Marc Battyani (marc.battyani@fractalconcept.com) + * sql/sql.cl: + * sql/pool.cl: + * sql/classes.cl: + * sql/package.cl: + Completed connection pool. + Added with-db-from-pool macro. + +27 Apr 2002 Kevin Rosenberg (kevin@rosenberg.net) + * Multiple files: + Added initial support for connection pool + * sql/transactions.cl + Took transaction code from UncommonSQL and integrated + into CLSQL code. See file for disclaimer about why this + was added. + +23 Apr 2002 Kevin Rosenberg (kevin@rosenberg.net) + * interfaces/postgresql/postgresql-sql.cl: + Fix keyword typo in database-read-large-object + * interfaces/mysql/mysql-loader.cl + Fix loading on Win32 + * test-suite/tester-clsql.cl + Fix type coercion of double-float + * doc/* + Added debian docbook catalog, made it the default + +19 Apr 2002 Marc Battyani (marc.battyani@fractalconcept.com) + * interface/postgresql/postgresql-api.cl: + * interface/postgresql/postgresql-sql.cl: + * sql/sql.cl: + * sql/db-interface.cl: + Added large objects support for postgresql. + +07 Apr 2002 Kevin Rosenberg (kevin@rosenberg.net) + * src/postgresql-socket/postgresql-socket-api.cl: + Fixed find-foreign-function call, eliminated crypt warning + * Makefiles: + Multiple improvements + * sql/usql.cl: + Moved functionality from low-level interfaces to this file + via generic functions + * test-suite/tester.cl: + Added test with acl-compat-tester, moved others to old-tests + directory. + +06 Apr 2002 Kevin Rosenberg (kevin@rosenberg.net) + * src/usql.cl: + Reinstated commented out sections + * interfaces/postgresql/postgresql-loader.cl: + * interfaces/mysql/mysql-loader.cl: + Updated find-forieign-library support. + * interfaces/postgresql-socket/postgresql-socket-package.cl: + Fixed require form for Lispworks (Thanks Marc Battyani!) + * interfaces/postgresql-socket/postgresql-socket-api.cl: + Fixed eval of def-function for crypt library. + +31 Mar 2002 Kevin Rosenberg (kevin@rosenberg.net) + * Added interface to support USQL high-level rouines + +29 Mar 2002 Kevin Rosenberg (kevin@rosenberg.net) + * Separated db-interface and conditions from sql/sql.cl + * Improved foreign library loading testing + * interfaces/postgresql/postgresql-api.cl + Added PQisBusy function + * interfaces/clsql-uffi/clsql-uffi.cl + Fixed sign error for 64-bit processing + +27 Mar 2002 Kevin Rosenberg (kevin@rosenberg.net) + * interfaces/postgresql-socket/postgresql-socket-api.cl: + Fixes to read-double-from-socket. Added 64-bit integer support. + * test-suite/xptest-clsql.cl + Added testint for 64-bit integers + * Additons to installation docs + +26 Mar 2002 Kevin Rosenberg (kevin@rosenberg.net) + * interfaces/postgresql-socket/postgresql-socket-api.cl: + Implemented direct socket reading for field type :double + * Added usage information for :types to documentation + * interfaces/mysql/mysql-sql.cl: Fixed type specifiers in atoi, + atol, atof calls + * interfaces/clsql-uffi: Created new directory. Split common + interface routines that use UFFI into this package. Required + especially to support direct reading of 64-bit integers into + bignums and bypassing temporary strings. + * test-clsql.cl: Updated to test postgresql-socket's + read-double-from-socket function. + * test-suite/xptest-clsql.cl + Started work on test suite + +25 Mar 2002 Kevin Rosenberg (kevin@rosenberg.net) + * interfaces/mysql/mysql-api.cl: Added mysql-fetch-fields, + mysql-fetch-field-direct Got :auto types working + * interfaces/postgresql/postgresql-api.cl + * interfaces/postgresql-socket/postgresql-socket-api.cl + Added pgsql-field-types enum. Got :auto types working. + * multiple-files + Renamed :field-types to :types. + +24 Mar 2002 Kevin Rosenberg (kevin@rosenberg.net) + * Added field-types parameter to query, database-query, + database-query-result-set, map-query. Haven't added code + to utilize field types, yet. + * Changed postgresql-socket result set from cons to a structure + * Updated test-clsql.cl to use automated testing with a config + file + * Changed return types of field accessors from cstring to + (* :unsigned-char). This prepares for being able to use specified + type conversions when taking field data into lisp. + * Added field-type processing for most interfaces. Not done yet. + +23 Mar 2002 Kevin Rosenberg (kevin@rosenberg.net) + * doc/ref.sgml: Updated MAP-QUERY example to use + *read-default-float-format* (John Foderaro) + * Extensive work to foreign library loaders and .system files to + check for successful loading of foreign libraries. + * Modified test-clsql.cl to allow more modularity and + automated testing in future release. + * mysql/mysql-sql.lisp: Added field types + +01 Jan 2002 Kevin Rosenberg (kevin@rosenberg.net) + * mysql/mysql-sql.lisp: + - Added support for Allegro CL and Lispworks using UFFI layer + - Changed database-connect to use mysql-real-connect. This way, + can avoid using double (unwind-protect) + - Changed database-connect to have MySQL library allocate space + for MYSQL structure. This will make the code more robust in + the event that MySQL library changes the size of the mysql-mysql + structure. @@ -0,0 +1,5 @@ +Refer to the main documentation file for installation instructions. + +Documentation is availabe as a PDF file in doc/clsql.pdf and as HTML +files in doc/html.tar.gz. + diff --git a/LATEST-TEST-RESULTS b/LATEST-TEST-RESULTS new file mode 100644 index 0000000..72725ce --- /dev/null +++ b/LATEST-TEST-RESULTS @@ -0,0 +1,81 @@ +Note from Russ Tyndall <russ@acceleration.net> 2015-03-23 : + +This is the current results of running the test suite against all the database +backends I have accessible, on SBCL / UBUNTU64bit. It would be great to +continue improving the test suite and skip tests that reliably fail, improve +tests so that all pass. In the interim, I would like know that I am not +increasing the number of failing tests + +:mysql +No tests failed. +18 of 310 Tests skipped + +:odbc MSSQL2000/5 +No tests failed. +22 of 306 Tests skipped: + +:odbc postgres +*couldnt get them to run - foreign lib problems* + +:postgres-socket :postgres-socket-3 +4 out of 308 total tests failed: :TIME/PG/OODML/USEC, :TIME/PG/OODML/NO-USEC, + :TIME/PG/FDML/USEC, :FDML/SELECT/36. +20 of 308 Tests skipped: + +:sqlite3 +1 out of 308 total tests failed: :FDDL/INDEX/3. +20 of 308 Tests skipped: + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +Version 3.0.0 run on August 3, 2004 on x86, x86_64, and PowerPC platforms + +POSTGRESQL: All 233 tests passed (x86, Allegro CL Enterprise Edition). +POSTGRESQL-SOCKET/POSTGRESQL: All 233 tests passed (x86, Allegro CL Enterprise Edition). +MYSQL: All 213 tests passed (x86, Allegro CL Enterprise Edition). +SQLITE: All 224 tests passed (x86, Allegro CL Enterprise Edition). +ODBC/POSTGRESQL: All 232 tests passed (x86, Allegro CL Enterprise Edition). +ODBC/MYSQL: All 213 tests passed (x86, Allegro CL Enterprise Edition). +ORACLE: All 227 tests passed (x86, Allegro CL Enterprise Edition). +AODBC/UNKNOWN: 23 of 231 tests failed (x86, Allegro CL Enterprise Edition). +POSTGRESQL: All 233 tests passed (X86, CMU Common Lisp). +POSTGRESQL-SOCKET/POSTGRESQL: All 233 tests passed (X86, CMU Common Lisp). +MYSQL: All 213 tests passed (X86, CMU Common Lisp). +SQLITE: All 224 tests passed (X86, CMU Common Lisp). +ODBC/POSTGRESQL: All 232 tests passed (X86, CMU Common Lisp). +ODBC/MYSQL: All 213 tests passed (X86, CMU Common Lisp). +ORACLE: All 227 tests passed (X86, CMU Common Lisp). +POSTGRESQL: All 233 tests passed (NIL, LispWorks). +POSTGRESQL-SOCKET/POSTGRESQL: All 233 tests passed (NIL, LispWorks). +MYSQL: All 213 tests passed (NIL, LispWorks). +SQLITE: All 224 tests passed (NIL, LispWorks). +ODBC/POSTGRESQL: All 232 tests passed (NIL, LispWorks). +ODBC/MYSQL: All 213 tests passed (NIL, LispWorks). +ORACLE: All 227 tests passed (NIL, LispWorks). +POSTGRESQL: All 233 tests passed (X86, SBCL). +POSTGRESQL-SOCKET/POSTGRESQL: All 233 tests passed (X86, SBCL). +MYSQL: All 213 tests passed (X86, SBCL). +SQLITE: All 224 tests passed (X86, SBCL). +ODBC/POSTGRESQL: All 232 tests passed (X86, SBCL). +ODBC/MYSQL: All 213 tests passed (X86, SBCL). +ORACLE: All 227 tests passed (X86, SBCL). + +POSTGRESQL: All 233 tests passed (64-bit AMD64, Allegro CL Enterprise Edition). +POSTGRESQL-SOCKET/POSTGRESQL: All 233 tests passed (64-bit AMD64, Allegro CL Enterprise Edition). +MYSQL: All 223 tests passed (64-bit AMD64, Allegro CL Enterprise Edition). +SQLITE: All 224 tests passed (64-bit AMD64, Allegro CL Enterprise Edition). +ORACLE: All 227 tests passed (64-bit AMD64, Allegro CL Enterprise Edition). + +POSTGRESQL: All 233 tests passed (PowerPC, SBCL). +POSTGRESQL-SOCKET/POSTGRESQL: All 233 tests passed (PowerPC, SBCL). +MYSQL: All 217 tests passed (PowerPC, SBCL). +SQLITE: All 224 tests passed (PowerPC, SBCL). +ODBC/POSTGRESQL: All 232 tests passed (PowerPC, SBCL). +ODBC/MYSQL: All 217 tests passed (PowerPC, SBCL). +POSTGRESQL: All 233 tests passed (ppc, OpenMCL). +POSTGRESQL-SOCKET/POSTGRESQL: All 233 tests passed (ppc, OpenMCL). +MYSQL: All 217 tests passed (ppc, OpenMCL). +SQLITE: All 224 tests passed (ppc, OpenMCL). +ODBC/POSTGRESQL: All 232 tests passed (ppc, OpenMCL). +ODBC/MYSQL: All 217 tests passed (ppc, OpenMCL). + diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..0565167 --- /dev/null +++ b/Makefile @@ -0,0 +1,50 @@ +#!/usr/bin/make +########################################################################## +# FILE IDENTIFICATION +# +# Name: Makefile +# Purpose: Makefile for the CLSQL package +# Programer: Kevin M. Rosenberg +# Date Started: Mar 2002 +# +# This file, part of CLSQL, is Copyright (c) 2002-2010 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. +########################################################################## + + +PKG := clsql +DEBPKG := cl-sql +SUBDIRS := sql tests uffi db-mysql db-aodbc db-odbc \ + db-postgresql db-postgresql-socket db-sqlite \ + db-oracle +DOCSUBDIRS:=doc + +include Makefile.common + +LIBSUBDIRS=db-mysql uffi +.PHONY: subdirs $(LIBSUBDIRS) + +.PHONY: all +all: $(LIBSUBDIRS) + +$(LIBSUBDIRS): + $(MAKE) -C $@ + +SOURCE_FILES=interfaces sql cmucl-compat doc test-suite Makefile VERSION \ + COPYING.CLSQL COPYING.MaiSQL README INSTALL ChangeLog NEWS TODO \ + set-logical.cl clsql-uffi.system \ + clsql.system clsql-aodbc.system clsql-mysql.system \ + clsql-postgresql.system clsql-postgresql-socket.system + +.PHONY: doc +doc: + $(MAKE) -C doc + +.PHONY:dist +dist: clean + @$(MAKE) -C doc $@ + + diff --git a/Makefile.common b/Makefile.common new file mode 100644 index 0000000..358d75d --- /dev/null +++ b/Makefile.common @@ -0,0 +1,44 @@ +UNAME=$(shell uname) +UNAME_A=$(shell uname -a) +DARWIN_LIBC=$(shell file /usr/lib/libc.dylib) + +OS_AIX=$(shell expr "$(UNAME)" : '.*AIX.*') +OS_SUNOS=$(shell expr "$(UNAME)" : '.*SunOS.*') +OS_DARWIN=$(shell expr "$(UNAME)" : '.*Darwin.*') +ifneq ($(OS_DARWIN),0) + OS_DARWIN64=$(shell expr "$(DARWIN_LIBC)" : '.*x86_64.*') +else + OS_DARWIN64=0 +endif +OS_CYGWIN=$(shell expr "$(UNAME)" : '.*CYGWIN.*') +OS_LINUX=$(shell expr "$(UNAME)" : '.*Linux.*') +OS_LINUX64=$(shell expr "$(UNAME_A)" : '.*Linux.*x86_64.*') +ifneq ("$(wildcard /usr/bin/dpkg-buildflags)","") +DPKG_BUILDFLAGS=1 +else +DPKG_BUILDFLAGS=0 +endif + +all: + + +.PHONY: clean +clean: + @rm -rf .bin + @rm -f *.ufsl *.fsl *.fas *.x86f *.sparcf *.fasl *.pfsl *.dfsl + @rm -f *.fasla8 *.fasla16 *.faslm8 *.faslm16 *.faslmt + @rm -f *~ *.bak *.orig *.err \#*\# .#* + @rm -f *.so *.a + @rm -rf debian/cl-sql +ifneq ($(SUBDIRS)$(DOCSUBDIRS),) + @set -e; for i in $(SUBDIRS) $(DOCSUBDIRS); do \ + $(MAKE) -C $$i $@; done +endif + +distclean: clean +ifneq ($(SUBDIRS)$(DOCSUBDIRS),) + @set -e; for i in $(SUBDIRS) $(DOCSUBDIRS); do \ + $(MAKE) -C $$i $@; done +endif + +.SUFFIXES: # No default suffixes @@ -0,0 +1,47 @@ +Sep 14 2006 +----------- +Version 4.0.0 release with incompatible backward change: + - using ANSI mode for MySQL backend + - reducing case changes in SQL output for symbols which will have an effect + for users of mlisp (Allegro "Modern" Lisp) . + - Add support for generating quoted strings in SQL output when +specifying table names as strings rather than symbols. This may have +an effect on applications that use strings as table names and use +inconsistent case in the table names. Previously, those varying case +strings would be mapped to a canonical case unquoted SQL output. But +to accomodate users which need to specify case in table names, this +mapping has been removed. +See ChangeLog entry for details. + +Dec 30 2006 +----------- +Version 3.8.0 released with incompatible backward change. See +the ChangeLog entry for details. + + +Aug 3 2006 +---------- +CLSQL 3.0 has been released. The 3.0 release of CLSQL is a major +rewrite compared to version 2.0. New features include: + + - Full CommonSQL backward compatibility with native documentation while + retaining and adding many improvements beyond the CommonSQL + standard. + - Extensive (233 tests) regression suite + - Addition of ODBC and Oracle backends + +I wish to acknowledge Marcus Pearce's significant contribution to this +release. He has performed the initial port of Uncommonsql to CLSQL as +well as the initial regression suite and most of the new +documentation. He has contributed to many of the re-design decisions +and new code for CLSQL. + +CLSQL's home is http://clsql.kpe.io + +Enjoy! + +Kevin Rosenberg + + + + @@ -0,0 +1,43 @@ +CLSQL is a Common Lisp to SQL engine interface by Kevin M. +Rosenberg. It includes both functional and object oriented subsystems +for data definition and manipulation as well as an integrated symbolic +SQL syntax. + +CLSQL supports a number of RDBMS and uses the UFFI (http://uffi.kpe.io) +library for compatibility with Allegro CL, Lispworks, CMUCL, SBCL and +OpenMCL. + +CLSQL has incorporated code from the following projects. At this point +in 2004, development of has stopped on these incorporated projects. + - Pierre Mai's MaiSQL + - onShore Development's UncommonSQL + - Paul Meurer's SQL/ODBC + - Cadabra's Oracle interface + +CLSQL's home is http://clsql.kpe.io. + +Documentation is available as a PDF file in doc/clsql.pdf and as HTML +files in doc/html.tar.gz. + + +CONTRIBUTING +------------ + +If you would like to report a bug please do so through the clsql +mailing list. http://lists.kpe.io/mailman/listinfo/CLSQL + +Patches are welcome. It will be much easier for us to incorporate if +you use [git](http://git-scm.com/). Please keep distinct changes in +seperate patches as it makes it much easier to review. If you have +something small to to send to the mailing list `git format-patch` is +your friend. + +If you have a bigger set of patches then I recommend creating a fork +on github from https://github.com/UnwashedMeme/clsql. Once your +patches are available there either issue a pull request or let us know +about it on the mailing list. + +* http://help.github.com/ has some excellent tutorials on getting + started. +* http://git-scm.com/book is an excellent in depth tutorial on how to + use git effectively. @@ -0,0 +1,27 @@ +TESTS TO ADD + +* Test that ":db-kind :key" adds an index for that key. This is complicated by + different backends showing autogenerated primary key in different ways. +* :db-constraint tests +* Number and Char field types +* symbol slot +* generalized-boolean slot +* tests for db-reader and db-writer + +OPTIMIZATIONS + +* Revisit result-type list creation, perhaps caching +* Rework LIST-ATTRIBUTE-TYPES and LIST-INDEXES such that they exhibit their + current behaviours using single database queries. +* Possible use of cached attribute type information for operations which + insert/update records as mentioned in the CommonSQL user guide. +* Extend caching of generated SQL strings to more complex expressions which + are likely to be repeatedly executed many times. + +POSSIBLE EXTENSIONS + +* improve large object api and extend to databases beyond postgresql +* add support for prepared statements + +RACE CONDITIONS +* sql/databases.lisp: *connected-databases* is shared globally but not modified in a threadsafe manner. diff --git a/clsql-aodbc.asd b/clsql-aodbc.asd new file mode 100644 index 0000000..42e4cdb --- /dev/null +++ b/clsql-aodbc.asd @@ -0,0 +1,37 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: clsql-aodbc.asd +;;;; Purpose: ASDF definition file for CLSQL AODBC backend +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Aug 2002 +;;;; +;;;; This file, part of CLSQL, is Copyright (c) 2002-2010 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-aodbc-system (:use #:asdf #:cl)) +(in-package #:clsql-aodbc-system) + +#+(and allegro (not allegro-cl-trial)) +(defsystem clsql-aodbc + :name "cl-sql-aodbc" + :author "Kevin M. Rosenberg <kmr@debian.org>" + :maintainer "Kevin M. Rosenberg <kmr@debian.org>" + :licence "Lessor Lisp General Public License" + :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) + :components + ((:module :db-aodbc + :components + ((:file "aodbc-package") + (:file "aodbc-sql" :depends-on ("aodbc-package")))))) + +#-(and allegro (not allegro-cl-trial)) +(defsystem clsql-aodbc) diff --git a/clsql-cffi.asd b/clsql-cffi.asd new file mode 100644 index 0000000..fb6fb7d --- /dev/null +++ b/clsql-cffi.asd @@ -0,0 +1,27 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: clsql-cffi.asd +;;;; Purpose: ASDF System definition for CLSQL using CFFI-UFFI-COMPAT +;;;; Author: Kevin M. Rosenberg +;;;; Created: Jan 2010 +;;;; +;;;; 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. +;;;; ************************************************************************* + +(push :clsql-cffi cl:*features*) + +(defpackage #:clsql-cffi-system (:use #:asdf #:cl)) +(in-package #:clsql-cffi-system) + +(defsystem clsql-cffi + :name "CLSQL-CFFI" + :author "Kevin Rosenberg <kevin@rosenberg.net>" + :maintainer "Kevin M. Rosenberg <kmr@debian.org>" + :licence "Lessor Lisp General Public License" + :description "CLSQL using CFFI-UFFI-COMPAT interface" + :depends-on (clsql) + :components nil) diff --git a/clsql-db2.asd b/clsql-db2.asd new file mode 100644 index 0000000..4007017 --- /dev/null +++ b/clsql-db2.asd @@ -0,0 +1,40 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: clsql-db2.asd +;;;; Purpose: ASDF definition file for CLSQL Db2 backend +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Aug 2002 +;;;; +;;;; 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. +;;;; ************************************************************************* + +(defpackage #:clsql-db2-system (:use #:asdf #:cl)) +(in-package #:clsql-db2-system) + +;;; System definition + +(defsystem clsql-db2 + :name "clsql-db2" + :author "Kevin M. Rosenberg <kmr@debian.org>" + :maintainer "Kevin M. Rosenberg <kmr@debian.org>" + :licence "Lessor Lisp General Public License" + :description "Common Lisp SQL Db2 Driver" + :long-description "cl-sql-db2 package provides a database driver to the Db2 database system." + + :depends-on (clsql-uffi) + :components + ((:module :db-db2 + :components + ((:file "db2-package") + (:file "db2-loader" :depends-on ("db2-package")) + (:file "foreign-resources" :depends-on ("db2-package")) + (:file "db2-constants" :depends-on ("db2-package")) + (:file "db2-api" :depends-on ("db2-constants" "db2-loader")) + (:file "db2-sql" :depends-on ("db2-api" "foreign-resources")) + (:file "db2-objects" :depends-on ("db2-sql")))))) diff --git a/clsql-mysql.asd b/clsql-mysql.asd new file mode 100644 index 0000000..12b8479 --- /dev/null +++ b/clsql-mysql.asd @@ -0,0 +1,92 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: clsql-mysql.asd +;;;; Purpose: ASDF definition file for CLSQL MySQL backend +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Aug 2002 +;;;; +;;;; This file, part of CLSQL, is Copyright (c) 2002-2010 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-mysql-system (:use #:asdf #:cl)) +(in-package #:clsql-mysql-system) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (unless (find-package 'uffi) + (asdf:operate 'asdf:load-op 'uffi))) + +(defvar *library-file-dir* + (merge-pathnames "db-mysql/" + (make-pathname :name nil :type nil + :defaults *load-truename*))) + +(defclass clsql-mysql-source-file (c-source-file) + ()) + +(defmethod output-files ((o compile-op) (c clsql-mysql-source-file)) + (let* ((library-file-type + (funcall (intern (symbol-name'#:default-foreign-library-type) + (symbol-name '#:uffi)))) + (found (some #'(lambda (dir) + (probe-file (make-pathname :directory dir + :name (component-name c) + :type library-file-type))) + '((:absolute "usr" "lib" "clsql"))))) + (list (if found + found + (make-pathname :name (component-name c) + :type library-file-type + :defaults *library-file-dir*))))) + +(defmethod perform ((o load-op) (c clsql-mysql-source-file)) + t) + +(defmethod operation-done-p ((o load-op) (c clsql-mysql-source-file)) + (and (find-package '#:mysql) + (symbol-function (intern (symbol-name '#:mysql-get-client-info) + (find-package '#:mysql))) + t)) + +(defmethod perform ((o compile-op) (c clsql-mysql-source-file)) + (unless (operation-done-p o c) + #-(or win32 win64 windows mswindows) + (unless (zerop (run-shell-command + #-freebsd "cd ~A; make" + #+freebsd "cd ~A; gmake" + (namestring *library-file-dir*))) + (error 'operation-error :component c :operation o)))) + +(defmethod operation-done-p ((o compile-op) (c clsql-mysql-source-file)) + (or (and (probe-file #p"/usr/lib/clsql/clsql_mysql.so") t) + (let ((lib (make-pathname :defaults (component-pathname c) + :type (uffi:default-foreign-library-type)))) + (and (probe-file lib) (probe-file (component-pathname c)) + (> (file-write-date lib) (file-write-date (component-pathname c))))))) + +;;; System definition + +(defsystem :clsql-mysql + :name "cl-sql-mysql" + :author "Kevin M. Rosenberg <kmr@debian.org>" + :maintainer "Kevin M. Rosenberg <kmr@debian.org>" + :licence "Lessor Lisp General Public License" + :description "Common Lisp SQL MySQL Driver" + :long-description "cl-sql-mysql package provides a database driver to the MySQL database system." + + :depends-on (clsql clsql-uffi) + :components + ((:module :db-mysql + :components + ((:file "mysql-package") + (:clsql-mysql-source-file "clsql_mysql" :depends-on ("mysql-package")) + (:file "mysql-loader" :depends-on ("mysql-package" "clsql_mysql")) + (:file "mysql-client-info" :depends-on ("mysql-loader")) + (:file "mysql-api" :depends-on ("mysql-client-info")) + (:file "mysql-sql" :depends-on ("mysql-api")) + (:file "mysql-objects" :depends-on ("mysql-sql")))))) diff --git a/clsql-odbc.asd b/clsql-odbc.asd new file mode 100644 index 0000000..30c04cf --- /dev/null +++ b/clsql-odbc.asd @@ -0,0 +1,39 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: clsql-odbc.asd +;;;; Purpose: ASDF definition file for CLSQL ODBC backend +;;;; Author: Kevin M. Rosenberg +;;;; Created: April 2004 +;;;; +;;;; This file, part of CLSQL, is Copyright (c) 200d42 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-odbc-system (:use #:asdf #:cl)) +(in-package #:clsql-odbc-system) + +(defsystem clsql-odbc + :name "clsql-odbc" + :author "Kevin M. Rosenberg <kmr@debian.org>" + :maintainer "Kevin M. Rosenberg <kmr@debian.org>" + :licence "Lessor Lisp General Public License" + :description "Common Lisp SQL ODBC Driver" + :long-description "cl-sql-odbc package provides a database driver to the ODBC database system." + + :depends-on (clsql clsql-uffi) + :components + ((:module :db-odbc + :components + ((:file "odbc-package") + (:file "odbc-loader" :depends-on ("odbc-package")) + (:file "odbc-constants" :depends-on ("odbc-loader")) + (:file "odbc-ff-interface" :depends-on ("odbc-constants")) + (:file "odbc-api" :depends-on ("odbc-ff-interface" "odbc-constants")) + (:file "odbc-dbi" :depends-on ("odbc-api")) + (:file "odbc-sql" :depends-on ("odbc-dbi")))))) + diff --git a/clsql-oracle.asd b/clsql-oracle.asd new file mode 100644 index 0000000..62d9eb7 --- /dev/null +++ b/clsql-oracle.asd @@ -0,0 +1,40 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: clsql-oracle.asd +;;;; Purpose: ASDF definition file for CLSQL Oracle backend +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Aug 2002 +;;;; +;;;; 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. +;;;; ************************************************************************* + +(defpackage #:clsql-oracle-system (:use #:asdf #:cl)) +(in-package #:clsql-oracle-system) + +;;; System definition + +(defsystem clsql-oracle + :name "clsql-oracle" + :author "Kevin M. Rosenberg <kmr@debian.org>" + :maintainer "Kevin M. Rosenberg <kmr@debian.org>" + :licence "Lessor Lisp General Public License" + :description "Common Lisp SQL Oracle Driver" + :long-description "cl-sql-oracle package provides a database driver to the Oracle database system." + + :depends-on (clsql-uffi) + :components + ((:module :db-oracle + :components + ((:file "oracle-package") + (:file "oracle-loader" :depends-on ("oracle-package")) + (:file "foreign-resources" :depends-on ("oracle-package")) + (:file "oracle-constants" :depends-on ("oracle-package")) + (:file "oracle-api" :depends-on ("oracle-constants" "oracle-loader")) + (:file "oracle-sql" :depends-on ("oracle-api" "foreign-resources")) + (:file "oracle-objects" :depends-on ("oracle-sql")))))) diff --git a/clsql-postgresql-socket.asd b/clsql-postgresql-socket.asd new file mode 100644 index 0000000..2051b7a --- /dev/null +++ b/clsql-postgresql-socket.asd @@ -0,0 +1,38 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: clsql-postgresql-socket.asd +;;;; Purpose: ASDF file for CLSQL PostgresSQL socket backend +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Aug 2002 +;;;; +;;;; 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-postgresql-socket-system (:use #:asdf #:cl)) +(in-package #:clsql-postgresql-socket-system) + +;;; System definition + +(defsystem clsql-postgresql-socket + :name "cl-sql-postgresql-socket" + :author "Kevin M. Rosenberg <kmr@debian.org>" + :maintainer "Kevin M. Rosenberg <kmr@debian.org>" + :licence "Lessor Lisp General Public License" + :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 md5 #-:clsql-cffi uffi #+:clsql-cffi cffi-uffi-compat #+sbcl sb-bsd-sockets) + :components + ((:module :db-postgresql-socket + :components + ((:file "postgresql-socket-package") + (:file "postgresql-socket-api" + :depends-on ("postgresql-socket-package")) + (:file "postgresql-socket-sql" + :depends-on ("postgresql-socket-api")))))) diff --git a/clsql-postgresql-socket3.asd b/clsql-postgresql-socket3.asd new file mode 100644 index 0000000..cd6a6d8 --- /dev/null +++ b/clsql-postgresql-socket3.asd @@ -0,0 +1,41 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: clsql-postgresql-socket.asd +;;;; Purpose: ASDF file for CLSQL PostgresSQL socket (protocol vs 3) backend +;;;; Programmer: Russ Tyndall +;;;; Date Started: Sept 2009 +;;;; +;;;; $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-postgresql-socket-system (:use #:asdf #:cl)) +(in-package #:clsql-postgresql-socket-system) + +;;; System definition + +(defsystem clsql-postgresql-socket3 + :name "cl-sql-postgresql-socket3" + :author "Russ Tyndall <russ@acceleration.net>" + :maintainer "Russ Tyndall <russ@acceleration.net>" + :licence "Lessor Lisp General Public License" + :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 + md5 + :cl-postgres + (:feature sbcl sb-bsd-sockets)) + :components + ((:module :db-postgresql-socket3 + :serial T + :components ((:file "package") + (:file "api") + (:file "sql"))))) diff --git a/clsql-postgresql.asd b/clsql-postgresql.asd new file mode 100644 index 0000000..5c73bba --- /dev/null +++ b/clsql-postgresql.asd @@ -0,0 +1,37 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: clsql-postgresql.asd +;;;; Purpose: ASDF file for CLSQL PostgresSQL backend +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Aug 2002 +;;;; +;;;; 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-postgresql-system (:use #:asdf #:cl)) +(in-package #:clsql-postgresql-system) + +#+(and allegro macosx) (push "so" excl::*load-foreign-types*) + +(defsystem clsql-postgresql + :name "cl-sql-postgresql" + :author "Kevin M. Rosenberg <kmr@debian.org>" + :maintainer "Kevin M. Rosenberg <kmr@debian.org>" + :licence "Lessor Lisp General Public License" + :description "Common Lisp PostgreSQL API Driver" + :long-description "cl-sql-postgresql package provides a the database driver for the PostgreSQL API." + + :depends-on (clsql clsql-uffi) + :components + ((:module :db-postgresql + :components + ((:file "postgresql-package") + (:file "postgresql-loader" :depends-on ("postgresql-package")) + (:file "postgresql-api" :depends-on ("postgresql-loader")) + (:file "postgresql-sql" :depends-on ("postgresql-api")))))) diff --git a/clsql-sqlite.asd b/clsql-sqlite.asd new file mode 100644 index 0000000..a8538dc --- /dev/null +++ b/clsql-sqlite.asd @@ -0,0 +1,36 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: clsql-sqlite.asd +;;;; Purpose: ASDF file for CLSQL SQLite backend +;;;; Programmer: Aurelio Bignoli +;;;; Date Started: Aug 2003 +;;;; +;;;; This file, part of CLSQL, is Copyright (c) 2003 by Aurelio Bignoli +;;;; +;;;; 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-sqlite-system (:use #:asdf #:cl)) +(in-package #:clsql-sqlite-system) + +(defsystem clsql-sqlite + :name "cl-sql-sqlite" + :author "Aurelio Bignoli <aurelio@bignoli.it>" + :maintainer "Aurelio Bignoli" + :licence "Lessor Lisp General Public License" + :description "Common Lisp SQLite Driver" + :long-description "cl-sql-sqlite package provides a database driver to SQLite database library." + + + :depends-on (clsql clsql-uffi) + :components + ((:module :db-sqlite + :components + ((:file "sqlite-package") + (:file "sqlite-loader" :depends-on ("sqlite-package")) + (:file "sqlite-api" :depends-on ("sqlite-loader")) + (:file "sqlite-sql" :depends-on ("sqlite-api")))))) diff --git a/clsql-sqlite3.asd b/clsql-sqlite3.asd new file mode 100644 index 0000000..f83d2dd --- /dev/null +++ b/clsql-sqlite3.asd @@ -0,0 +1,37 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: clsql-sqlite3.asd +;;;; Purpose: ASDF file for CLSQL SQLite3 backend +;;;; Programmer: Aurelio Bignoli +;;;; Date Started: Oct 2004 +;;;; +;;;; This file, part of CLSQL, is Copyright (c) 2004 by Aurelio Bignoli +;;;; +;;;; 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-sqlite3-system (:use #:asdf #:cl)) +(in-package #:clsql-sqlite3-system) + +(defsystem clsql-sqlite3 + :name "cl-sql-sqlite3" + :author "Aurelio Bignoli <aurelio@bignoli.it>" + :maintainer "Aurelio Bignoli" + :licence "Lessor Lisp General Public License" + :description "Common Lisp Sqlite3 Driver" + :long-description "cl-sql-sqlite3 package provides a database driver to SQLite Versione 3 database library." + + + :depends-on (clsql clsql-uffi) + :components + ((:module :db-sqlite3 + :components + ((:file "sqlite3-package") + (:file "sqlite3-loader" :depends-on ("sqlite3-package")) + (:file "sqlite3-api" :depends-on ("sqlite3-loader")) + (:file "sqlite3-sql" :depends-on ("sqlite3-api")) + (:file "sqlite3-methods" :depends-on ("sqlite3-sql")))))) diff --git a/clsql-tests.asd b/clsql-tests.asd new file mode 100644 index 0000000..f0280fc --- /dev/null +++ b/clsql-tests.asd @@ -0,0 +1,60 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; File: clsql-tests.asd +;;;; Authors: Marcus Pearce and Kevin Rosenberg +;;;; Created: 30/03/2004 +;;;; +;;;; 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 #:cl-user) +(defpackage #:clsql-tests-system (:use #:asdf #:cl)) +(in-package #:clsql-tests-system) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (unless (find-package '#:uffi) + (asdf:operate 'asdf:load-op 'uffi))) + +(defsystem clsql-tests + :name "CLSQL Tests" + :author "" + :maintainer "" + :version "" + :licence "" + :description "A regression test suite for CLSQL." + :depends-on (clsql rt) + :components + ((:module tests + :serial t + :components ((:file "package") + (:file "utils") + (:file "test-init") + (:file "datasets") + (:file "ds-employees") + (:file "ds-nodes") + (:file "ds-artists") + (:file "benchmarks") + (:file "test-internal") + (:file "test-basic") + (:file "test-time") + (:file "test-connection") + (:file "test-fddl") + (:file "test-fdml") + (:file "test-ooddl") + (:file "test-oodml") + (:file "test-syntax") + (:file "test-pool") + ; #-uffi:no-i18n (:file "test-i18n") + )))) + +(defmethod perform ((o test-op) (c (eql (find-system 'clsql-tests)))) + (operate 'load-op 'clsql) + (unless (funcall (intern (symbol-name '#:run-tests) + (find-package '#:clsql-tests))) + (error "test-op failed"))) diff --git a/clsql-uffi.asd b/clsql-uffi.asd new file mode 100644 index 0000000..90e77de --- /dev/null +++ b/clsql-uffi.asd @@ -0,0 +1,38 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: clsql-uffi.asd +;;;; Purpose: ASDF definition file for CLSQL UFFI Helper package +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Aug 2002 +;;;; +;;;; This file, part of CLSQL, is Copyright (c) 2002-2010 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 clsql-uffi-system (:use #:asdf #:cl)) +(in-package clsql-uffi-system) + +(defsystem clsql-uffi + :name "cl-sql-base" + :author "Kevin M. Rosenberg <kmr@debian.org>" + :maintainer "Kevin M. Rosenberg <kmr@debian.org>" + :licence "Lessor Lisp General Public License" + :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 (clsql #-:clsql-cffi (:version uffi "2.0") + #+:clsql-cffi cffi-uffi-compat) + + :components + ((:module :uffi + :components + ((:file "clsql-uffi-package") + (:file "clsql-uffi-loader" :depends-on ("clsql-uffi-package")) + (:file "clsql-uffi" :depends-on ("clsql-uffi-package")))))) diff --git a/clsql.asd b/clsql.asd new file mode 100644 index 0000000..4f00950 --- /dev/null +++ b/clsql.asd @@ -0,0 +1,115 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: clsql.asd +;;;; Purpose: ASDF System definition for CLSQL +;;;; Authors: Marcus Pearce and Kevin M. Rosenberg +;;;; Created: March 2004 +;;;; +;;;; 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 #:clsql-system (:use #:asdf #:cl)) +(in-package #:clsql-system) + +#+(and clisp (not :clsql-cffi)) +(asdf:operate 'asdf:load-op 'clsql-cffi) + +;; need to load uffi for below perform :after method +(eval-when (:compile-toplevel :load-toplevel :execute) + #+:clsql-cffi + (unless (find-package 'cffi-uffi-compat) + #+quicklisp + (ql:quickload :cffi-uffi-compat) + #-quicklisp + (asdf:operate 'asdf:load-op 'cffi-uffi-compat)) + #-:clsql-cffi + (unless (find-package 'uffi) + (asdf:operate 'asdf:load-op 'uffi))) + +(defsystem clsql + :name "CLSQL" + :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 provides low-level +database interfaces as well as a functional and an object +oriented interface." + :version "6.4" + :components + ((:module sql + :components + ((:module base + :pathname "" + :components + ((:file "cmucl-compat") + (:file "package") + (:file "kmr-mop" :depends-on ("package")) + (:file "base-classes" :depends-on ("package")) + (:file "conditions" :depends-on ("base-classes")) + (:file "db-interface" :depends-on ("conditions")) + (:file "decimals" :depends-on ("package" "db-interface")) + (:file "utils" :depends-on ("package" "db-interface")) + (:file "time" :depends-on ("package" "conditions" "utils")) + (:file "generics" :depends-on ("package")))) + (:module database + :pathname "" + :components + ((:file "initialize") + (:file "database" :depends-on ("initialize")) + (:file "recording" :depends-on ("database")) + (:file "pool" :depends-on ("database"))) + :depends-on (base)) + (:module syntax + :pathname "" + :components ((:file "expressions") + (:file "operations" + :depends-on ("expressions")) + (:file "syntax" :depends-on ("operations"))) + :depends-on (database)) + (:module functional + :pathname "" + :components ((:file "fdml") + (:file "transaction" :depends-on ("fdml")) + #+clisp (:file "ansi-loop") + (:file "loop-extension" + :depends-on ("fdml" #+clisp "ansi-loop")) + (:file "fddl" :depends-on ("fdml"))) + :depends-on (syntax)) + (:module object + :pathname "" + :components ((:file "metaclasses") + (:file "ooddl" :depends-on ("metaclasses")) + (:file "oodml" :depends-on ("ooddl"))) + :depends-on (functional)) + (:module generic + :pathname "" + :components ((:file "generic-postgresql") + (:file "generic-odbc") + (:file "sequences") + (:file "command-object")) + :depends-on (functional)))))) + + +(defmethod perform ((o test-op) (c (eql (find-system 'clsql)))) + (operate 'load-op 'clsql-tests) + (operate 'test-op 'clsql-tests :force t)) + +(defmethod perform :after ((o load-op) (c (eql (find-system 'clsql)))) + (let* ((init-var (uffi::getenv "CLSQLINIT")) + (init-file (or (when init-var (probe-file init-var)) + (probe-file + (concatenate 'string + (namestring (user-homedir-pathname)) + ".clsql-init.lisp")) + (probe-file "/etc/clsql-init.lisp") + #+(or mswin windows win32 win64 mswindows) + (probe-file "c:\\etc\\clsql-init.lisp")))) + (when init-file (load init-file)))) + diff --git a/db-aodbc/Makefile b/db-aodbc/Makefile new file mode 100644 index 0000000..31dc910 --- /dev/null +++ b/db-aodbc/Makefile @@ -0,0 +1,6 @@ +SUBDIRS := + +include ../Makefile.common + +.PHONY: distclean +distclean: clean diff --git a/db-aodbc/aodbc-package.lisp b/db-aodbc/aodbc-package.lisp new file mode 100644 index 0000000..40d08f5 --- /dev/null +++ b/db-aodbc/aodbc-package.lisp @@ -0,0 +1,28 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: aodbc-package.cl +;;;; Purpose: Package definition for CLSQL AODBC backend +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Feb 2002 +;;;; +;;;; 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. +;;;; ************************************************************************* + +(in-package #:cl-user) + +#+allegro +(eval-when (:compile-toplevel :load-toplevel :execute) + (require :aodbc-v2)) +#-allegro (warn "This system requires Allegro's AODBC library to operate") + +(defpackage #:clsql-aodbc + (:nicknames #:aodbc) + (:use #:common-lisp #:clsql-sys) + (:export #:aodbc-database) + (:documentation "This is the CLSQL interface to Allegro's AODBC")) diff --git a/db-aodbc/aodbc-sql.lisp b/db-aodbc/aodbc-sql.lisp new file mode 100644 index 0000000..98f9ec8 --- /dev/null +++ b/db-aodbc/aodbc-sql.lisp @@ -0,0 +1,102 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: aodbc-sql.cl +;;;; Purpose: Low-level interface for CLSQL AODBC backend +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Feb 2002 +;;;; +;;;; 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. +;;;; ************************************************************************* + +(in-package #:clsql-aodbc) + +;; interface foreign library loading routines +(defmethod clsql-sys:database-type-library-loaded ((database-type (eql :aodbc))) + "T if foreign library was able to be loaded successfully. " + (when (find-package :dbi) ;; finds Allegro's DBI (AODBC) package + t)) + +(defmethod clsql-sys:database-type-load-foreign ((databae-type (eql :aodbc))) + t) + +(when (find-package :dbi) + (clsql-sys:database-type-load-foreign :aodbc)) + + +;; AODBC interface + +(defclass aodbc-database (generic-odbc-database) + ((aodbc-db-type :accessor database-aodbc-db-type :initform :unknown))) + +(defmethod database-name-from-spec (connection-spec + (database-type (eql :aodbc))) + (check-connection-spec connection-spec database-type (dsn user password)) + (destructuring-bind (dsn user password) connection-spec + (declare (ignore password)) + (concatenate 'string dsn "/" user))) + +(defmethod database-connect (connection-spec (database-type (eql :aodbc))) + (check-connection-spec connection-spec database-type (dsn user password)) + #+aodbc-v2 + (destructuring-bind (dsn user password) connection-spec + (handler-case + (make-instance 'aodbc-database + :name (database-name-from-spec connection-spec :aodbc) + :database-type :aodbc + :dbi-package (find-package '#:dbi) + :odbc-conn + (dbi:connect :user user + :password password + :data-source-name dsn)) + (sql-error (e) + (error e)) + (error () ;; Init or Connect failed + (error 'sql-connection-error + :database-type database-type + :connection-spec connection-spec + :message "Connection failed"))))) + + +(defmethod database-query (query-expression (database aodbc-database) + result-types field-names) + #+aodbc-v2 + (handler-case + (dbi:sql query-expression + :db (clsql-sys::odbc-conn database) + :types result-types + :column-names field-names) + #+ignore + (error () + (error 'sql-database-data-error + :database database + :expression query-expression + :message "Query failed")))) + +(defmethod database-create (connection-spec (type (eql :aodbc))) + (warn "Not implemented.")) + +(defmethod database-destroy (connection-spec (type (eql :aodbc))) + (warn "Not implemented.")) + +(defmethod database-probe (connection-spec (type (eql :aodbc))) + (warn "Not implemented.")) + +;;; Backend capabilities + +(defmethod database-underlying-type ((database aodbc-database)) + (database-aodbc-db-type database)) + +(defmethod db-backend-has-create/destroy-db? ((db-type (eql :aodbc))) + nil) + +(defmethod database-initialize-database-type ((database-type (eql :aodbc))) + t) + +(when (clsql-sys:database-type-library-loaded :aodbc) + (clsql-sys:initialize-database-type :database-type :aodbc)) diff --git a/db-db2/Makefile b/db-db2/Makefile new file mode 100644 index 0000000..e6f2448 --- /dev/null +++ b/db-db2/Makefile @@ -0,0 +1,23 @@ +#!/usr/bin/make +########################################################################## +# FILE IDENTIFICATION +# +# Name: Makefile +# Purpose: Makefile for CLSQL Db2 interface +# Author: Kevin M. Rosenberg +# Created: May 2004 +# +# This file, part of CLSQL, is Copyright (c) 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. +########################################################################## + + +SUBDIRS= + +include ../Makefile.common + +.PHONY: distclean +distclean: clean diff --git a/db-db2/db2-api.lisp b/db-db2/db2-api.lisp new file mode 100644 index 0000000..42d2609 --- /dev/null +++ b/db-db2/db2-api.lisp @@ -0,0 +1,110 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: db2.lisp +;;;; Purpose: Package definition for CLSQL Db2 interface +;;;; +;;;; 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-db2) + + +;; +;; Opaque pointer types +;; + +(uffi:def-foreign-type cli-handle :pointer-void) +(uffi:def-foreign-type cli-pointer :pointer-void) +(uffi:def-foreign-type cli-char :byte) +(uffi:def-foreign-type cli-ulen :unsigned-int) +(uffi:def-foreign-type cli-len :int) +(uffi:def-foreign-type cli-smallint :short) +(uffi:def-foreign-type cli-usmallint :unsigned-short) + + +(defvar +null-void-pointer+ (uffi:make-null-pointer :void)) +(defvar +null-void-pointer-pointer+ (uffi:make-null-pointer :pointer-void)) + +;;; Check an CLI return code for erroricity and signal a reasonably +;;; informative condition if so. +;;; +;;; ERRHP provides an error handle which can be used to find +;;; subconditions; if it's not provided, subcodes won't be checked. +;;; +;;; NULLS-OK says that a NULL-VALUE-RETURNED subcondition condition is +;;; normal and needn't cause any signal. An error handle is required +;;; to detect this subcondition, so it doesn't make sense to set ERRHP +;;; unless NULLS-OK is set. + +(defmacro def-cli-routine ((c-cli-symbol lisp-cli-fn) c-return &rest c-parms) + (let ((ll (mapcar (lambda (x) (declare (ignore x)) (gensym)) c-parms))) + `(let ((%lisp-cli-fn (uffi:def-function + (,c-cli-symbol ,(intern (concatenate 'string "%" (symbol-name lisp-cli-fn)))) + ,c-parms + :returning ,c-return))) + (defun ,lisp-cli-fn (,@ll &key database nulls-ok) + (let ((result (funcall %lisp-cli-fn ,@ll))) + (case result + (#.SQL_SUCCESS + SQL_SUCCESS) + (#.SQL_SUCCESS_WITH_INFO + (format *standard-output* "sucess with info") + SQL_SUCCESS) + (#.SQL_ERROR + (error 'sql-database-error + :error-id result + :message + (format nil "DB2 error" result))) + (t + (error 'sql-database-error + :message + (format nil "DB2 unknown error, code=~A" result))))))))) + + +(defmacro def-raw-cli-routine + ((c-cli-symbol lisp-cli-fn) c-return &rest c-parms) + (let ((ll (mapcar (lambda (x) (declare (ignore x)) (gensym)) c-parms))) + `(let ((%lisp-cli-fn (uffi:def-function (,c-cli-symbol ,(intern (concatenate 'string "%" (symbol-name lisp-cli-fn)))) + ,c-parms + :returning ,c-return))) + (defun ,lisp-cli-fn (,@ll &key database nulls-ok) + (funcall %lisp-cli-fn ,@ll))))) + + +(def-cli-routine ("SQLAllocHandle" sql-alloc-handle) + :int + (fHandleType cli-smallint) + (hInput cli-handle) + (phOuput (* cli-handle))) + +(def-cli-routine ("SQLConnect" sql-connect) + :int + (hDb cli-handle) + (server :cstring) + (server-len cli-smallint) + (user :cstring) + (user-len cli-smallint) + (password :cstring) + (passwd-len cli-smallint)) + + +;;; CLI Functions needed +;;; SQLBindParameter +;;; SQLExecDirect +;;; SQLNumResultCols +;;; SQLDescribeCol +;;; SQLColAttribute +;;; SQLRowCount +;;; SQLBindCol +;;; SQLFetch +;;; SQLGetData +;;; SQLEndTran +;;; SQLFreeHandle +;;; SQLDisconnect +;;; SQLSetConnectAttr diff --git a/db-db2/db2-constants.lisp b/db-db2/db2-constants.lisp new file mode 100644 index 0000000..7429375 --- /dev/null +++ b/db-db2/db2-constants.lisp @@ -0,0 +1,26 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: db2-constants.lisp +;;;; Purpose: Constants for CLSQL Db2 interface +;;;; +;;;; 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-db2) + +(defconstant SQL_NULL_HANDLE nil) +(defconstant SQL_HANDLE_ENV 1) +(defconstant SQL_HANDLE_DBC 2) +(defconstant SQL_HANDLE_STMT 3) +(defconstant SQL_NTS -3) + +(defconstant SQL_ERROR -1) +(defconstant SQL_SUCCESS 0) +(defconstant SQL_SUCCESS_WITH_INFO 1) + diff --git a/db-db2/db2-loader.lisp b/db-db2/db2-loader.lisp new file mode 100644 index 0000000..5e5251b --- /dev/null +++ b/db-db2/db2-loader.lisp @@ -0,0 +1,52 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: db2-loader.lisp +;;;; Purpose: Foreign library loader for CLSQL Db2 interface +;;;; +;;;; 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-db2) + +(defparameter *db2-lib-path* + (let ((db2-home (getenv "DB2_HOME"))) + (when db2-home + (make-pathname :directory + (append + (pathname-directory + (parse-namestring (concatenate 'string db2-home "/"))) + (list "lib")))))) + +(defparameter *db2-library-filenames* + (if *db2-lib-path* + (list (merge-pathnames "libdb2" *db2-lib-path*) + "libdb2") + "libdb2")) + +(defvar *db2-supporting-libraries* '("c") + "Used only by CMU. List of library flags needed to be passed to ld to +load the Db2 client library succesfully. If this differs at your site, +set to the right path before compiling or loading the system.") + +(defvar *db2-library-loaded* nil + "T if foreign library was able to be loaded successfully") + +(defmethod clsql-sys:database-type-library-loaded ((database-type (eql :db2))) + *db2-library-loaded*) + +(defmethod clsql-sys:database-type-load-foreign ((database-type (eql :db2))) + (clsql-uffi:find-and-load-foreign-library *db2-library-filenames* + :module "clsql-db2" + :supporting-libraries + *db2-supporting-libraries*) + (setq *db2-library-loaded* t)) + +(clsql-sys:database-type-load-foreign :db2) + + diff --git a/db-db2/db2-objects.lisp b/db-db2/db2-objects.lisp new file mode 100644 index 0000000..90e65b1 --- /dev/null +++ b/db-db2/db2-objects.lisp @@ -0,0 +1,15 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: db2-objects.lisp +;;;; +;;;; 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-db2) + diff --git a/db-db2/db2-package.lisp b/db-db2/db2-package.lisp new file mode 100644 index 0000000..c51dc6c --- /dev/null +++ b/db-db2/db2-package.lisp @@ -0,0 +1,23 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: db2-package.cl +;;;; Purpose: Package definition for CLSQL Db2 interface +;;;; +;;;; 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 #:cl-user) + +(defpackage #:clsql-db2 + (:use #:common-lisp #:clsql-sys #:clsql-uffi) + (:export #:db2-database + #:*db2-server-version* + #:*db2-so-load-path* + #:*db2-so-libraries*) + (:documentation "This is the CLSQL interface to Db2.")) diff --git a/db-db2/db2-sql.lisp b/db-db2/db2-sql.lisp new file mode 100644 index 0000000..aa7901e --- /dev/null +++ b/db-db2/db2-sql.lisp @@ -0,0 +1,70 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: db2-sql.lisp +;;;; +;;;; 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-db2) + +(defmethod database-initialize-database-type ((database-type (eql :db2))) + t) + +(defclass db2-database (database) + ((henv :initform nil :allocation :class :initarg :henv :accessor henv) + (hdbc :initform nil :initarg :hdbc :accessor hdbc))) + + +(defmethod database-name-from-spec (connection-spec + (database-type (eql :db2))) + (check-connection-spec connection-spec database-type (dsn user password)) + (destructuring-bind (dsn user password) connection-spec + (declare (ignore password)) + (concatenate 'string dsn "/" user))) + +(defmethod database-connect (connection-spec (database-type (eql :db2))) + (check-connection-spec connection-spec database-type (dsn user password)) + (destructuring-bind (server user password) connection-spec + (handler-case + (let ((db (make-instance 'db2-database + :name (database-name-from-spec connection-spec :db2) + :database-type :db2))) + (db2-connect db server user password) + db) + (error () ;; Init or Connect failed + (error 'sql-connection-error + :database-type database-type + :connection-spec connection-spec + :message "Connection failed"))))) + + +;; API Functions + +(uffi:def-type handle-type cli-handle) +(uffi:def-type handle-ptr-type (* cli-handle)) + +(defmacro deref-vp (foreign-object) + `(the handle-type (uffi:deref-pointer (the handle-ptr-type ,foreign-object) cli-handle))) + +(defun db2-connect (db server user password) + (let ((henv (uffi:allocate-foreign-object 'cli-handle)) + (hdbc (uffi:allocate-foreign-object 'cli-handle))) + (sql-alloc-handle SQL_HANDLE_ENV SQL_NULL_HANDLE henv) + (setf (slot-value db 'henv) henv) + (setf (slot-value db 'hdbc) hdbc) + + (sql-alloc-handle SQL_HANDLE_DBC (deref-vp henv) hdbc) + (uffi:with-cstrings ((native-server server) + (native-user user) + (native-password password)) + (sql-connect (deref-vp hdbc) + native-server SQL_NTS + native-user SQL_NTS + native-password SQL_NTS))) + db) diff --git a/db-db2/foreign-resources.lisp b/db-db2/foreign-resources.lisp new file mode 100644 index 0000000..c141bcd --- /dev/null +++ b/db-db2/foreign-resources.lisp @@ -0,0 +1,57 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; 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-db2) + +(defparameter *foreign-resource-hash* (make-hash-table :test #'equal)) + +(defstruct (foreign-resource) + (type (error "Missing TYPE.") + :read-only t) + (sizeof (error "Missing SIZEOF.") + :read-only t) + (buffer (error "Missing BUFFER.") + :read-only t) + (in-use nil :type boolean)) + + +(defun %get-resource (type sizeof) + (let ((resources (gethash type *foreign-resource-hash*))) + (car (member-if + #'(lambda (res) + (and (= (foreign-resource-sizeof res) sizeof) + (not (foreign-resource-in-use res)))) + resources)))) + +(defun %insert-foreign-resource (type res) + (let ((resource (gethash type *foreign-resource-hash*))) + (setf (gethash type *foreign-resource-hash*) + (cons res resource)))) + +(defmacro acquire-foreign-resource (type &optional size) + `(let ((res (%get-resource ,type ,size))) + (unless res + (setf res (make-foreign-resource + :type ,type :sizeof ,size + :buffer (uffi:allocate-foreign-object ,type ,size))) + (%insert-foreign-resource ',type res)) + (claim-foreign-resource res))) + +(defun free-foreign-resource (ares) + (setf (foreign-resource-in-use ares) nil) + ares) + +(defun claim-foreign-resource (ares) + (setf (foreign-resource-in-use ares) t) + ares) + + + diff --git a/db-mysql/Makefile b/db-mysql/Makefile new file mode 100644 index 0000000..cf7c71d --- /dev/null +++ b/db-mysql/Makefile @@ -0,0 +1,85 @@ +#!/usr/bin/make +# FILE IDENTIFICATION +# +# Name: Makefile +# Purpose: Makefile for CLSQL MySQL interface +# Programer: Kevin M. Rosenberg +# Date Started: Mar 2002 +# +# 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. + +SUBDIRS= + +include ../Makefile.common + +base=clsql_mysql +source=$(base).c +object=$(base).o +shared_lib=$(base).so +shared64_lib=$(base)64.so +dylib=$(base).dylib + +.PHONY: all +all: $(shared_lib) + +CFLAGS:=-I /usr/local/include/mysql -I /usr/include/mysql -I /sw/include/mysql -I /opt/local/include/mysql -I /opt/local/include/mysql55/mysql -I /usr/local/mysql/include +LDFLAGS:=-L/usr/local/lib64/mysql -L/usr/local/lib/mysql -L/usr/lib64/mysql -L/usr/lib/mysql -L/sw/lib -L/opt/local/lib/mysql -L/opt/local/lib/mysql5/mysql -L/usr/local/mysql/lib -L/usr/lib/gcc/i686-pc-cygwin/3.4.4 -lmysqlclient -lz -lc + +CFLAGS32:=-I /usr/local/include/mysql -I /usr/include/mysql -I /sw/include/mysql -I /opt/local/include/mysql -I /opt/local/include/mysql5/mysql -I /usr/local/mysql/include -m32 +LDFLAGS32:=-L/lib32 -L/usr/lib32 -lmysqlclient -lz -lc + +ifneq ($(OS_CYGWIN),0) + CFLAGS:=-I /cygdrive/c/Program\ Files/MySQL/MySQL\ Server\ 5.0/include + LDFLAGS:=-L/usr/local/lib64/mysql -L/usr/local/lib/mysql -L/usr/lib/mysql -L/sw/lib -L/opt/local/lib/mysql -L/usr/lib/gcc/i686-pc-cygwin/3.4.4 -lmysqlclient -lpthread -lz -lm -lgcc -lc +endif +ifneq ($(OS_DPKG_BUILDFLAGS),0) + CFLAGS:=$(CFLAGS) $(shell dpkg-buildflags --get CFLAGS) + LDFLAGS:=$(LDFLAGS) $(shell env DEB_BUILD_MAINT_OPTIONS=hardening=+all,-pie dpkg-buildflags --get LDFLAGS | sed "s/-Wl\|,/ /ig") +endif + +$(shared_lib): $(source) Makefile +ifneq ($(OS_AIX),0) + gcc $(CFLAGS) -c -D_BSD -D_NO_PROTO -D_NONSTD_TYPES -D_MBI=void $(source) + make_shared $(LDFLAGS) -o $(shared_lib) $(object) +else + ifneq ($(OS_SUNOS),0) + cc $(CFLAGS) -KPIC -c $(source) -o $(object) + cc -G $(object) $(LDFLAGS) -o $(shared_lib) + else + ifneq ($(OS_DARWIN64),0) + cc $(CFLAGS) -arch x86_64 -arch i386 -bundle /usr/lib/bundle1.o -flat_namespace -undefined suppress $(source) -o $(dylib) + cc -arch x86_64 -arch i386 -bundle /usr/lib/bundle1.o -flat_namespace -undefined suppress /usr/lib/libz.dylib -o z.dylib + else + ifneq ($(OS_DARWIN),0) + cc $(CFLAGS) -arch i386 -bundle /usr/lib/bundle1.o -flat_namespace -undefined suppress $(source) -o $(dylib) + cc -arch i386 -bundle /usr/lib/bundle1.o -flat_namespace -undefined suppress /usr/lib/libz.dylib -o z.dylib + else + ifneq ($(OS_CYGWIN),0) + gcc $(CFLAGS) -DWIN32 -c $(source) -o $(object) + ld -shared -soname=$(base) $(object) $(LDFLAGS) -o $(shared_lib) + else + ifneq ($(OS_LINUX64),0) + gcc $(CFLAGS) -fPIC -c $(source) -o $(object) + gcc $(LDFLAGS) -fPIC -shared -Wl,-soname=$(base) -lc $(object) -o $(shared64_lib) + rm $(object) + @echo "Ensure that you have multiarch i386 build tools and libraries if you want to build 32-bit library" + -gcc $(CFLAGS32) -fPIC -c $(source) -o $(object) + -gcc $(LDFLAGS) -fPIC -shared -Wl,-soname=$(base) -lc $(object) $(LDFLAGS32) -o $(shared_lib) + else + gcc $(CFLAGS) -fPIC -c $(source) -o $(object) + gcc -fPIC -shared -Wl,-soname=$(base) $(object) $(LDFLAGS) -o $(shared_lib) + endif + endif + endif + endif + endif +endif + rm -f $(object) + +.PHONY: distclean +distclean: clean + @rm -f $(dylib) $(shared_lib) $(shared64_lib) $(object) z.dylib diff --git a/db-mysql/Makefile.msvc b/db-mysql/Makefile.msvc new file mode 100755 index 0000000..176c559 --- /dev/null +++ b/db-mysql/Makefile.msvc @@ -0,0 +1,40 @@ +# -*- Mode: Makefile -*- +########################################################################### +# FILE IDENTIFICATION +# +# Name: Makefile.msvc +# Purpose: Makefile for the CLSQL UFFI helper package (MSVC) +# Author: Kevin M. Rosenberg +# Created: Mar 2002 +# +# This file, part of CLSQL, is Copyright (c) 2002-2010 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. +########################################################################### + + +BASE=clsql_mysql + +# Set to the directory where you have installed mysql's library +MYSQL_DIR=c:/Program Files/MySQL/MySQL Server 5.1/ +MYSQL_LIB_FILE=$(MYSQL_DIR)lib\opt\mysqlclient.lib +MYSQL_INCLUDE=$(MYSQL_DIR)include + +# Nothing to configure beyond here + +SRC=$(BASE).c +OBJ=$(BASE).obj +DLL=$(BASE).dll +LIB=$(BASE).lib + + +$(DLL): $(SRC) $(MYSQL_LIB_FILE) + echo "LD" + echo $(MYSQL_LIB_FILE) + cl /MD /LD -D_MT /DWIN32=1 /D__LCC__=1 /I"$(MYSQL_INCLUDE)" $(SRC) $(MYSQL_LIB_FILE) + del $(OBJ) $(BASE).exp + +clean: + del /q $(DLL) diff --git a/db-mysql/clsql_mysql.c b/db-mysql/clsql_mysql.c new file mode 100644 index 0000000..ebbb8e1 --- /dev/null +++ b/db-mysql/clsql_mysql.c @@ -0,0 +1,157 @@ +/**************************************************************************** + * FILE IDENTIFICATION + * + * Name: clsql-mysql.c + * Purpose: Helper functions for mysql.cl to handle 64-bit parts of API + * Programmer: Kevin M. Rosenberg + * Date Started: Mar 2002 + * + * 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. + ***************************************************************************/ + +#if defined(WIN32)||defined(WIN64) +#include <windows.h> + +BOOL WINAPI DllEntryPoint(HINSTANCE hinstdll, DWORD fdwReason, + LPVOID lpvReserved) +{ + return 1; +} + +#define DLLEXPORT __declspec(dllexport) + +#else +#define DLLEXPORT +#endif + + +#include <mysql.h> + +/* Need to assemble a 64-bit integer to send to MySQL */ +DLLEXPORT +void +clsql_mysql_data_seek (MYSQL_RES* res, unsigned int offset_high32, + unsigned int offset_low32) +{ + my_ulonglong offset; + + offset = offset_high32; + offset = offset << 32; + offset += offset_low32; + + mysql_data_seek (res, offset); +} + +/* The following functions are used to return 64-bit integers to Lisp. + They return the 32-bit low part and store in upper 32-bits in a + located sent via a pointer */ + +static const unsigned int bitmask_32bits = 0xFFFFFFFF; +#define lower_32bits(int64) ((unsigned int) int64 & bitmask_32bits) +#define upper_32bits(int64) ((unsigned int) (int64 >> 32)) + +DLLEXPORT +unsigned int +clsql_mysql_num_rows (MYSQL_RES* res, unsigned int* pHigh32) +{ + my_ulonglong nRows = mysql_num_rows (res); + *pHigh32 = upper_32bits(nRows); + return lower_32bits(nRows); +} + +DLLEXPORT +unsigned int +clsql_mysql_affected_rows (MYSQL* res, unsigned int* pHigh32) +{ + my_ulonglong nAffected = mysql_affected_rows (res); + *pHigh32 = upper_32bits(nAffected); + return lower_32bits(nAffected); +} + +DLLEXPORT +unsigned int +clsql_mysql_insert_id (MYSQL* mysql, unsigned int* pHigh32) +{ + my_ulonglong insert_id = mysql_insert_id (mysql); + *pHigh32 = upper_32bits(insert_id); + return lower_32bits(insert_id); +} + + +/* Accessor functions to hide the differences across MySQL versions */ + +DLLEXPORT +unsigned int +clsql_mysql_field_flags (MYSQL_FIELD* field) +{ + return field->flags; +} + + +DLLEXPORT +unsigned int +clsql_mysql_field_type (MYSQL_FIELD* field) +{ + return field->type; +} + +DLLEXPORT +char* +clsql_mysql_field_name (MYSQL_FIELD* field) +{ + return field->name; +} + +DLLEXPORT +unsigned long +clsql_mysql_field_length (MYSQL_FIELD* field) +{ + return field->length; +} + +DLLEXPORT +unsigned long +clsql_mysql_field_max_length (MYSQL_FIELD* field) +{ + return field->max_length; +} + + +#if MYSQL_VERSION_ID >= 40102 +#include <stdlib.h> + +DLLEXPORT +MYSQL_BIND* +allocate_bind (unsigned int n) +{ + return (MYSQL_BIND*) malloc (n * sizeof(MYSQL_BIND)); +} + +DLLEXPORT +void +bind_param (MYSQL_BIND bind[], unsigned int n, unsigned long length, unsigned short is_null, + void* buffer, unsigned short buffer_type, unsigned long buffer_length) +{ + *bind[n].length = length; + *bind[n].is_null = is_null; + bind[n].buffer = buffer; + bind[n].buffer_type = buffer_type; + bind[n].buffer_length = buffer_length; +} + + +DLLEXPORT +unsigned int +clsql_mysql_stmt_affected_rows (MYSQL_STMT* stmt, unsigned int* pHigh32) +{ + my_ulonglong nAffected = mysql_stmt_affected_rows (stmt); + *pHigh32 = upper_32bits(nAffected); + return lower_32bits(nAffected); +} + +#endif + diff --git a/db-mysql/mysql-api.lisp b/db-mysql/mysql-api.lisp new file mode 100644 index 0000000..19d1f91 --- /dev/null +++ b/db-mysql/mysql-api.lisp @@ -0,0 +1,559 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: mysql-api.lisp +;;;; Purpose: Low-level MySQL interface using UFFI +;;;; Programmers: Kevin M. Rosenberg based on +;;;; Original code by Pierre R. Mai +;;;; Date Started: Feb 2002 +;;;; +;;;; This file, part of CLSQL, is Copyright (c) 2002-2009 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 #:mysql) + +;;;; Modifications from original code +;;;; - Updated C-structures to conform to structures in MySQL 3.23.46 +;;;; - Changed from CMUCL interface to UFFI +;;;; - Added and call a C-helper file to support 64-bit integers +;;;; that are used in a few routines. +;;;; - Removed all references to interiors of C-structions, this will +;;;; increase robustness when MySQL's internal structures change. + +;;;; Type definitions + +;;; Basic Types + +(uffi:def-foreign-type mysql-socket :int) +(uffi:def-foreign-type mysql-bool :byte) +(uffi:def-foreign-type mysql-byte :unsigned-char) + +(uffi:def-enum mysql-net-type + (:tcp-ip + :socket + :named-pipe)) + +(uffi:def-array-pointer mysql-row (* :unsigned-char)) + +;;; MYSQL-FIELD +(uffi:def-enum mysql-field-types + (:decimal + :tiny + :short + :long + :float + :double + :null + :timestamp + :longlong + :int24 + :date + :time + :datetime + :year + :newdate + (:enum 247) + (:set 248) + (:tiny-blob 249) + (:medium-blob 250) + (:long-blob 251) + (:blob 252) + (:var-string 253) + (:string 254) + (:geometry 255))) + +(uffi:def-enum mysql-option + (:connect-timeout + :compress + :named-pipe + :init-command + :read-default-file + :read-default-group + :set-charset-dir + :set-charset-name + :local-infile + :protocol + :shared-memory-base-name + :read-timeout + :write-timeout + :use-result + :use-remote-connection + :use-embedded-connection + :guess-connection + :set-client-ip + :secure-auth + :report-data-truncation + :reconnect + :ssl-verify-server-cert)) + +(defvar +mysql-option-parameter-map+ + '((:connect-timeout . :uint-ptr) + (:compress . :none) + (:named-pipe . :none) + (:init-command . :char-ptr) + (:read-default-file . :char-ptr) + (:read-default-group . :char-ptr) + (:set-charset-dir . :char-ptr) + (:set-charset-name . :char-ptr) + (:local-infile . :uint-ptr) + (:protocol . :uint-ptr) + (:shared-memory-base-name . :char-ptr) + (:read-timeout . :uint-ptr) + (:write-timeout . :uint-ptr) + (:use-result . :none) + (:use-remote-connection . :none) + (:use-embedded-connection . :none) + (:guess-connection . :none) + (:set-client-ip . :char-ptr) + (:secure-auth . :boolean-ptr) + (:report-data-truncation . :boolean-ptr) + (:reconnect . :boolean-ptr) + (:ssl-verify-server-cert . :boolean-ptr))) + +(uffi:def-enum mysql-status + (:ready + :get-result + :use-result)) + +;;; Opaque pointers to mysql C-defined structures +(uffi:def-foreign-type mysql-mysql (* :void)) +(uffi:def-foreign-type mysql-mysql-res (* :void)) +(uffi:def-foreign-type mysql-field (* :void)) +(uffi:def-foreign-type mysql-bind (* :void)) + +;;;; The Foreign C routines +(declaim (inline mysql-init)) +(uffi:def-function "mysql_init" + ((mysql mysql-mysql)) + :module "mysql" + :returning mysql-mysql) + +;; Need to comment this out for LW 4.2.6 +;; ? bug in LW version +#-lispworks (declaim (inline mysql-real-connect)) +(uffi:def-function "mysql_real_connect" + ((mysql mysql-mysql) + (host :cstring) + (user :cstring) + (passwd :cstring) + (db :cstring) + (port :unsigned-int) + (unix-socket :cstring) + (clientflag :unsigned-long)) + :module "mysql" + :returning mysql-mysql) + +(declaim (inline mysql-close)) +(uffi:def-function "mysql_close" + ((sock mysql-mysql)) + :module "mysql" + :returning :void) + +(declaim (inline mysql-select-db)) +(uffi:def-function "mysql_select_db" + ((mysql mysql-mysql) + (db :cstring)) + :module "mysql" + :returning :int) + +(declaim (inline mysql-query)) +(uffi:def-function "mysql_query" + ((mysql mysql-mysql) + (query :cstring)) + :module "mysql" + :returning :int) + + ;;; I doubt that this function is really useful for direct Lisp usage, +;;; but it is here for completeness... + +(declaim (inline mysql-real-query)) +(uffi:def-function "mysql_real_query" + ((mysql mysql-mysql) + (query :cstring) + (length :unsigned-int)) + :module "mysql" + :returning :int) + +(declaim (inline mysql-shutdown)) +(uffi:def-function "mysql_shutdown" + ((mysql mysql-mysql)) + :module "mysql" + :returning :int) + +(declaim (inline mysql-dump-debug-info)) +(uffi:def-function "mysql_dump_debug_info" + ((mysql mysql-mysql)) + :module "mysql" + :returning :int) + +(declaim (inline mysql-refresh)) +(uffi:def-function "mysql_refresh" + ((mysql mysql-mysql) + (refresh-options :unsigned-int)) + :module "mysql" + :returning :int) + +(declaim (inline mysql-kill)) +(uffi:def-function "mysql_kill" + ((mysql mysql-mysql) + (pid :unsigned-long)) + :module "mysql" + :returning :int) + +(declaim (inline mysql-ping)) +(uffi:def-function "mysql_ping" + ((mysql mysql-mysql)) + :module "mysql" + :returning :int) + +(declaim (inline mysql-stat)) +(uffi:def-function "mysql_stat" + ((mysql mysql-mysql)) + :module "mysql" + :returning :cstring) + +(declaim (inline mysql-get-server-info)) +(uffi:def-function "mysql_get_server_info" + ((mysql mysql-mysql)) + :module "mysql" + :returning :cstring) + +(declaim (inline mysql-get-host-info)) +(uffi:def-function "mysql_get_host_info" + ((mysql mysql-mysql)) + :module "mysql" + :returning :cstring) + +(declaim (inline mysql-get-proto-info)) +(uffi:def-function "mysql_get_proto_info" + ((mysql mysql-mysql)) + :module "mysql" + :returning :unsigned-int) + +(declaim (inline mysql-list-dbs)) +(uffi:def-function "mysql_list_dbs" + ((mysql mysql-mysql) + (wild :cstring)) + :module "mysql" + :returning mysql-mysql-res) + +(declaim (inline mysql-list-tables)) +(uffi:def-function "mysql_list_tables" + ((mysql mysql-mysql) + (wild :cstring)) + :module "mysql" + :returning mysql-mysql-res) + +(declaim (inline mysql-list-fields)) +(uffi:def-function "mysql_list_fields" + ((mysql mysql-mysql) + (table :cstring) + (wild :cstring)) + :module "mysql" + :returning mysql-mysql-res) + +(declaim (inline mysql-list-processes)) +(uffi:def-function "mysql_list_processes" + ((mysql mysql-mysql)) + :module "mysql" + :returning mysql-mysql-res) + +(declaim (inline mysql-store-result)) +(uffi:def-function "mysql_store_result" + ((mysql mysql-mysql)) + :module "mysql" + :returning mysql-mysql-res) + +(declaim (inline mysql-use-result)) +(uffi:def-function "mysql_use_result" + ((mysql mysql-mysql)) + :module "mysql" + :returning mysql-mysql-res) + +(declaim (inline mysql-options)) +(uffi:def-function "mysql_options" + ((mysql mysql-mysql) + (option mysql-option) + (arg :pointer-void)) + :module "mysql" + :returning :int) + +(declaim (inline mysql-free-result)) +(uffi:def-function "mysql_free_result" + ((res mysql-mysql-res)) + :module "mysql" + :returning :void) + +(declaim (inline mysql-next-result)) +(uffi:def-function "mysql_next_result" + ((mysql mysql-mysql)) + :module "mysql" + :returning :int) + +(declaim (inline mysql-fetch-row)) +(uffi:def-function "mysql_fetch_row" + ((res mysql-mysql-res)) + :module "mysql" + :returning (* (* :unsigned-char))) + +(declaim (inline mysql-fetch-lengths)) +(uffi:def-function "mysql_fetch_lengths" + ((res mysql-mysql-res)) + :module "mysql" + :returning (* :unsigned-long)) + +(declaim (inline mysql-fetch-field)) +(uffi:def-function "mysql_fetch_field" + ((res mysql-mysql-res)) + :module "mysql" + :returning mysql-field) + +(declaim (inline mysql-field-seek)) +(uffi:def-function "mysql_field_seek" + ((res mysql-mysql-res) + (offset :unsigned-int)) + :module "mysql" + :returning :unsigned-int) + +(declaim (inline mysql-fetch-fields)) +(uffi:def-function "mysql_fetch_fields" + ((res mysql-mysql-res)) + :module "mysql" + :returning mysql-field) + +(declaim (inline mysql-fetch-field-direct)) +(uffi:def-function "mysql_fetch_field_direct" + ((res mysql-mysql-res) + (field-num :unsigned-int)) + :module "mysql" + :returning mysql-field) + +(declaim (inline mysql-escape-string)) +(uffi:def-function "mysql_escape_string" + ((to (* :unsigned-char)) + (from (* :unsigned-char)) + (length :unsigned-int)) + :module "mysql" + :returning :unsigned-int) + +(declaim (inline mysql-debug)) +(uffi:def-function "mysql_debug" + ((debug :cstring)) + :module "mysql" + :returning :void) + +(declaim (inline clsql-mysql-num-rows)) +(uffi:def-function "clsql_mysql_num_rows" + ((res mysql-mysql-res) + (p-high32 (* :unsigned-int))) + :module "clsql-mysql" + :returning :unsigned-int) + +#+(or mysql-client-v4.1 mysql-client-v5) +(uffi:def-foreign-type mysql-stmt-ptr :pointer-void) + +#+(or mysql-client-v4.1 mysql-client-v5) +(uffi:def-function "mysql_stmt_init" + ((res mysql-mysql-res)) + :module "clsql-mysql" + :returning mysql-stmt-ptr) + +#+(or mysql-client-v4.1 mysql-client-v5) +(uffi:def-function "mysql_stmt_prepare" + ((stmt mysql-stmt-ptr) + (query :cstring) + (length :unsigned-long)) + :module "clsql-mysql" + :returning :int) + +#+(or mysql-client-v4.1 mysql-client-v5) +(uffi:def-function "mysql_stmt_param_count" + ((stmt mysql-stmt-ptr)) + :module "clsql-mysql" + :returning :unsigned-int) + +#+(or mysql-client-v4.1 mysql-client-v5) +(uffi:def-function "mysql_stmt_bind_param" + ((stmt mysql-stmt-ptr) + (bind mysql-bind)) + :module "clsql-mysql" + :returning :short) + +#+(or mysql-client-v4.1 mysql-client-v5) +(uffi:def-function "mysql_stmt_bind_result" + ((stmt mysql-stmt-ptr) + (bind mysql-bind)) + :module "clsql-mysql" + :returning :short) + +#+(or mysql-client-v4.1 mysql-client-v5) +(uffi:def-function "mysql_stmt_result_metadata" + ((stmt mysql-stmt-ptr)) + :module "clsql-mysql" + :returning mysql-mysql-res) + + +#+(or mysql-client-v4.1 mysql-client-v5) +(uffi:def-function "mysql_stmt_execute" + ((stmt mysql-stmt-ptr)) + :module "clsql-mysql" + :returning :int) + +#+(or mysql-client-v4.1 mysql-client-v5) +(uffi:def-function "mysql_stmt_store_result" + ((stmt mysql-stmt-ptr)) + :module "clsql-mysql" + :returning :int) + +#+(or mysql-client-v4.1 mysql-client-v5) +(uffi:def-function "mysql_stmt_fetch" + ((stmt mysql-stmt-ptr)) + :module "clsql-mysql" + :returning :int) + +#+(or mysql-client-v4.1 mysql-client-v5) +(uffi:def-function "mysql_stmt_free_result" + ((stmt mysql-stmt-ptr)) + :module "clsql-mysql" + :returning :short) + +#+(or mysql-client-v4.1 mysql-client-v5) +(uffi:def-function "mysql_stmt_close" + ((stmt mysql-stmt-ptr)) + :module "clsql-mysql" + :returning :short) + +#+(or mysql-client-v4.1 mysql-client-v5) +(uffi:def-function "mysql_stmt_errno" + ((stmt mysql-stmt-ptr)) + :module "clsql-mysql" + :returning :unsigned-int) + +#+(or mysql-client-v4.1 mysql-client-v5) +(uffi:def-function "mysql_stmt_error" + ((stmt mysql-stmt-ptr)) + :module "clsql-mysql" + :returning :cstring) + + +;;;; Equivalents of C Macro definitions for accessing various fields +;;;; in the internal MySQL Datastructures + + +(declaim (inline mysql-num-rows)) +(defun mysql-num-rows (res) + (uffi:with-foreign-object (p-high32 :unsigned-int) + (let ((low32 (clsql-mysql-num-rows res p-high32)) + (high32 (uffi:deref-pointer p-high32 :unsigned-int))) + (if (zerop high32) + low32 + (make-64-bit-integer high32 low32))))) + +(uffi:def-function "clsql_mysql_affected_rows" + ((mysql mysql-mysql) + (p-high32 (* :unsigned-int))) + :returning :unsigned-int + :module "clsql-mysql") + +(defun mysql-affected-rows (mysql) + (uffi:with-foreign-object (p-high32 :unsigned-int) + (let ((low32 (clsql-mysql-affected-rows mysql p-high32)) + (high32 (uffi:deref-pointer p-high32 :unsigned-int))) + (if (zerop high32) + low32 + (make-64-bit-integer high32 low32))))) + +(uffi:def-function "clsql_mysql_insert_id" + ((res mysql-mysql) + (p-high32 (* :unsigned-int))) + :returning :unsigned-int + :module "clsql-mysql") + +(defun mysql-insert-id (mysql) + (uffi:with-foreign-object (p-high32 :unsigned-int) + (let ((low32 (clsql-mysql-insert-id mysql p-high32)) + (high32 (uffi:deref-pointer p-high32 :unsigned-int))) + (if (zerop high32) + low32 + (make-64-bit-integer high32 low32))))) + + +(declaim (inline mysql-num-fields)) +(uffi:def-function "mysql_num_fields" + ((res mysql-mysql-res)) + :returning :unsigned-int + :module "mysql") + +(declaim (inline clsql-mysql-eof)) +(uffi:def-function ("mysql_eof" clsql-mysql-eof) + ((res mysql-mysql-res)) + :returning :char + :module "mysql") + +(declaim (inline mysql-eof)) +(defun mysql-eof (res) + (if (zerop (clsql-mysql-eof res)) + nil + t)) + +(declaim (inline mysql-error)) +(uffi:def-function ("mysql_error" mysql-error) + ((mysql mysql-mysql)) + :returning :cstring + :module "mysql") + +(declaim (inline mysql-error-string)) +(defun mysql-error-string (mysql) + (uffi:convert-from-cstring (mysql-error mysql))) + +(declaim (inline mysql-errno)) +(uffi:def-function "mysql_errno" + ((mysql mysql-mysql)) + :returning :unsigned-int + :module "mysql") + +(declaim (inline mysql-info)) +(uffi:def-function ("mysql_info" mysql-info) + ((mysql mysql-mysql)) + :returning :cstring + :module "mysql") + +(declaim (inline mysql-info-string)) +(defun mysql-info-string (mysql) + (uffi:convert-from-cstring (mysql-info mysql))) + +(declaim (inline clsql-mysql-data-seek)) +(uffi:def-function "clsql_mysql_data_seek" + ((res mysql-mysql-res) + (offset-high32 :unsigned-int) + (offset-low32 :unsigned-int)) + :module "clsql-mysql" + :returning :void) + +(declaim (inline clsql-mysql-field-name)) +(uffi:def-function "clsql_mysql_field_name" + ((res mysql-field)) + :module "clsql-mysql" + :returning :cstring) + +(declaim (inline clsql-mysql-field-flags)) +(uffi:def-function "clsql_mysql_field_flags" + ((res mysql-field)) + :module "clsql-mysql" + :returning :unsigned-int) + +(declaim (inline clsql-mysql-field-type)) +(uffi:def-function "clsql_mysql_field_type" + ((res mysql-field)) + :module "clsql-mysql" + :returning :unsigned-int) + +(defun mysql-data-seek (res offset) + (multiple-value-bind (high32 low32) (split-64-bit-integer offset) + (clsql-mysql-data-seek res high32 low32))) diff --git a/db-mysql/mysql-client-info.lisp b/db-mysql/mysql-client-info.lisp new file mode 100644 index 0000000..9b791df --- /dev/null +++ b/db-mysql/mysql-client-info.lisp @@ -0,0 +1,51 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: mysql-client-info.lisp +;;;; Purpose: Check mysql client version +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: April 2004 +;;;; +;;;; This file, part of CLSQL, is Copyright (c) 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 #:mysql) + +(declaim (inline mysql-get-client-info)) + +(defvar *mysql-client-info* nil) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (uffi:def-function ("mysql_get_client_info" mysql-get-client-info) + () + :module "mysql" + :returning :cstring) + + (setf *mysql-client-info* (uffi:convert-from-cstring (mysql-get-client-info))) + + + (when (and (stringp *mysql-client-info*) + (plusp (length *mysql-client-info*))) + (cond + ((eql (schar *mysql-client-info* 0) #\3) + (pushnew :mysql-client-v3 cl:*features*)) + ((eql (schar *mysql-client-info* 0) #\4) + (pushnew :mysql-client-v4 cl:*features*) + (when (and (>= (length *mysql-client-info*) 3) + (string-equal "4.1" *mysql-client-info* :end2 3)) + (pushnew :mysql-client-v4.1 cl:*features*))) + ((eql (schar *mysql-client-info* 0) #\5) + (pushnew :mysql-client-v5 cl:*features*) + (when (and (>= (length *mysql-client-info*) 3) + (string-equal "5.1" *mysql-client-info* :end2 3)) + (pushnew :mysql-client-v5.1 cl:*features*))) + ((eql (schar *mysql-client-info* 0) #\6) + (pushnew :mysql-client-v6 cl:*features*)) + (t + (error "Unknown mysql client version '~A'." *mysql-client-info*))))) + diff --git a/db-mysql/mysql-loader.lisp b/db-mysql/mysql-loader.lisp new file mode 100644 index 0000000..afea3e5 --- /dev/null +++ b/db-mysql/mysql-loader.lisp @@ -0,0 +1,51 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: mysql-loader.sql +;;;; Purpose: MySQL library loader using UFFI +;;;; Author: Kevin M. Rosenberg +;;;; Created: Feb 2002 +;;;; +;;;; This file, part of CLSQL, is Copyright (c) 2002-2010 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 #:mysql) + +;; searches clsql_mysql64 to accomodate both 32-bit and 64-bit libraries on same system +(defparameter *clsql-mysql-library-candidate-names* + `(,@(when (> most-positive-fixnum (expt 2 32)) (list "clsql_mysql64")) + "clsql_mysql")) + +(defvar *mysql-library-candidate-names* + '("libmysqlclient" "libmysql")) + +(defvar *mysql-supporting-libraries* '("c") + "Used only by CMU. List of library flags needed to be passed to ld to +load the MySQL client library succesfully. If this differs at your site, +set to the right path before compiling or loading the system.") + +(defvar *mysql-library-loaded* nil + "T if foreign library was able to be loaded successfully") + +(defmethod clsql-sys:database-type-library-loaded ((database-type (eql :mysql))) + *mysql-library-loaded*) + +(defmethod clsql-sys:database-type-load-foreign ((database-type (eql :mysql))) + (unless *mysql-library-loaded* + (clsql:push-library-path clsql-mysql-system::*library-file-dir*) + + (clsql-uffi:find-and-load-foreign-library *mysql-library-candidate-names* + :module "mysql" + :supporting-libraries *mysql-supporting-libraries*) + + (clsql-uffi:find-and-load-foreign-library *clsql-mysql-library-candidate-names* + :module "clsql-mysql" + :supporting-libraries *mysql-supporting-libraries*) + (setq *mysql-library-loaded* t))) + +(clsql-sys:database-type-load-foreign :mysql) diff --git a/db-mysql/mysql-objects.lisp b/db-mysql/mysql-objects.lisp new file mode 100644 index 0000000..0a9e7b3 --- /dev/null +++ b/db-mysql/mysql-objects.lisp @@ -0,0 +1,25 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: mysql-objects.lisp +;;;; Purpose: CLSQL Object layer for MySQL +;;;; Created: May 2004 +;;;; +;;;; 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-mysql) + +(defmethod database-get-type-specifier ((type symbol) args database + (db-type (eql :mysql))) + (declare (ignore args database db-type)) + (case type + (wall-time "DATETIME") + (tinyint "TINYINT") + (smallint "SMALLINT") + (mediumint "MEDIUMINT") + (t (call-next-method)))) + diff --git a/db-mysql/mysql-package.lisp b/db-mysql/mysql-package.lisp new file mode 100644 index 0000000..74a1955 --- /dev/null +++ b/db-mysql/mysql-package.lisp @@ -0,0 +1,153 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: mysql-package.cl +;;;; Purpose: Package definition for low-level MySQL interface +;;;; Programmers: Kevin M. Rosenberg +;;;; Date Started: Feb 2002 +;;;; +;;;; 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. +;;;; ************************************************************************* + +(in-package #:cl-user) + +(defpackage #:mysql + (:use #:common-lisp #:clsql-uffi) + (:export + #:database-library-loaded + + #:mysql-socket + #:mysql-book + #:mysql-byte + #:mysql-net-type + #:mysql-net-type#tcp-ip + #:mysql-net-type#socket + #:mysql-net-type#named-pipe + #:mysql-net + #:mysql-used-mem + #:mysql-mem-root + #:mysql-field-types + #:mysql-field-types#decimal + #:mysql-field-types#tiny + #:mysql-field-types#short + #:mysql-field-types#long + #:mysql-field-types#float + #:mysql-field-types#double + #:mysql-field-types#null + #:mysql-field-types#timestamp + #:mysql-field-types#longlong + #:mysql-field-types#int24 + #:mysql-field-types#date + #:mysql-field-types#time + #:mysql-field-types#datetime + #:mysql-field-types#year + #:mysql-field-types#newdate + #:mysql-field-types#enum + #:mysql-field-types#tiny-blob + #:mysql-field-types#medium-blob + #:mysql-field-types#long-blob + #:mysql-field-types#blob + #:mysql-field-types#var-string + #:mysql-field-types#string + #:mysql-field + #:mysql-row + #:mysql-field-offset + #:mysql-row-offset + #:mysql-field-vector + #:mysql-data + #:mysql-options + #:mysql-mysql-option + #:mysql-mysql-option#connect-timeout + #:mysql-mysql-option#compress + #:mysql-mysql-option#named-pipe + #:mysql-mysql-option#init-command + #:mysql-mysql-option#read-default-file + #:mysql-mysql-option#read-default-group + #:mysql-status + #:mysql-status#ready + #:mysql-status#get-ready + #:mysql-status#use-result + #:mysql-mysql + #:mysql-mysql-res + + ;; functions + #:mysql-init + #:mysql-connect + #:mysql-real-connect + #:mysql-close + #:mysql-select-db + #:mysql-query + #:mysql-real-query + #:mysql-create-db + #:mysql-drop-db + #:mysql-shutdown + #:mysql-dump-debug-info + #:mysql-refresh + #:mysql-kill + #:mysql-ping + #:mysql-stat + #:mysql-get-server-info + #:mysql-get-client-info + #:mysql-get-host-info + #:mysql-get-proto-info + #:mysql-list-dbs + #:mysql-list-tables + #:mysql-list-fields + #:mysql-list-processes + #:mysql-store-result + #:mysql-use-result + #:mysql-options + #:mysql-free-result + #:mysql-next-result + #:mysql-row-seek + #:mysql-field-seek + #:mysql-fetch-row + #:mysql-fetch-lengths + #:mysql-fetch-field + #:mysql-fetch-fields + #:mysql-fetch-field-direct + #:mysql-escape-string + #:mysql-debug + #:mysql-num-rows + #:mysql-num-fields + #:mysql-affected-rows + #:mysql-insert-id + #:mysql-eof + #:mysql-error + #:mysql-error-string + #:mysql-errno + #:mysql-info + #:mysql-info-string + #:mysql-data-seek + + #:mysql-time + #:mysql-bind + #:mysql-stmt-param-count + #:mysql-stmt-prepare + #:mysql-stmt-execute + #:mysql-stmt-store-result + #:mysql-stmt-init + #:mysql-stmt-close-result + #:mysql-stmt-free-result + #:mysql-stmt + #:mysql-stmt-result-metadata + #:mysql-stmt-fetch + #:mysql-stmt-bind-param + #:mysql-stmt-bind-result + #:mysql-stmt-close + #:mysql-stmt-errno + #:mysql-stmt-error + + #:make-64-bit-integer + #:clsql-mysql-field-name + #:clsql-mysql-field-type + #:clsql-mysql-field-flags + + #:+mysql-option-parameter-map+ + ) + (:documentation "This is the low-level interface MySQL.")) diff --git a/db-mysql/mysql-sql.lisp b/db-mysql/mysql-sql.lisp new file mode 100644 index 0000000..1f54d44 --- /dev/null +++ b/db-mysql/mysql-sql.lisp @@ -0,0 +1,848 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: mysql-sql.lisp +;;;; Purpose: High-level MySQL interface using UFFI +;;;; Date Started: Feb 2002 +;;;; +;;;; This file, part of CLSQL, is Copyright (c) 2002-2010 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-mysql + (:use #:common-lisp #:clsql-sys #:mysql #:clsql-uffi) + (:export #:mysql-database) + (:import-from :clsql-sys + :escaped :unescaped :combine-database-identifiers + :escaped-database-identifier :unescaped-database-identifier :database-identifier + :%sequence-name-to-table :%table-name-to-sequence-name) + (:documentation "This is the CLSQL interface to MySQL.")) + +(in-package #:clsql-mysql) + +;;; Field conversion functions + +(defun result-field-names (res-ptr) + (let ((names '())) + (mysql-field-seek res-ptr 0) + (loop + (let ((field (mysql-fetch-field res-ptr))) + (when (uffi:null-pointer-p field) (return)) + (push (uffi:convert-from-cstring (clsql-mysql-field-name field)) names))) + (nreverse names))) + +(defun make-type-list-for-auto (res-ptr) + (let ((new-types '())) + (mysql-field-seek res-ptr 0) + (loop + (let ((field (mysql-fetch-field res-ptr))) + (when (uffi:null-pointer-p field) (return)) + (let* ((flags (clsql-mysql-field-flags field)) + (unsigned (plusp (logand flags 32))) + (type (clsql-mysql-field-type field))) + (push + (case type + ((#.mysql-field-types#tiny + #.mysql-field-types#short + #.mysql-field-types#int24) + (if unsigned + :uint32 + :int32)) + (#.mysql-field-types#long + (if unsigned + :uint + :int)) + (#.mysql-field-types#longlong + (if unsigned + :uint64 + :int64)) + ((#.mysql-field-types#double + #.mysql-field-types#float + #.mysql-field-types#decimal) + :double) + (otherwise + t)) + new-types)))) + (nreverse new-types))) + +(defun canonicalize-types (types res-ptr) + (when types + (let ((auto-list (make-type-list-for-auto res-ptr))) + (cond + ((listp types) + (canonicalize-type-list types auto-list)) + ((eq types :auto) + auto-list) + (t + nil))))) + +(defmethod database-initialize-database-type ((database-type (eql :mysql))) + t) + +;;(uffi:def-type mysql-mysql-ptr-def (* mysql-mysql)) +;;(uffi:def-type mysql-mysql-res-ptr-def (* mysql-mysql-res)) +(uffi:def-type mysql-mysql-ptr-def mysql-mysql) +(uffi:def-type mysql-mysql-res-ptr-def mysql-mysql-res) +(uffi:def-type mysql-row-def mysql-row) + +(defclass mysql-database (database) + ((mysql-ptr :accessor database-mysql-ptr :initarg :mysql-ptr + :type mysql-mysql-ptr-def) + (server-info :accessor database-server-info :initarg :server-info + :type string))) + +(defmethod database-type ((database mysql-database)) + :mysql) + +(defmethod database-name-from-spec (connection-spec (database-type (eql :mysql))) + (check-connection-spec connection-spec database-type + (host db user password &optional port options)) + (destructuring-bind (host db user password &optional port options) connection-spec + (declare (ignore password options)) + (concatenate 'string + (etypecase host + (null "localhost") + (pathname (namestring host)) + (string host)) + (if port + (concatenate 'string + ":" + (etypecase port + (integer (write-to-string port)) + (string port))) + "") + "/" db "/" user))) + +(defun lookup-option-code (option) + (if (assoc option +mysql-option-parameter-map+) + (symbol-value (intern + (concatenate 'string (symbol-name-default-case "mysql-option#") + (symbol-name option)) + (symbol-name '#:mysql))) + (progn + (warn "Unknown mysql option name ~A - ignoring.~%" option) + nil))) + +(defun set-mysql-options (mysql-ptr options) + (flet ((lookup-option-type (option) + (cdr (assoc option +mysql-option-parameter-map+)))) + (dolist (option options) + (if (atom option) + (let ((option-code (lookup-option-code option))) + (when option-code + (mysql-options mysql-ptr option-code uffi:+null-cstring-pointer+))) + (destructuring-bind (name . value) option + (let ((option-code (lookup-option-code name))) + (when option-code + (case (lookup-option-type name) + (:none + (mysql-options mysql-ptr option-code uffi:+null-cstring-pointer+)) + (:char-ptr + (if (stringp value) + (uffi:with-foreign-string (fs value) + (mysql-options mysql-ptr option-code fs)) + (warn "Expecting string argument for mysql option ~A, got ~A ~ +- ignoring.~%" + name value))) + (:uint-ptr + (if (integerp value) + (uffi:with-foreign-object (fo :unsigned-int) + (setf (uffi:deref-pointer fo :unsigned-int) value) + (mysql-options mysql-ptr option-code fo)) + (warn "Expecting integer argument for mysql option ~A, got ~A ~ +- ignoring.~%" + name value))) + (:boolean-ptr + (uffi:with-foreign-object (fo :byte) + (setf (uffi:deref-pointer fo :byte) + (case value + ((nil 0) 0) + (t 1))) + (mysql-options mysql-ptr option-code fo))))))))))) + +(defmethod database-connect (connection-spec (database-type (eql :mysql))) + (check-connection-spec connection-spec database-type + (host db user password &optional port options)) + (destructuring-bind (host db user password &optional port options) connection-spec + (let ((mysql-ptr (mysql-init (uffi:make-null-pointer 'mysql-mysql))) + (socket nil)) + (if (uffi:null-pointer-p mysql-ptr) + (error 'sql-connection-error + :database-type database-type + :connection-spec connection-spec + :error-id (mysql-errno mysql-ptr) + :message (mysql-error-string mysql-ptr)) + (uffi:with-cstrings ((host-native host) + (user-native user) + (password-native password) + (db-native db) + (socket-native socket)) + (when options + (set-mysql-options mysql-ptr options)) + (let ((error-occurred nil)) + (unwind-protect + (if (uffi:null-pointer-p + (mysql-real-connect + mysql-ptr host-native user-native password-native + db-native + (etypecase port + (null 0) + (integer port) + (string (parse-integer port))) + socket-native 0)) + (progn + (setq error-occurred t) + (error 'sql-connection-error + :database-type database-type + :connection-spec connection-spec + :error-id (mysql-errno mysql-ptr) + :message (mysql-error-string mysql-ptr))) + (let* ((db + (make-instance 'mysql-database + :name (database-name-from-spec connection-spec + database-type) + :database-type :mysql + :connection-spec connection-spec + :server-info (uffi:convert-from-cstring + (mysql:mysql-get-server-info mysql-ptr)) + :mysql-ptr mysql-ptr)) + (cmd "SET SESSION sql_mode='ANSI'")) + (uffi:with-cstring (cmd-cs cmd) + (if (zerop (mysql-real-query mysql-ptr cmd-cs (uffi:foreign-encoded-octet-count + cmd :encoding (encoding db)))) + db + (progn + (warn "Error setting ANSI mode for MySQL.") + db))))) + (when error-occurred (mysql-close mysql-ptr))))))))) + + +(defmethod database-disconnect ((database mysql-database)) + (mysql-close (database-mysql-ptr database)) + (setf (database-mysql-ptr database) nil) + t) + +(defmethod database-execute-command (sql-expression (database mysql-database)) + (uffi:with-cstring (sql-native sql-expression) + (let ((mysql-ptr (database-mysql-ptr database))) + (declare (type mysql-mysql-ptr-def mysql-ptr)) + (if (zerop (mysql-real-query mysql-ptr sql-native + (uffi:foreign-encoded-octet-count + sql-expression :encoding (encoding database)))) + t + (error 'sql-database-data-error + :database database + :expression sql-expression + :error-id (mysql-errno mysql-ptr) + :message (mysql-error-string mysql-ptr)))))) + + +(defmethod database-query (query-expression (database mysql-database) + result-types field-names) + (declare (optimize (speed 3))) + (let ((mysql-ptr (database-mysql-ptr database)) + (results nil) ;; all the results and column-names in reverse-order + (res-ptr nil) + (num-fields 0)) + (declare (type mysql-mysql-ptr-def mysql-ptr) + (type (or null mysql-mysql-res-ptr-def) res-ptr) + (fixnum num-fields)) + (when (database-execute-command query-expression database) + (labels + ((get-row (row lengths) + "Pull a single row value from the results" + (loop for i from 0 below num-fields + collect + (convert-raw-field + (uffi:deref-array row '(:array (* :unsigned-char)) + (the fixnum i)) + (nth i result-types) + :length + (uffi:deref-array lengths '(:array :unsigned-long) + (the fixnum i)) + :encoding (encoding database)))) + (get-result-rows () + "get all the rows out of the now valid results set" + (loop for row = (mysql-fetch-row res-ptr) + for lengths = (mysql-fetch-lengths res-ptr) + until (uffi:null-pointer-p row) + collect (get-row row lengths))) + (do-result-set () + "for a mysql-ptr, grab and return a results set" + (setf res-ptr (mysql-use-result mysql-ptr)) + (cond + ((or (null res-ptr) (uffi:null-pointer-p res-ptr)) + (unless (zerop (mysql-errno mysql-ptr)) + ;;from http://dev.mysql.com/doc/refman/5.0/en/mysql-field-count.html + ;; if mysql_use_result or mysql_store_result return a null ptr, + ;; we use a mysql_errno check to see if it had a problem or just + ;; was a query without a result. If no error, just return nil. + (error 'sql-database-data-error + :database database + :expression query-expression + :error-id (mysql-errno mysql-ptr) + :message (mysql-error-string mysql-ptr)))) + (t + (unwind-protect + (progn (setf num-fields (mysql-num-fields res-ptr) + result-types (canonicalize-types + result-types res-ptr)) + (push (get-result-rows) results) + (push (when field-names + (result-field-names res-ptr)) + results)) + (mysql-free-result res-ptr)))))) + + (loop + do (do-result-set) + while (let ((next (mysql-next-result mysql-ptr))) + (case next + (0 t) ;Successful and there are more results + (-1 nil) ;Successful and there are no more results + (t nil) ;errors + ))) + (values-list (nreverse results)))))) + + +(defstruct mysql-result-set + (res-ptr (uffi:make-null-pointer 'mysql-mysql-res) :type mysql-mysql-res-ptr-def) + (types nil :type list) + (num-fields 0 :type fixnum) + (full-set nil :type boolean)) + + +(defmethod database-query-result-set ((query-expression string) + (database mysql-database) + &key full-set result-types) + ;; TODO: REFACTOR THIS IN TERMS OF database-query or vice-versa + ;; This doesnt seem to free database results reliably, dont think + ;; that we should allow that particularly, OTOH, dont know how + ;; we support cursoring without it + (let ((mysql-ptr (database-mysql-ptr database))) + (declare (type mysql-mysql-ptr-def mysql-ptr)) + (when (database-execute-command query-expression database) + (let ((res-ptr (if full-set + (mysql-store-result mysql-ptr) + (mysql-use-result mysql-ptr)))) + (declare (type mysql-mysql-res-ptr-def res-ptr)) + (if (not (uffi:null-pointer-p res-ptr)) + (let* ((num-fields (mysql-num-fields res-ptr)) + (result-set (make-mysql-result-set + :res-ptr res-ptr + :num-fields num-fields + :full-set full-set + :types + (canonicalize-types + result-types res-ptr)))) + (if full-set + (values result-set + num-fields + (mysql-num-rows res-ptr)) + (values result-set + num-fields))) + (error 'sql-database-data-error + :database database + :expression query-expression + :error-id (mysql-errno mysql-ptr) + :message (mysql-error-string mysql-ptr)))) + ))) + +(defmethod database-dump-result-set (result-set (database mysql-database)) + (mysql-free-result (mysql-result-set-res-ptr result-set)) + t) + + +(defmethod database-store-next-row (result-set (database mysql-database) list) + (let* ((res-ptr (mysql-result-set-res-ptr result-set)) + (row (mysql-fetch-row res-ptr)) + (lengths (mysql-fetch-lengths res-ptr)) + (types (mysql-result-set-types result-set))) + (declare (type mysql-mysql-res-ptr-def res-ptr) + (type mysql-row-def row)) + (unless (uffi:null-pointer-p row) + (loop for i from 0 below (mysql-result-set-num-fields result-set) + for rest on list + do + (setf (car rest) + (convert-raw-field + (uffi:deref-array row '(:array (* :unsigned-char)) i) + (nth i types) + :length + (uffi:deref-array lengths '(:array :unsigned-long) i) + :encoding (encoding database)))) + list))) + + +;; Table and attribute introspection + +(defmethod database-list-tables ((database mysql-database) &key (owner nil)) + (declare (ignore owner)) + (cond + ((eql #\5 (char (database-server-info database) 0)) + (loop for (name type) in (database-query "SHOW FULL TABLES" database nil nil) + when (and (string-equal type "base table") + (not (and (>= (length name) 11) + (string-equal (subseq name 0 11) "_CLSQL_SEQ_")))) + collect name)) + (t + (remove-if #'(lambda (s) + (and (>= (length s) 11) + (string-equal (subseq s 0 11) "_CLSQL_SEQ_"))) + (mapcar #'car (database-query "SHOW TABLES" database nil nil)))))) + +(defmethod database-list-views ((database mysql-database) + &key (owner nil)) + (declare (ignore owner)) + (cond + ((eql #\5 (char (database-server-info database) 0)) + (loop for (name type) in (database-query "SHOW FULL TABLES" database nil nil) + when (string-equal type "view") + collect name)) + (t + nil))) + +(defmethod database-list-indexes ((database mysql-database) + &key (owner nil)) + (let ((result '())) + (dolist (table (database-list-tables database :owner owner) result) + (setq result + (append (database-list-table-indexes table database :owner owner) + result))))) + +(defmethod database-list-table-indexes (table (database mysql-database) + &key (owner nil)) + (declare (ignore owner)) + (do ((results nil) + (rows (database-query + (format nil "SHOW INDEX FROM ~A" (escaped-database-identifier + table database)) + database nil nil) + (cdr rows))) + ((null rows) (nreverse results)) + (let ((col (nth 2 (car rows)))) + (unless (find col results :test #'string-equal) + (push col results))))) + +(defmethod database-list-attributes ((table clsql-sys::%database-identifier) + (database mysql-database) + &key (owner nil) + &aux (table (unescaped-database-identifier table))) + (declare (ignore owner)) + (mapcar #'car + (database-query + (format nil "SHOW COLUMNS FROM ~A" (escaped-database-identifier + table database)) + database nil nil))) + +(defmethod database-attribute-type ((attribute clsql-sys::%database-identifier) + (table clsql-sys::%database-identifier) + (database mysql-database) + &key (owner nil) + &aux (table (unescaped-database-identifier table)) + (attribute (unescaped-database-identifier attribute))) + (declare (ignore owner)) + (let ((row (car (database-query + (format nil + "SHOW COLUMNS FROM ~A LIKE '~A'" + (escaped-database-identifier + table database) + (unescaped-database-identifier + attribute database)) + database nil nil)))) + (let* ((raw-type (second row)) + (null (third row)) + (start-length (position #\( raw-type)) + (type (if start-length + (subseq raw-type 0 start-length) + raw-type)) + (length (when start-length + (parse-integer (subseq raw-type (1+ start-length)) + :junk-allowed t)))) + (when type + (values (ensure-keyword type) length nil (if (string-equal null "YES") 1 0)))))) + +;;; Sequence functions + +(defmethod database-create-sequence (sequence-name + (database mysql-database)) + (let ((table-name (%sequence-name-to-table sequence-name database))) + (database-execute-command + (concatenate 'string "CREATE TABLE " table-name + " (id int NOT NULL PRIMARY KEY AUTO_INCREMENT)") + database) + (database-execute-command + (concatenate 'string "INSERT INTO " table-name + " VALUES (-1)") + database))) + +(defmethod database-drop-sequence (sequence-name + (database mysql-database)) + (database-execute-command + (concatenate 'string "DROP TABLE " + (%sequence-name-to-table sequence-name database)) + database)) + +(defmethod database-list-sequences ((database mysql-database) + &key (owner nil)) + (declare (ignore owner)) + (mapcan #'(lambda (s) + (let ((sn (%table-name-to-sequence-name (car s)))) + (and sn (list (car s) sn)))) + (database-query "SHOW TABLES" database nil nil))) + +(defmethod database-set-sequence-position (sequence-name + (position integer) + (database mysql-database)) + (database-execute-command + (format nil "UPDATE ~A SET id=~A" (%sequence-name-to-table sequence-name database) + position) + database) + (mysql:mysql-insert-id (clsql-mysql::database-mysql-ptr database))) + +(defmethod database-sequence-next (sequence-name (database mysql-database)) + (without-interrupts + (database-execute-command + (concatenate 'string "UPDATE " (%sequence-name-to-table sequence-name database) + " SET id=LAST_INSERT_ID(id+1)") + database) + (mysql:mysql-insert-id (clsql-mysql::database-mysql-ptr database)))) + +(defmethod database-sequence-last (sequence-name (database mysql-database)) + (without-interrupts + (caar (database-query + (concatenate 'string "SELECT id from " + (%sequence-name-to-table sequence-name database)) + database :auto nil)))) + +(defmethod database-last-auto-increment-id ((database mysql-database) table column) + (declare (ignore table column)) + (car (query "SELECT LAST_INSERT_ID();" + :flatp t :field-names nil + :database database))) + +(defmethod database-create (connection-spec (type (eql :mysql))) + (destructuring-bind (host name user password) connection-spec + (let ((database (database-connect (list host "" user password) + type))) + (setf (slot-value database 'clsql-sys::state) :open) + (unwind-protect + (database-execute-command (format nil "create database ~A" name) database) + (database-disconnect database))))) + +(defmethod database-destroy (connection-spec (type (eql :mysql))) + (destructuring-bind (host name user password) connection-spec + (let ((database (database-connect (list host "" user password) + type))) + (setf (slot-value database 'clsql-sys::state) :open) + (unwind-protect + (database-execute-command (format nil "drop database ~A" name) database) + (database-disconnect database))))) + +(defmethod database-probe (connection-spec (type (eql :mysql))) + (when (find (second connection-spec) (database-list connection-spec type) + :test #'string-equal) + t)) + +(defmethod database-list (connection-spec (type (eql :mysql))) + (destructuring-bind (host name user password &optional port options) connection-spec + (declare (ignore options)) + (let ((database (database-connect (list host (or name "mysql") + user password port) type))) + (unwind-protect + (progn + (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-sys::state) :closed)))))) + + +;;; Prepared statements + +(defclass mysql-stmt () + ((database :initarg :database :reader database) + (stmt :initarg :stmt :accessor stmt) + (input-bind :initarg :input-bind :reader input-bind) + (output-bind :initarg :output-bind :reader output-bind) + (types :initarg :types :reader types) + (result-set :initarg :result-set :reader result-set) + (num-fields :initarg :num-fields :reader num-fields) + (field-names :initarg :field-names :accessor stmt-field-names) + (length-ptr :initarg :length-ptr :reader length-ptr) + (is-null-ptr :initarg :is-null-ptr :reader is-null-ptr) + (result-types :initarg :result-types :reader result-types))) + +(defun clsql-type->mysql-type (type) + (cond + ((in type :null) mysql-field-types#null) + ((in type :int :integer) mysql-field-types#long) + ((in type :short) mysql-field-types#short) + ((in type :bigint) mysql-field-types#longlong) + ((in type :float :double :number) mysql-field-types#double) + ((and (consp type) (in (car type) :char :string :varchar)) mysql-field-types#var-string) + ((or (eq type :blob) (and (consp type) (in (car type) :blob))) mysql-field-types#var-string) + (t + (error 'sql-user-error + :message + (format nil "Unknown clsql type ~A." type))))) + +#+mysql-client-v4.1 +(defmethod database-prepare (sql-stmt types (database mysql-database) result-types field-names) + (let* ((mysql-ptr (database-mysql-ptr database)) + (stmt (mysql-stmt-init mysql-ptr))) + (when (uffi:null-pointer-p stmt) + (error 'sql-database-error + :error-id (mysql-errno mysql-ptr) + :message (mysql-error-string mysql-ptr))) + + (uffi:with-cstring (native-query sql-stmt) + (unless (zerop (mysql-stmt-prepare stmt native-query (uffi:foreign-encoded-octet-count + sql-stmt :encoding (encoding database)))) + (mysql-stmt-close stmt) + (error 'sql-database-error + :error-id (mysql-errno mysql-ptr) + :message (mysql-error-string mysql-ptr)))) + + (unless (= (mysql-stmt-param-count stmt) (length types)) + (mysql-stmt-close stmt) + (error 'sql-database-error + :message + (format nil "Mysql param count (~D) does not match number of types (~D)" + (mysql-stmt-param-count stmt) (length types)))) + + (let ((rs (mysql-stmt-result-metadata stmt))) + (when (uffi:null-pointer-p rs) + (warn "mysql_stmt_result_metadata returned NULL") + #+nil + (mysql-stmt-close stmt) + #+nil + (error 'sql-database-error + :message "mysql_stmt_result_metadata returned NULL")) + + (let ((input-bind (uffi:allocate-foreign-object 'mysql-bind (length types))) + (mysql-types (mapcar 'clsql-type->mysql-type types)) + field-vec num-fields is-null-ptr output-bind length-ptr) + + (print 'a) + (dotimes (i (length types)) + (let* ((binding (uffi:deref-array input-bind '(:array mysql-bind) i))) + (setf (uffi:get-slot-value binding 'mysql-bind 'mysql::buffer-type) + (nth i mysql-types)) + (setf (uffi:get-slot-value binding 'mysql-bind 'mysql::buffer-length) 0))) + + (print 'b) + (unless (uffi:null-pointer-p rs) + (setq field-vec (mysql-fetch-fields rs) + num-fields (mysql-num-fields rs) + is-null-ptr (uffi:allocate-foreign-object :byte num-fields) + output-bind (uffi:allocate-foreign-object 'mysql-bind num-fields) + length-ptr (uffi:allocate-foreign-object :unsigned-long num-fields)) + (dotimes (i num-fields) + (declare (fixnum i)) + (let* ((field (uffi:deref-array field-vec '(:array mysql-field) i)) + (type (uffi:get-slot-value field 'mysql-field 'type)) + (binding (uffi:deref-array output-bind '(:array mysql-bind) i))) + (setf (uffi:get-slot-value binding 'mysql-bind 'mysql::buffer-type) type) + + (setf (uffi:get-slot-value binding 'mysql-bind 'mysql::buffer-length) 0) + #+need-to-allocate-foreign-object-for-this + (setf (uffi:get-slot-value binding 'mysql-bind 'mysql::is-null) + (+ i (uffi:pointer-address is-null-ptr))) + #+need-to-allocate-foreign-object-for-this + (setf (uffi:get-slot-value binding 'mysql-bind 'length) + (+ (* i 8) (uffi:pointer-address length-ptr))) + + (case type + ((#.mysql-field-types#var-string #.mysql-field-types#string + #.mysql-field-types#tiny-blob #.mysql-field-types#blob + #.mysql-field-types#medium-blob #.mysql-field-types#long-blob) + (setf (uffi:get-slot-value binding 'mysql-bind 'mysql::buffer-length) 1024) + (setf (uffi:get-slot-value binding 'mysql-bind 'mysql::buffer) + (uffi:allocate-foreign-object :unsigned-char 1024))) + (#.mysql-field-types#tiny + (setf (uffi:get-slot-value binding 'mysql-bind 'mysql::buffer) + (uffi:allocate-foreign-object :byte))) + (#.mysql-field-types#short + (setf (uffi:get-slot-value binding 'mysql-bind 'mysql::buffer) + (uffi:allocate-foreign-object :short))) + (#.mysql-field-types#long + (setf (uffi:get-slot-value binding 'mysql-bind 'mysql::buffer) + ;; segfaults if supply :int on amd64 + (uffi:allocate-foreign-object :long))) + #+64bit + (#.mysql-field-types#longlong + (setf (uffi:get-slot-value binding 'mysql-bind 'mysql::buffer) + (uffi:allocate-foreign-object :long))) + (#.mysql-field-types#float + (setf (uffi:get-slot-value binding 'mysql-bind 'mysql::buffer) + (uffi:allocate-foreign-object :float))) + (#.mysql-field-types#double + (setf (uffi:get-slot-value binding 'mysql-bind 'mysql::buffer) + (uffi:allocate-foreign-object :double))) + ((#.mysql-field-types#time #.mysql-field-types#date + #.mysql-field-types#datetime #.mysql-field-types#timestamp) + (uffi:allocate-foreign-object 'mysql-time)) + (t + (error "mysql type ~D not supported." type))))) + + (unless (zerop (mysql-stmt-bind-result stmt output-bind)) + (mysql-stmt-close stmt) + (error 'sql-database-error + :error-id (mysql-stmt-errno stmt) + :message (uffi:convert-from-cstring + (mysql-stmt-error stmt))))) + + (make-instance 'mysql-stmt + :database database + :stmt stmt + :num-fields num-fields + :input-bind input-bind + :output-bind output-bind + :result-set rs + :result-types result-types + :length-ptr length-ptr + :is-null-ptr is-null-ptr + :types mysql-types + :field-names field-names))))) + +#+mysql-client-v4.1 +(defmethod database-bind-parameter ((stmt mysql-stmt) position value) + ;; FIXME: will need to allocate bind structure. This should probably be + ;; done in C since the API is not mature and may change + (let ((binding (uffi:deref-array (input-bind stmt) '(:array mysql-bind) (1- position))) + (type (nth (1- position) (types stmt)))) + (setf (uffi:get-slot-value binding 'mysql-bind 'length) 0) + (cond + ((null value) + (when (is-null-ptr stmt) + (setf (uffi:deref-array (is-null-ptr stmt) '(:array :byte) (1- position)) 1))) + (t + (when (is-null-ptr stmt) + (setf (uffi:deref-array (is-null-ptr stmt) '(:array :byte) (1- position)) 0)) + (case type + (#.mysql-field-types#long + (setf (uffi:get-slot-value binding 'mysql-bind 'mysql::buffer) value)) + (t + (warn "Unknown input bind type ~D." type)) + ))))) + +#+mysql-client-v4.1 +(defmethod database-run-prepared ((stmt mysql-stmt)) + (print 'a1) + (when (input-bind stmt) + (unless (zerop (mysql-stmt-bind-param (stmt stmt) (input-bind stmt))) + (error 'sql-database-error + :error-id (mysql-stmt-errno (stmt stmt)) + :message (uffi:convert-from-cstring + (mysql-stmt-error (stmt stmt)))))) + (print 'a2) + (unless (zerop (mysql-stmt-execute (stmt stmt))) + (error 'sql-database-error + :error-id (mysql-stmt-errno (stmt stmt)) + :message (uffi:convert-from-cstring + (mysql-stmt-error (stmt stmt))))) + (print 'a3) + (unless (zerop (mysql-stmt-store-result (stmt stmt))) + (error 'sql-database-error + :error-id (mysql-stmt-errno (stmt stmt)) + :message (uffi:convert-from-cstring + (mysql-stmt-error (stmt stmt))))) + (database-fetch-prepared-rows stmt)) + +#+mysql-client-v4.1 +(defun database-fetch-prepared-rows (stmt) + (do ((rc (mysql-stmt-fetch (stmt stmt)) (mysql-stmt-fetch (stmt stmt))) + (num-fields (num-fields stmt)) + (rows '())) + ((not (zerop rc)) (nreverse rows)) + (push + (loop for i from 0 below num-fields + collect + (let ((is-null + (not (zerop (uffi:ensure-char-integer + (uffi:deref-array (is-null-ptr stmt) '(:array :byte) i)))))) + (unless is-null + (let* ((bind (uffi:deref-array (output-bind stmt) '(:array mysql-bind) i)) + (type (uffi:get-slot-value bind 'mysql-bind 'mysql::buffer-type)) + (buffer (uffi:get-slot-value bind 'mysql-bind 'mysql::buffer))) + (case type + ((#.mysql-field-types#var-string #.mysql-field-types#string + #.mysql-field-types#tiny-blob #.mysql-field-types#blob + #.mysql-field-types#medium-blob #.mysql-field-types#long-blob) + (uffi:convert-from-foreign-string buffer :encoding (encoding (database stmt)))) + (#.mysql-field-types#tiny + (uffi:ensure-char-integer + (uffi:deref-pointer buffer :byte))) + (#.mysql-field-types#short + (uffi:deref-pointer buffer :short)) + (#.mysql-field-types#long + (uffi:deref-pointer buffer :int)) + #+64bit + (#.mysql-field-types#longlong + (uffi:deref-pointer buffer :long)) + (#.mysql-field-types#float + (uffi:deref-pointer buffer :float)) + (#.mysql-field-types#double + (uffi:deref-pointer buffer :double)) + ((#.mysql-field-types#time #.mysql-field-types#date + #.mysql-field-types#datetime #.mysql-field-types#timestamp) + (let ((year (uffi:get-slot-value buffer 'mysql-time 'mysql::year)) + (month (uffi:get-slot-value buffer 'mysql-time 'mysql::month)) + (day (uffi:get-slot-value buffer 'mysql-time 'mysql::day)) + (hour (uffi:get-slot-value buffer 'mysql-time 'mysql::hour)) + (minute (uffi:get-slot-value buffer 'mysql-time 'mysql::minute)) + (second (uffi:get-slot-value buffer 'mysql-time 'mysql::second))) + (db-timestring + (make-time :year year :month month :day day :hour hour + :minute minute :second second)))) + (t + (list type))))))) + rows))) + + + + +#+mysql-client-v4.1 +(defmethod database-free-prepared ((stmt mysql-stmt)) + (with-slots (stmt) stmt + (mysql-stmt-close stmt)) + ) + + +;;; Database capabilities + +(defmethod db-type-use-column-on-drop-index? ((db-type (eql :mysql))) + t) + +(defmethod db-type-has-views? ((db-type (eql :mysql))) + #+mysql-client-v5 t + #-mysql-client-v5 nil) + +(defmethod db-type-has-subqueries? ((db-type (eql :mysql))) + #+(or mysql-client-v4.1 mysql-client-v5) t + #-(or mysql-client-v4.1 mysql-client-v5) nil) + +(defmethod db-type-has-boolean-where? ((db-type (eql :mysql))) + #+(or mysql-client-v4.1 mysql-client-v5) t + #-(or mysql-client-v4.1 mysql-client-v5) nil) + +(defmethod db-type-has-union? ((db-type (eql :mysql))) + (not (eql (schar mysql::*mysql-client-info* 0) #\3))) + +(defmethod db-type-transaction-capable? ((db-type (eql :mysql)) database) + (let ((tuple (car (database-query "SHOW VARIABLES LIKE 'HAVE_INNODB'" database :auto nil)))) + (and tuple (string-equal "YES" (second tuple))))) + +(defmethod db-type-has-prepared-stmt? ((db-type (eql :mysql))) + #+(or mysql-client-v4.1 mysql-client-v5) t + #-(or mysql-client-v4.1 mysql-client-v5) nil) + +(defmethod db-type-has-auto-increment? ((db-type (eql :mysql))) + t) + +(when (clsql-sys:database-type-library-loaded :mysql) + (clsql-sys:initialize-database-type :database-type :mysql)) diff --git a/db-mysql/testing/mysql-struct-size.cc b/db-mysql/testing/mysql-struct-size.cc new file mode 100644 index 0000000..464ef46 --- /dev/null +++ b/db-mysql/testing/mysql-struct-size.cc @@ -0,0 +1,10 @@ +#include <stdio.h> +#include "/usr/include/mysql/mysql.h" + +int main (int argc, char** argv) +{ + printf ("Size of MYSQL struct: %ld\n", sizeof (MYSQL)); + printf("Sizeof MYSQL_BIND: %d\n", sizeof(MYSQL_BIND)); + printf("Sizeof MYSQL_FIELD: %d\n", sizeof(MYSQL_FIELD)); + printf("Sizeof MYSQL_TIME: %d\n", sizeof(MYSQL_TIME)); +} diff --git a/db-mysql/testing/mysql-struct-size.lisp b/db-mysql/testing/mysql-struct-size.lisp new file mode 100644 index 0000000..3aac6f9 --- /dev/null +++ b/db-mysql/testing/mysql-struct-size.lisp @@ -0,0 +1,11 @@ +(in-package :mysql) + +#+lispworks +(progn + (setq c (fli:allocate-foreign-object :type 'mysql-mysql)) + (format t "~&Size MYSQL structure: ~d" (fli:pointer-element-size c))) +#+allegro +(progn + (setq c (ff:allocate-fobject 'mysql-mysql :foreign)) + (format t "~&Size MYSQL structure: ~A" c)) + diff --git a/db-odbc/Makefile b/db-odbc/Makefile new file mode 100644 index 0000000..2497b4f --- /dev/null +++ b/db-odbc/Makefile @@ -0,0 +1,24 @@ +#!/usr/bin/make +########################################################################## +# FILE IDENTIFICATION +# +# Name: Makefile +# Purpose: Makefile for CLSQL SQL interface +# Programer: Kevin M. Rosenberg +# Date Started: Mar 2002 +# +# 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. +########################################################################## + + +SUBDIRS= + +include ../Makefile.common + +.PHONY: distclean +distclean: clean + diff --git a/db-odbc/odbc-api.lisp b/db-odbc/odbc-api.lisp new file mode 100644 index 0000000..208dafa --- /dev/null +++ b/db-odbc/odbc-api.lisp @@ -0,0 +1,1023 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Package: odbc -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: odbc-api.lisp +;;;; Purpose: Low-level ODBC API using UFFI +;;;; Authors: Kevin M. Rosenberg and Paul Meurer +;;;; +;;;; This file, part of CLSQL, is Copyright (c) 2004 by Kevin M. Rosenberg +;;;; and Copyright (C) Paul Meurer 1999 - 2001. All rights reserved. +;;;; +;;;; 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 #:odbc) + +(defvar *null* nil + "Lisp representation of SQL Null value, default = nil. +May be locally bound to something else if a certain type is necessary.") + + +(defvar *binary-format* :unsigned-byte-vector) +(defvar *time-format* + (lambda (time) + (clsql-sys:format-time nil time :format :iso)) + "Bound to a function that converts from a clsql:wall-time to the desired + representation of date/time/timestamp. + By default, returns an iso-timestring.") + +(defvar +null-ptr+ (make-null-pointer :byte)) +(defparameter +null-handle-ptr+ (make-null-pointer :void)) +(defvar *info-output* nil + "Stream to send SUCCESS_WITH_INFO messages.") + +(defmacro %put-str (ptr string &optional max-length) + (let ((size (gensym))) + `(let ((,size (length ,string))) + (when (and ,max-length (> ,size ,max-length)) + (error 'clsql:sql-database-data-error + :message + (format nil "string \"~a\" of length ~d is longer than max-length: ~d" + ,string ,size ,max-length))) + (with-cast-pointer (char-ptr ,ptr :byte) + (dotimes (i ,size) + (setf (deref-array char-ptr '(:array :byte) i) + (char-code (char ,string i)))) + (setf (deref-array char-ptr '(:array :byte) ,size) 0))))) + +(defmacro with-allocate-foreign-string ((var len) &body body) + "Safely does uffi:allocate-foreign-string-- making sure we do the uffi:free-foreign-object" + `(let ((,var)) + (unwind-protect + (progn + (setf ,var (uffi:allocate-foreign-string ,len)) + ,@body) + (when ,var + (uffi:free-foreign-object ,var))))) + +(defmacro with-allocate-foreign-strings (bindings &rest body) + (if bindings + `(with-allocate-foreign-string ,(car bindings) + (with-allocate-foreign-strings ,(cdr bindings) + ,@body)) + `(progn ,@body))) + +(defun handle-error (henv hdbc hstmt) + (with-allocate-foreign-strings ((sql-state 256) + (error-message #.$SQL_MAX_MESSAGE_LENGTH)) + (with-foreign-objects ((error-code #.$ODBC-LONG-TYPE) + (msg-length :short)) + (SQLError henv hdbc hstmt sql-state + error-code error-message + #.$SQL_MAX_MESSAGE_LENGTH msg-length) + (values + (convert-from-foreign-string error-message) + (convert-from-foreign-string sql-state) + (deref-pointer msg-length :short) + (deref-pointer error-code #.$ODBC-LONG-TYPE))))) + +(defun sql-state (henv hdbc hstmt) + (with-allocate-foreign-strings ((sql-state 256) + (error-message #.$SQL_MAX_MESSAGE_LENGTH)) + (with-foreign-objects ((error-code #.$ODBC-LONG-TYPE) + (msg-length :short)) + (SQLError henv hdbc hstmt sql-state error-code + error-message #.$SQL_MAX_MESSAGE_LENGTH msg-length) + (convert-from-foreign-string sql-state) + ;; test this: return a keyword for efficiency + ;;(%cstring-to-keyword state) + ))) + +(defmacro with-error-handling ((&key henv hdbc hstmt (print-info t)) + odbc-call &body body) + (let ((result-code (gensym "RC-"))) + `(let ((,result-code ,odbc-call)) + + ;; Check for allegro v7 & v8 bug with ODBC calls returning + ;; 32-bit unsigned ints, not 16-bit signed ints + #+(and allegro mswindows) + (when (> ,result-code #xFFFF) + (warn (format nil "16-bit return bug: result-code #x~X for expression ~S" + ,result-code (quote ,odbc-call))) + (setq ,result-code (logand ,result-code #xFFFF)) + (when (> ,result-code #x7FFF) + (setq ,result-code (- ,result-code #x10000)))) + + (case ,result-code + (#.$SQL_SUCCESS + (progn ,result-code ,@body)) + (#.$SQL_SUCCESS_WITH_INFO + (when ,print-info + (multiple-value-bind (error-message sql-state) + (handle-error (or ,henv +null-handle-ptr+) + (or ,hdbc +null-handle-ptr+) + (or ,hstmt +null-handle-ptr+)) + (when *info-output* + (format *info-output* "[ODBC info ~A] ~A state: ~A" + ,result-code error-message + sql-state)))) + (progn ,result-code ,@body)) + (#.$SQL_INVALID_HANDLE + (error + 'clsql-sys:sql-database-error + :message "ODBC: Invalid handle")) + (#.$SQL_STILL_EXECUTING + (error + 'clsql-sys:sql-temporary-error + :message "ODBC: Still executing")) + (#.$SQL_ERROR + (multiple-value-bind (error-message sql-state) + (handle-error (or ,henv +null-handle-ptr+) + (or ,hdbc +null-handle-ptr+) + (or ,hstmt +null-handle-ptr+)) + (error + 'clsql-sys:sql-database-error + :message error-message + :secondary-error-id sql-state))) + (#.$SQL_NO_DATA_FOUND + (progn ,result-code ,@body)) + ;; work-around for Allegro 7.0beta AMD64 which returns negative numbers + (otherwise + (multiple-value-bind (error-message sql-state) + (handle-error (or ,henv +null-handle-ptr+) + (or ,hdbc +null-handle-ptr+) + (or ,hstmt +null-handle-ptr+)) + (error + 'clsql-sys:sql-database-error + :message error-message + :secondary-error-id sql-state)) + #+ignore + (progn ,result-code ,@body)))))) + +(defun %new-environment-handle () + (let ((henv + (with-foreign-object (phenv 'sql-handle) + (with-error-handling + () + (SQLAllocHandle $SQL_HANDLE_ENV +null-handle-ptr+ phenv) + (deref-pointer phenv 'sql-handle))))) + (%set-attr-odbc-version henv $SQL_OV_ODBC3) + henv)) + + +(defun %sql-free-environment (henv) + (with-error-handling + (:henv henv) + (SQLFreeEnv henv))) + +(defun %new-db-connection-handle (henv) + (with-foreign-object (phdbc 'sql-handle) + (setf (deref-pointer phdbc 'sql-handle) +null-handle-ptr+) + (with-error-handling + (:henv henv) + (SQLAllocHandle $SQL_HANDLE_DBC henv phdbc) + (deref-pointer phdbc 'sql-handle)))) + +(defun %free-statement (hstmt option) + (with-error-handling + (:hstmt hstmt) + (SQLFreeStmt + hstmt + (ecase option + (:drop $SQL_DROP) + (:close $SQL_CLOSE) + (:unbind $SQL_UNBIND) + (:reset $SQL_RESET_PARAMS))))) + +(defmacro with-statement-handle ((hstmt hdbc) &body body) + `(let ((,hstmt (%new-statement-handle ,hdbc))) + (unwind-protect + (progn ,@body) + (%free-statement ,hstmt :drop)))) + +;; functional interface + +(defun %sql-connect (hdbc server uid pwd) + (with-cstrings ((server-ptr server) + (uid-ptr uid) + (pwd-ptr pwd)) + (with-error-handling + (:hdbc hdbc) + (SQLConnect hdbc server-ptr $SQL_NTS uid-ptr + $SQL_NTS pwd-ptr $SQL_NTS)))) + +(defun %sql-driver-connect (hdbc connection-string completion window-handle) + (with-cstring (connection-ptr connection-string) + (with-allocate-foreign-string (completed-connection-string-ptr $SQL_MAX_CONN_OUT) + (with-foreign-object (completed-connection-length :short) + (with-error-handling + (:hdbc hdbc) + (SQLDriverConnect hdbc + (or window-handle + +null-handle-ptr+) + connection-ptr $SQL_NTS + completed-connection-string-ptr $SQL_MAX_CONN_OUT + completed-connection-length + completion)))))) + +(defun %disconnect (hdbc) + (with-error-handling + (:hdbc hdbc) + (SQLDisconnect hdbc) + (with-error-handling + (:hdbc hdbc) + (SQLFreeHandle $SQL_HANDLE_DBC hdbc)))) + +(defun %commit (henv hdbc) + (with-error-handling + (:henv henv :hdbc hdbc) + (SQLTransact + henv hdbc $SQL_COMMIT))) + +(defun %rollback (henv hdbc) + (with-error-handling + (:henv henv :hdbc hdbc) + (SQLTransact + henv hdbc $SQL_ROLLBACK))) + +; col-nr is zero-based in Lisp but 1 based in sql +; col-nr = :bookmark retrieves a bookmark. +(defun %bind-column (hstmt column-nr c-type data-ptr precision out-len-ptr) + (with-error-handling + (:hstmt hstmt) + (SQLBindCol hstmt + (if (eq column-nr :bookmark) 0 (1+ column-nr)) + c-type data-ptr precision out-len-ptr))) + +; parameter-nr is zero-based in Lisp +(defun %sql-bind-parameter (hstmt parameter-nr parameter-type c-type + sql-type precision scale data-ptr + max-value out-len-ptr) + (with-error-handling + (:hstmt hstmt) + (SQLBindParameter hstmt (1+ parameter-nr) + parameter-type ;$SQL_PARAM_INPUT + c-type ;$SQL_C_CHAR + sql-type ;$SQL_VARCHAR + precision ;(1- (length str)) + scale ;0 + data-ptr + max-value + out-len-ptr ;#.+null-ptr+ + ))) + +(defun %sql-fetch (hstmt) + (with-error-handling + (:hstmt hstmt) + (SQLFetch hstmt))) + +(defun %new-statement-handle (hdbc) + (let ((statement-handle + (with-foreign-object (phstmt 'sql-handle) + (with-error-handling + (:hdbc hdbc) + (SQLAllocHandle $SQL_HANDLE_STMT hdbc phstmt) + (deref-pointer phstmt 'sql-handle))))) + (if (uffi:null-pointer-p statement-handle) + (error 'clsql:sql-database-error :message "Received null statement handle.") + statement-handle))) + +(defun %sql-get-info (hdbc info-type) + (ecase info-type + ;; those return string + ((#.$SQL_ACCESSIBLE_PROCEDURES + #.$SQL_ACCESSIBLE_TABLES + #.$SQL_COLUMN_ALIAS + #.$SQL_DATA_SOURCE_NAME + #.$SQL_DATA_SOURCE_READ_ONLY + #.$SQL_DBMS_NAME + #.$SQL_DBMS_VER + #.$SQL_DRIVER_NAME + #.$SQL_DRIVER_ODBC_VER + #.$SQL_DRIVER_VER + #.$SQL_EXPRESSIONS_IN_ORDERBY + #.$SQL_IDENTIFIER_QUOTE_CHAR + #.$SQL_KEYWORDS + #.$SQL_LIKE_ESCAPE_CLAUSE + #.$SQL_MAX_ROW_SIZE_INCLUDES_LONG + #.$SQL_MULT_RESULT_SETS + #.$SQL_MULTIPLE_ACTIVE_TXN + #.$SQL_NEED_LONG_DATA_LEN + #.$SQL_ODBC_SQL_OPT_IEF + #.$SQL_ODBC_VER + #.$SQL_ORDER_BY_COLUMNS_IN_SELECT + #.$SQL_OUTER_JOINS + #.$SQL_OWNER_TERM + #.$SQL_PROCEDURE_TERM + #.$SQL_PROCEDURES + #.$SQL_QUALIFIER_NAME_SEPARATOR + #.$SQL_QUALIFIER_TERM + #.$SQL_ROW_UPDATES + #.$SQL_SEARCH_PATTERN_ESCAPE + #.$SQL_SERVER_NAME + #.$SQL_SPECIAL_CHARACTERS + #.$SQL_TABLE_TERM + #.$SQL_USER_NAME) + (with-allocate-foreign-string (info-ptr 1024) + (with-foreign-object (info-length-ptr :short) + (with-error-handling + (:hdbc hdbc) + (SQLGetInfo hdbc info-type info-ptr 1023 info-length-ptr) + (convert-from-foreign-string info-ptr))))) + ;; those returning a word + ((#.$SQL_ACTIVE_CONNECTIONS + #.$SQL_ACTIVE_STATEMENTS + #.$SQL_CONCAT_NULL_BEHAVIOR + #.$SQL_CORRELATION_NAME + #.$SQL_CURSOR_COMMIT_BEHAVIOR + #.$SQL_CURSOR_ROLLBACK_BEHAVIOR + #.$SQL_MAX_COLUMN_NAME_LEN + #.$SQL_MAX_COLUMNS_IN_GROUP_BY + #.$SQL_MAX_COLUMNS_IN_INDEX + #.$SQL_MAX_COLUMNS_IN_ORDER_BY + #.$SQL_MAX_COLUMNS_IN_SELECT + #.$SQL_MAX_COLUMNS_IN_TABLE + #.$SQL_MAX_CURSOR_NAME_LEN + #.$SQL_MAX_OWNER_NAME_LEN + #.$SQL_MAX_PROCEDURE_NAME_LEN + #.$SQL_MAX_QUALIFIER_NAME_LEN + #.$SQL_MAX_TABLE_NAME_LEN + #.$SQL_MAX_TABLES_IN_SELECT + #.$SQL_MAX_USER_NAME_LEN + #.$SQL_NON_NULLABLE_COLUMNS + #.$SQL_NULL_COLLATION + #.$SQL_ODBC_API_CONFORMANCE + #.$SQL_ODBC_SAG_CLI_CONFORMANCE + #.$SQL_ODBC_SQL_CONFORMANCE + #.$SQL_QUALIFIER_LOCATION + #.$SQL_QUOTED_IDENTIFIER_CASE + #.$SQL_TXN_CAPABLE) + (with-foreign-objects ((info-ptr :short) + (info-length-ptr :short)) + (with-error-handling + (:hdbc hdbc) + (SQLGetInfo hdbc + info-type + info-ptr + 255 + info-length-ptr) + (deref-pointer info-ptr :short))) + ) + ;; those returning a long bitmask + ((#.$SQL_ALTER_TABLE + #.$SQL_BOOKMARK_PERSISTENCE + #.$SQL_CONVERT_BIGINT + #.$SQL_CONVERT_BINARY + #.$SQL_CONVERT_BIT + #.$SQL_CONVERT_CHAR + #.$SQL_CONVERT_DATE + #.$SQL_CONVERT_DECIMAL + #.$SQL_CONVERT_DOUBLE + #.$SQL_CONVERT_FLOAT + #.$SQL_CONVERT_INTEGER + #.$SQL_CONVERT_LONGVARCHAR + #.$SQL_CONVERT_NUMERIC + #.$SQL_CONVERT_REAL + #.$SQL_CONVERT_SMALLINT + #.$SQL_CONVERT_TIME + #.$SQL_CONVERT_TIMESTAMP + #.$SQL_CONVERT_TINYINT + #.$SQL_CONVERT_VARBINARY + #.$SQL_CONVERT_VARCHAR + #.$SQL_CONVERT_LONGVARBINARY + #.$SQL_CONVERT_FUNCTIONS + #.$SQL_FETCH_DIRECTION + #.$SQL_FILE_USAGE + #.$SQL_GETDATA_EXTENSIONS + #.$SQL_LOCK_TYPES + #.$SQL_MAX_INDEX_SIZE + #.$SQL_MAX_ROW_SIZE + #.$SQL_MAX_STATEMENT_LEN + #.$SQL_NUMERIC_FUNCTIONS + #.$SQL_OWNER_USAGE + #.$SQL_POS_OPERATIONS + #.$SQL_POSITIONED_STATEMENTS + #.$SQL_QUALIFIER_USAGE + #.$SQL_SCROLL_CONCURRENCY + #.$SQL_SCROLL_OPTIONS + #.$SQL_STATIC_SENSITIVITY + #.$SQL_STRING_FUNCTIONS + #.$SQL_SUBQUERIES + #.$SQL_SYSTEM_FUNCTIONS + #.$SQL_TIMEDATE_ADD_INTERVALS + #.$SQL_TIMEDATE_DIFF_INTERVALS + #.$SQL_TIMEDATE_FUNCTIONS + #.$SQL_TXN_ISOLATION_OPTION + #.$SQL_UNION) + (with-foreign-objects ((info-ptr #.$ODBC-LONG-TYPE) + (info-length-ptr :short)) + (with-error-handling + (:hdbc hdbc) + (SQLGetInfo hdbc + info-type + info-ptr + 255 + info-length-ptr) + (deref-pointer info-ptr #.$ODBC-LONG-TYPE))) + ) + ;; those returning a long integer + ((#.$SQL_DEFAULT_TXN_ISOLATION + #.$SQL_DRIVER_HDBC + #.$SQL_DRIVER_HENV + #.$SQL_DRIVER_HLIB + #.$SQL_DRIVER_HSTMT + #.$SQL_GROUP_BY + #.$SQL_IDENTIFIER_CASE + #.$SQL_MAX_BINARY_LITERAL_LEN + #.$SQL_MAX_CHAR_LITERAL_LEN + #.$SQL_ACTIVE_ENVIRONMENTS + ) + (with-foreign-objects ((info-ptr #.$ODBC-LONG-TYPE) + (info-length-ptr :short)) + (with-error-handling + (:hdbc hdbc) + (SQLGetInfo hdbc info-type info-ptr 255 info-length-ptr) + (deref-pointer info-ptr #.$ODBC-LONG-TYPE)))))) + +(defun %sql-exec-direct (sql hstmt henv hdbc) + (with-cstring (sql-ptr sql) + (with-error-handling + (:hstmt hstmt :henv henv :hdbc hdbc) + (SQLExecDirect hstmt sql-ptr $SQL_NTS)))) + +(defun %sql-cancel (hstmt) + (with-error-handling + (:hstmt hstmt) + (SQLCancel hstmt))) + +(defun %sql-execute (hstmt) + (with-error-handling + (:hstmt hstmt) + (SQLExecute hstmt))) + +(defun result-columns-count (hstmt) + (with-foreign-objects ((columns-nr-ptr :short)) + (with-error-handling (:hstmt hstmt) + (SQLNumResultCols hstmt columns-nr-ptr) + (deref-pointer columns-nr-ptr :short)))) + +(defun result-rows-count (hstmt) + (with-foreign-objects ((row-count-ptr #.$ODBC-LONG-TYPE)) + (with-error-handling (:hstmt hstmt) + (SQLRowCount hstmt row-count-ptr) + (deref-pointer row-count-ptr #.$ODBC-LONG-TYPE)))) + +;; column counting is 1-based +(defun %describe-column (hstmt column-nr) + (with-allocate-foreign-string (column-name-ptr 256) + (with-foreign-objects ((column-name-length-ptr :short) + (column-sql-type-ptr :short) + (column-precision-ptr #.$ODBC-ULONG-TYPE) + (column-scale-ptr :short) + (column-nullable-p-ptr :short)) + (with-error-handling (:hstmt hstmt) + (SQLDescribeCol hstmt column-nr column-name-ptr 256 + column-name-length-ptr + column-sql-type-ptr + column-precision-ptr + column-scale-ptr + column-nullable-p-ptr) + (values + (convert-from-foreign-string column-name-ptr) + (deref-pointer column-sql-type-ptr :short) + (deref-pointer column-precision-ptr #.$ODBC-ULONG-TYPE) + (deref-pointer column-scale-ptr :short) + (deref-pointer column-nullable-p-ptr :short)))))) + +;; parameter counting is 1-based +;; this function isn't used, which is good because FreeTDS dosn't support it. +(defun %describe-parameter (hstmt parameter-nr) + (with-foreign-objects ((column-sql-type-ptr :short) + (column-precision-ptr #.$ODBC-ULONG-TYPE) + (column-scale-ptr :short) + (column-nullable-p-ptr :short)) + (with-error-handling + (:hstmt hstmt) + (SQLDescribeParam hstmt parameter-nr + column-sql-type-ptr + column-precision-ptr + column-scale-ptr + column-nullable-p-ptr) + (values + (deref-pointer column-sql-type-ptr :short) + (deref-pointer column-precision-ptr #.$ODBC-ULONG-TYPE) + (deref-pointer column-scale-ptr :short) + (deref-pointer column-nullable-p-ptr :short))))) + +(defun %column-attributes (hstmt column-nr descriptor-type) + (with-allocate-foreign-string (descriptor-info-ptr 256) + (with-foreign-objects ((descriptor-length-ptr :short) + (numeric-descriptor-ptr #.$ODBC-LONG-TYPE)) + (with-error-handling + (:hstmt hstmt) + (SQLColAttributes hstmt column-nr descriptor-type descriptor-info-ptr + 256 descriptor-length-ptr + numeric-descriptor-ptr) + (values + (convert-from-foreign-string descriptor-info-ptr) + (deref-pointer numeric-descriptor-ptr #.$ODBC-LONG-TYPE)))))) + +(defun %prepare-describe-columns (hstmt table-qualifier table-owner + table-name column-name) + (with-cstrings ((table-qualifier-ptr table-qualifier) + (table-owner-ptr table-owner) + (table-name-ptr table-name) + (column-name-ptr column-name)) + (with-error-handling + (:hstmt hstmt) + (SQLColumns hstmt + table-qualifier-ptr (length table-qualifier) + table-owner-ptr (length table-owner) + table-name-ptr (length table-name) + column-name-ptr (length column-name))))) + +(defun %describe-columns (hdbc table-qualifier table-owner + table-name column-name) + (with-statement-handle (hstmt hdbc) + (%prepare-describe-columns hstmt table-qualifier table-owner + table-name column-name) + (fetch-all-rows hstmt))) + +(defun %sql-data-sources (henv &key (direction :first)) + (with-allocate-foreign-strings ((name-ptr (1+ $SQL_MAX_DSN_LENGTH)) + (description-ptr 1024)) + (with-foreign-objects ((name-length-ptr :short) + (description-length-ptr :short)) + (let ((res (with-error-handling + (:henv henv) + (SQLDataSources henv + (ecase direction + (:first $SQL_FETCH_FIRST) + (:next $SQL_FETCH_NEXT)) + name-ptr + (1+ $SQL_MAX_DSN_LENGTH) + name-length-ptr + description-ptr + 1024 + description-length-ptr)))) + (when (= res $SQL_NO_DATA_FOUND) + (values + (convert-from-foreign-string name-ptr) + (convert-from-foreign-string description-ptr))))))) + + + +(defun sql-to-c-type (sql-type) + (ecase sql-type + ;; Added -10 for MSSQL ntext type and -11 for nvarchar + ((#.$SQL_CHAR #.$SQL_VARCHAR #.$SQL_LONGVARCHAR + #.$SQL_NUMERIC #.$sql_decimal -8 -9 -10 -11) $SQL_C_CHAR) + (#.$SQL_INTEGER $SQL_C_SLONG) + (#.$SQL_BIGINT $SQL_C_SBIGINT) + (#.$SQL_SMALLINT $SQL_C_SSHORT) + (#.$SQL_DOUBLE $SQL_C_DOUBLE) + (#.$SQL_FLOAT $SQL_C_DOUBLE) + (#.$SQL_REAL $SQL_C_FLOAT) + (#.$SQL_DATE $SQL_C_DATE) + (#.$SQL_TIME $SQL_C_TIME) + (#.$SQL_TIMESTAMP $SQL_C_TIMESTAMP) + (#.$SQL_TYPE_DATE $SQL_C_TYPE_DATE) + (#.$SQL_TYPE_TIME $SQL_C_TYPE_TIME) + (#.$SQL_TYPE_TIMESTAMP $SQL_C_TYPE_TIMESTAMP) + ((#.$SQL_BINARY #.$SQL_VARBINARY #.$SQL_LONGVARBINARY) $SQL_C_BINARY) + (#.$SQL_TINYINT $SQL_C_STINYINT) + (#.$SQL_BIT $SQL_C_BIT))) + +(def-type byte-pointer-type (* :byte)) +(def-type short-pointer-type (* :short)) +(def-type int-pointer-type (* :int)) +(def-type long-pointer-type (* #.$ODBC-LONG-TYPE)) +(def-type big-pointer-type (* #.$ODBC-BIG-TYPE)) +(def-type float-pointer-type (* :float)) +(def-type double-pointer-type (* :double)) +(def-type string-pointer-type (* :unsigned-char)) + +(defun get-cast-byte (ptr) + (locally (declare (type byte-pointer-type ptr)) + (deref-pointer ptr :byte))) + +(defun get-cast-short (ptr) + (locally (declare (type short-pointer-type ptr)) + (deref-pointer ptr :short))) + +(defun get-cast-int (ptr) + (locally (declare (type int-pointer-type ptr)) + (deref-pointer ptr :int))) + +(defun get-cast-long (ptr) + (locally (declare (type long-pointer-type ptr)) + (deref-pointer ptr #.$ODBC-LONG-TYPE))) + +(defun get-cast-big (ptr) + (locally (declare (type big-pointer-type ptr)) + (deref-pointer ptr #.$ODBC-BIG-TYPE))) + +(defun get-cast-single-float (ptr) + (locally (declare (type float-pointer-type ptr)) + (deref-pointer ptr :float))) + +(defun get-cast-double-float (ptr) + (locally (declare (type double-pointer-type ptr)) + (deref-pointer ptr :double))) + +(defun get-cast-foreign-string (ptr) + (locally (declare (type string-pointer-type ptr)) + (convert-from-foreign-string ptr))) + +(defun get-cast-binary (ptr len format) + "FORMAT is one of :unsigned-byte-vector, :bit-vector (:string, :hex-string)" + (with-cast-pointer (casted ptr :unsigned-byte) + (ecase format + (:unsigned-byte-vector + (let ((vector (make-array len :element-type '(unsigned-byte 8)))) + (dotimes (i len) + (setf (aref vector i) + (deref-array casted '(:array :unsigned-byte) i))) + vector)) + (:bit-vector + (let ((vector (make-array (ash len 3) :element-type 'bit))) + (dotimes (i len) + (let ((byte (deref-array casted '(:array :byte) i))) + (dotimes (j 8) + (setf (bit vector (+ (ash i 3) j)) + (logand (ash byte (- j 7)) 1))))) + vector))))) + + +(defun read-data (data-ptr c-type sql-type out-len-ptr result-type) + (declare (type long-ptr-type out-len-ptr)) + (let* ((out-len (get-cast-long out-len-ptr)) + (value + (cond ((= out-len $SQL_NULL_DATA) *null*) + (t + (case sql-type + ;; SQL extended datatypes + (#.$SQL_TINYINT (get-cast-byte data-ptr)) + (#.$SQL_C_STINYINT (get-cast-byte data-ptr)) ;; ? + (#.$SQL_C_SSHORT (get-cast-short data-ptr)) ;; ? + (#.$SQL_SMALLINT (get-cast-short data-ptr)) ;; ?? + (#.$SQL_INTEGER (get-cast-int data-ptr)) + (#.$SQL_BIGINT (get-cast-big data-ptr)) + ;; TODO: Change this to read in rationals instead of doubles + ((#.$SQL_DECIMAL #.$SQL_NUMERIC) + (let* ((*read-base* 10) + (*read-default-float-format* 'double-float) + (str (get-cast-foreign-string data-ptr))) + (read-from-string str))) + (#.$SQL_BIT (get-cast-byte data-ptr)) + (t + (case c-type + ((#.$SQL_C_DATE #.$SQL_C_TYPE_DATE) + (funcall *time-format* (date-to-clsql-time data-ptr))) + ((#.$SQL_C_TIME #.$SQL_C_TYPE_TIME) + (funcall *time-format* (time-to-clsql-time data-ptr))) + ((#.$SQL_C_TIMESTAMP #.$SQL_C_TYPE_TIMESTAMP) + (funcall *time-format* (timestamp-to-clsql-time data-ptr))) + (#.$SQL_INTEGER + (get-cast-int data-ptr)) + (#.$SQL_C_FLOAT + (get-cast-single-float data-ptr)) + (#.$SQL_C_DOUBLE + (get-cast-double-float data-ptr)) + (#.$SQL_C_SLONG + (get-cast-long data-ptr)) + #+lispworks + (#.$SQL_C_BIT ; encountered only in Access + (get-cast-byte data-ptr)) + (#.$SQL_C_BINARY + (get-cast-binary data-ptr out-len *binary-format*)) + ((#.$SQL_C_SSHORT #.$SQL_C_STINYINT) ; LMH short ints + (get-cast-short data-ptr)) ; LMH + (#.$SQL_C_SBIGINT (get-cast-big data-ptr)) + #+ignore + (#.$SQL_C_CHAR + (code-char (get-cast-short data-ptr))) + (t + (get-cast-foreign-string data-ptr))))))))) + + ;; FIXME: this could be better optimized for types which use READ-FROM-STRING above + + (if (and (or (eq result-type t) (eq result-type :string)) + value + (not (stringp value))) + (write-to-string value) + value))) + +;; which value is appropriate? +(defparameter +max-precision+ 4001) + +(defvar *break-on-unknown-data-type* t) + +;; C. Stacy's idea to factor this out +;; "Make it easy to add new datatypes by making new subroutine %ALLOCATE-BINDINGS, +;; so that I don't have to remember to make changes in more than one place. +;; Just keep it in synch with READ-DATA." +(defun %allocate-bindings (sql-type precision) + (let* ((c-type (sql-to-c-type sql-type)) + (size (if (zerop precision) + +max-precision+ ;; if the precision cannot be determined + (min precision +max-precision+))) + (long-p (= size +max-precision+)) + (data-ptr + (case c-type ;; add more? + (#.$SQL_C_SLONG (uffi:allocate-foreign-object #.$ODBC-LONG-TYPE)) + ((#.$SQL_C_DATE #.$SQL_C_TYPE_DATE) (allocate-foreign-object 'sql-c-date)) + ((#.$SQL_C_TIME #.$SQL_C_TYPE_TIME) (allocate-foreign-object 'sql-c-time)) + ((#.$SQL_C_TIMESTAMP #.$SQL_C_TYPE_TIMESTAMP) (allocate-foreign-object 'sql-c-timestamp)) + (#.$SQL_C_FLOAT (uffi:allocate-foreign-object :float)) + (#.$SQL_C_DOUBLE (uffi:allocate-foreign-object :double)) + (#.$SQL_C_BIT (uffi:allocate-foreign-object :byte)) + (#.$SQL_C_STINYINT (uffi:allocate-foreign-object :byte)) + (#.$SQL_C_SBIGINT (uffi:allocate-foreign-object #.$ODBC-BIG-TYPE)) + (#.$SQL_C_SSHORT (uffi:allocate-foreign-object :short)) + (#.$SQL_C_CHAR (uffi:allocate-foreign-string (1+ size))) + (#.$SQL_C_BINARY (uffi:allocate-foreign-string (1+ (* 2 size)))) + (t + ;; Maybe should signal a restartable condition for this? + (when *break-on-unknown-data-type* + (break "SQL type is ~A, precision ~D, size ~D, C type is ~A" + sql-type precision size c-type)) + (uffi:allocate-foreign-object :byte (1+ size))))) + (out-len-ptr (uffi:allocate-foreign-object #.$ODBC-LONG-TYPE))) + (values c-type data-ptr out-len-ptr size long-p))) + +(defun fetch-all-rows (hstmt &key free-option flatp) + (let ((column-count (result-columns-count hstmt))) + (unless (zerop column-count) + (let ((names (make-array column-count)) + (sql-types (make-array column-count :element-type 'fixnum)) + (c-types (make-array column-count :element-type 'fixnum)) + (precisions (make-array column-count :element-type 'fixnum)) + (data-ptrs (make-array column-count :initial-element nil)) + (out-len-ptrs (make-array column-count :initial-element nil)) + (scales (make-array column-count :element-type 'fixnum)) + (nullables-p (make-array column-count :element-type 'fixnum))) + (unwind-protect + (values + (progn + (dotimes (col-nr column-count) + ;; get column information + (multiple-value-bind (name sql-type precision scale nullable-p) + (%describe-column hstmt (1+ col-nr)) + ;; allocate space to bind result rows to + (multiple-value-bind (c-type data-ptr out-len-ptr) + (%allocate-bindings sql-type precision) + (%bind-column hstmt col-nr c-type data-ptr (1+ precision) out-len-ptr) + (setf (svref names col-nr) name + (aref sql-types col-nr) sql-type + (aref c-types col-nr) (sql-to-c-type sql-type) + (aref precisions col-nr) (if (zerop precision) 0 precision) + (aref scales col-nr) scale + (aref nullables-p col-nr) nullable-p + (aref data-ptrs col-nr) data-ptr + (aref out-len-ptrs col-nr) out-len-ptr)))) + ;; the main loop + (prog1 + (cond (flatp + (when (> column-count 1) + (error 'clsql:sql-database-error + :message "If more than one column is to be fetched, flatp has to be nil.")) + (loop until (= (%sql-fetch hstmt) $SQL_NO_DATA_FOUND) + collect + (read-data (aref data-ptrs 0) + (aref c-types 0) + (aref sql-types 0) + (aref out-len-ptrs 0) + t))) + (t + (loop until (= (%sql-fetch hstmt) $SQL_NO_DATA_FOUND) + collect + (loop for col-nr from 0 to (1- column-count) + collect + (read-data (aref data-ptrs col-nr) + (aref c-types col-nr) + (aref sql-types col-nr) + (aref out-len-ptrs col-nr) + t))))))) + names) + ;; dispose of memory etc + (when free-option (%free-statement hstmt free-option)) + (dotimes (col-nr column-count) + (let ((data-ptr (aref data-ptrs col-nr)) + (out-len-ptr (aref out-len-ptrs col-nr))) + (when data-ptr (free-foreign-object data-ptr)) ; we *did* allocate them + (when out-len-ptr (free-foreign-object out-len-ptr))))))))) + +;; to do: factor out common parts, put the sceleton (the obligatory macro part) +;; of %do-fetch into sql package (has been done) + +(defun %sql-prepare (hstmt sql) + (with-cstring (sql-ptr sql) + (with-error-handling (:hstmt hstmt) + (SQLPrepare hstmt sql-ptr $SQL_NTS)))) + +;; depending on option, we return a long int or a string; string not implemented +(defun get-connection-option (hdbc option) + (with-foreign-object (param-ptr #.$ODBC-LONG-TYPE) + (with-error-handling (:hdbc hdbc) + (SQLGetConnectOption hdbc option param-ptr) + (deref-pointer param-ptr #.$ODBC-LONG-TYPE)))) + +(defun set-connection-option (hdbc option param) + (with-error-handling (:hdbc hdbc) + (SQLSetConnectOption hdbc option param))) + +(defun disable-autocommit (hdbc) + (set-connection-option hdbc $SQL_AUTOCOMMIT $SQL_AUTOCOMMIT_OFF)) + +(defun enable-autocommit (hdbc) + (set-connection-option hdbc $SQL_AUTOCOMMIT $SQL_AUTOCOMMIT_ON)) + +(defun %sql-set-pos (hstmt row option lock) + (with-error-handling + (:hstmt hstmt) + (SQLSetPos hstmt row option lock))) + +(defun %sql-extended-fetch (hstmt fetch-type row) + (with-foreign-objects ((row-count-ptr #.$ODBC-ULONG-TYPE) + (row-status-ptr :short)) + (with-error-handling (:hstmt hstmt) + (SQLExtendedFetch hstmt fetch-type row row-count-ptr + row-status-ptr) + (values (deref-pointer row-count-ptr #.$ODBC-ULONG-TYPE) + (deref-pointer row-status-ptr :short))))) + +; column-nr is zero-based +(defun %sql-get-data (hstmt column-nr c-type data-ptr precision out-len-ptr) + (with-error-handling + (:hstmt hstmt :print-info nil) + (SQLGetData hstmt (if (eq column-nr :bookmark) 0 (1+ column-nr)) + c-type data-ptr precision out-len-ptr))) + +(defun %sql-param-data (hstmt param-ptr) + (with-error-handling (:hstmt hstmt :print-info t) ;; nil + (SQLParamData hstmt param-ptr))) + +(defun %sql-put-data (hstmt data-ptr size) + (with-error-handling + (:hstmt hstmt :print-info t) ;; nil + (SQLPutData hstmt data-ptr size))) + +(defconstant $sql-data-truncated (intern "01004" :keyword)) + + +(defun read-data-in-chunks (hstmt column-nr data-ptr c-type sql-type + out-len-ptr result-type) + (declare (type long-ptr-type out-len-ptr) + (ignore result-type)) + + (let* ((res (%sql-get-data hstmt column-nr c-type data-ptr + +max-precision+ out-len-ptr)) + (out-len (get-cast-long out-len-ptr)) + (result (if (equal out-len #.$SQL_NULL_DATA) + (return-from read-data-in-chunks *null*) + + ;;this isn't the most efficient way of doing it: + ;;the foreign string gets copied to lisp, then + ;;that is copied into the final string. However, + ;;the previous impl that tried to copy one + ;;character over at a time failed miserably on + ;;multibyte characters. + ;; + ;;In the face of multibyte characters, the out-len + ;;tells us the length in bytes but that doesn't + ;;particularly help us here in allocating a lisp + ;;array. So our best strategy is to just let the + ;;foreign library that's already dealing with + ;;encodings do its thing. + + (with-output-to-string (str) + (loop do (if (= c-type #.$SQL_CHAR) + (write-sequence (get-cast-foreign-string data-ptr) str) + (error 'clsql:sql-database-error + :message "wrong type. preliminary.")) + while (and (= res $SQL_SUCCESS_WITH_INFO) + (equal (sql-state +null-handle-ptr+ +null-handle-ptr+ hstmt) + "01004")) + do (setf res (%sql-get-data hstmt column-nr c-type data-ptr + +max-precision+ out-len-ptr))))))) + + ;; reset the out length for the next row + (setf (deref-pointer out-len-ptr #.$ODBC-LONG-TYPE) #.$SQL_NO_TOTAL) + (if (= sql-type $SQL_DECIMAL) + (let ((*read-base* 10)) + (read-from-string result)) + result))) + + +(def-type c-timestamp-ptr-type (* (:struct sql-c-timestamp))) +(def-type c-time-ptr-type (* (:struct sql-c-time))) +(def-type c-date-ptr-type (* (:struct sql-c-date))) + +(defun timestamp-to-clsql-time (ptr) + (declare (type c-timestamp-ptr-type ptr)) + (clsql-sys:make-time + :second (get-slot-value ptr 'sql-c-timestamp 'second) + :minute (get-slot-value ptr 'sql-c-timestamp 'minute) + :hour (get-slot-value ptr 'sql-c-timestamp 'hour) + :day (get-slot-value ptr 'sql-c-timestamp 'day) + :month (get-slot-value ptr 'sql-c-timestamp 'month) + :year (get-slot-value ptr 'sql-c-timestamp 'year) + :usec (let ((frac (get-slot-value ptr 'sql-c-timestamp 'fraction))) + (if frac (/ frac 1000) 0)))) + +(defun universal-time-to-timestamp (time &optional (fraction 0)) + "TODO: Dead function?" + (multiple-value-bind (sec min hour day month year) + (decode-universal-time time) + (let ((ptr (allocate-foreign-object 'sql-c-timestamp))) + (setf (get-slot-value ptr 'sql-c-timestamp 'second) sec + (get-slot-value ptr 'sql-c-timestamp 'minute) min + (get-slot-value ptr 'sql-c-timestamp 'hour) hour + (get-slot-value ptr 'sql-c-timestamp 'day) day + (get-slot-value ptr 'sql-c-timestamp 'month) month + (get-slot-value ptr 'sql-c-timestamp 'year) year + (get-slot-value ptr 'sql-c-timestamp 'fraction) fraction) + ptr))) + +(defun %put-timestamp (ptr time &optional (fraction 0)) + "TODO: Dead function?" + (declare (type c-timestamp-ptr-type ptr)) + (multiple-value-bind (sec min hour day month year) + (decode-universal-time time) + (setf (get-slot-value ptr 'sql-c-timestamp 'second) sec + (get-slot-value ptr 'sql-c-timestamp 'minute) min + (get-slot-value ptr 'sql-c-timestamp 'hour) hour + (get-slot-value ptr 'sql-c-timestamp 'day) day + (get-slot-value ptr 'sql-c-timestamp 'month) month + (get-slot-value ptr 'sql-c-timestamp 'year) year + (get-slot-value ptr 'sql-c-timestamp 'fraction) fraction) + ptr)) + +(defun date-to-clsql-time (ptr) + (declare (type c-date-ptr-type ptr)) + (clsql-sys:make-time + :second 0 :minute 0 :hour 0 + :day (get-slot-value ptr 'sql-c-timestamp 'day) + :month (get-slot-value ptr 'sql-c-timestamp 'month) + :year (get-slot-value ptr 'sql-c-timestamp 'year))) + +(defun time-to-clsql-time (ptr) + (declare (type c-time-ptr-type ptr)) + (clsql-sys:make-time + :second (get-slot-value ptr 'sql-c-timestamp 'second) + :minute (get-slot-value ptr 'sql-c-timestamp 'minute) + :hour (get-slot-value ptr 'sql-c-timestamp 'hour))) + + +;;; Added by KMR + +(defun %set-attr-odbc-version (henv version) + (with-error-handling (:henv henv) + ;;note that we are passing version as an integer that happens to be + ;;stuffed into a pointer. + ;;http://msdn.microsoft.com/en-us/library/ms709285%28v=VS.85%29.aspx + (SQLSetEnvAttr henv $SQL_ATTR_ODBC_VERSION + (make-pointer version :void) 0))) + +(defun %list-tables (hstmt) + (with-error-handling (:hstmt hstmt) + (SQLTables hstmt +null-ptr+ 0 +null-ptr+ 0 +null-ptr+ 0 +null-ptr+ 0))) + +(defun %table-statistics (table hstmt &key unique (ensure t) + &aux (table (princ-to-string + (clsql-sys::unescaped-database-identifier table)))) + (with-cstrings ((table-cs table)) + (with-error-handling (:hstmt hstmt) + (SQLStatistics + hstmt + +null-ptr+ 0 + +null-ptr+ 0 + table-cs $SQL_NTS + (if unique $SQL_INDEX_UNIQUE $SQL_INDEX_ALL) + (if ensure $SQL_ENSURE $SQL_QUICK))))) + +(defun %list-data-sources (henv) + (let ((results nil)) + (with-foreign-strings ((dsn-ptr (1+ $SQL_MAX_DSN_LENGTH)) + (desc-ptr 256)) + (with-foreign-objects ((dsn-len :short) + (desc-len :short)) + (let ((res (with-error-handling (:henv henv) + (SQLDataSources henv $SQL_FETCH_FIRST dsn-ptr + (1+ $SQL_MAX_DSN_LENGTH) + dsn-len desc-ptr 256 desc-len)))) + (when (or (eql res $SQL_SUCCESS) + (eql res $SQL_SUCCESS_WITH_INFO)) + (push (convert-from-foreign-string dsn-ptr) results)) + + (do ((res (with-error-handling (:henv henv) + (SQLDataSources henv $SQL_FETCH_NEXT dsn-ptr + (1+ $SQL_MAX_DSN_LENGTH) + dsn-len desc-ptr 256 desc-len)) + (with-error-handling (:henv henv) + (SQLDataSources henv $SQL_FETCH_NEXT dsn-ptr + (1+ $SQL_MAX_DSN_LENGTH) + dsn-len desc-ptr 256 desc-len)))) + ((not (or (eql res $SQL_SUCCESS) + (eql res $SQL_SUCCESS_WITH_INFO)))) + (push (convert-from-foreign-string dsn-ptr) results))))) + (nreverse results))) diff --git a/db-odbc/odbc-constants.lisp b/db-odbc/odbc-constants.lisp new file mode 100644 index 0000000..689fc12 --- /dev/null +++ b/db-odbc/odbc-constants.lisp @@ -0,0 +1,979 @@ + ;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Package: odbc -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: odbc-constants.lisp +;;;; Purpose: Constants for UFFI interface to ODBC +;;;; Authors: Kevin M. Rosenberg and Paul Meurer +;;;; +;;;; This file, part of CLSQL, is Copyright (c) 2004 by Kevin M. Rosenberg +;;;; and Copyright (C) Paul Meurer 1999 - 2001. All rights reserved. +;;;; +;;;; 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 #:odbc) + +;; on SuSE AMD64 9.0, unixODBC is compiled with with SQLLEN being 4 bytes long +(defconstant $ODBC-LONG-TYPE :int) +(defconstant $ODBC-ULONG-TYPE :unsigned-int) +(defconstant $ODBC-BIG-TYPE :long-long) + +;; (defconstant $ODBCVER #x0210) + + +;; for new SQLAllocHandle functiion +(defconstant $SQL_HANDLE_ENV 1) +(defconstant $SQL_HANDLE_DBC 2) +(defconstant $SQL_HANDLE_STMT 3) +(defconstant $SQL_HANDLE_DESC 4) + +;; generally useful constants +(defconstant $SQL_SPEC_MAJOR 2) ;; Major version of specification +(defconstant $SQL_SPEC_MINOR 10) ;; Minor version of specification +(defvar $SQL_SPEC_STRING "02.10") ;; String constant for version +(defconstant $SQL_SQLSTATE_SIZE 5) ;; size of SQLSTATE +(defconstant $SQL_MAX_MESSAGE_LENGTH 512) ;; message buffer size +(defconstant $SQL_MAX_DSN_LENGTH 32) ;; maximum data source name size + +;; RETCODEs +(defconstant $SQL_INVALID_HANDLE -2) +(defconstant $SQL_ERROR -1) +(defconstant $SQL_SUCCESS 0) +(defconstant $SQL_SUCCESS_WITH_INFO 1) +(defconstant $SQL_NO_DATA_FOUND 100) + +;; Standard SQL datatypes, using ANSI type numbering +(defconstant $SQL_CHAR 1) +(defconstant $SQL_NUMERIC 2) +(defconstant $SQL_DECIMAL 3) +(defconstant $SQL_INTEGER 4) +(defconstant $SQL_SMALLINT 5) +(defconstant $SQL_FLOAT 6) +(defconstant $SQL_REAL 7) +(defconstant $SQL_DOUBLE 8) +(defconstant $SQL_VARCHAR 12) + +(defconstant $SQL_TYPE_MIN $SQL_CHAR) +(defconstant $SQL_TYPE_NULL 0) +(defconstant $SQL_TYPE_MAX $SQL_VARCHAR) + +;; C datatype to SQL datatype mapping SQL types + +(defconstant $SQL_C_CHAR $SQL_CHAR) ;; CHAR, VARCHAR, DECIMAL, NUMERIC +(defconstant $SQL_C_LONG $SQL_INTEGER) ;; INTEGER +(defconstant $SQL_C_SHORT $SQL_SMALLINT) ;; SMALLINT +(defconstant $SQL_C_FLOAT $SQL_REAL) ;; REAL +(defconstant $SQL_C_DOUBLE $SQL_DOUBLE) ;; FLOAT, DOUBLE +(defconstant $SQL_C_DEFAULT 99) + +;; NULL status constants. These are used in SQLColumns, SQLColAttributes, +;;SQLDescribeCol, SQLDescribeParam, and SQLSpecialColumns to describe the +;;nullablity of a column in a table. + +(defconstant $SQL_NO_NULLS 0) +(defconstant $SQL_NULLABLE 1) +(defconstant $SQL_NULLABLE_UNKNOWN 2) + +;; Special length values +(defconstant $SQL_NULL_DATA -1) +(defconstant $SQL_DATA_AT_EXEC -2) +(defconstant $SQL_NTS -3) + +;; SQLFreeStmt defines +(defconstant $SQL_CLOSE 0) +(defconstant $SQL_DROP 1) +(defconstant $SQL_UNBIND 2) +(defconstant $SQL_RESET_PARAMS 3) + +;; SQLTransact defines +(defconstant $SQL_COMMIT 0) +(defconstant $SQL_ROLLBACK 1) + +;; SQLColAttributes defines +(defconstant $SQL_COLUMN_COUNT 0) +(defconstant $SQL_COLUMN_NAME 1) +(defconstant $SQL_COLUMN_TYPE 2) +(defconstant $SQL_COLUMN_LENGTH 3) +(defconstant $SQL_COLUMN_PRECISION 4) +(defconstant $SQL_COLUMN_SCALE 5) +(defconstant $SQL_COLUMN_DISPLAY_SIZE 6) +(defconstant $SQL_COLUMN_NULLABLE 7) +(defconstant $SQL_COLUMN_UNSIGNED 8) +(defconstant $SQL_COLUMN_MONEY 9) +(defconstant $SQL_COLUMN_UPDATABLE 10) +(defconstant $SQL_COLUMN_AUTO_INCREMENT 11) +(defconstant $SQL_COLUMN_CASE_SENSITIVE 12) +(defconstant $SQL_COLUMN_SEARCHABLE 13) +(defconstant $SQL_COLUMN_TYPE_NAME 14) +(defconstant $SQL_COLUMN_TABLE_NAME 15) +(defconstant $SQL_COLUMN_OWNER_NAME 16) +(defconstant $SQL_COLUMN_QUALIFIER_NAME 17) +(defconstant $SQL_COLUMN_LABEL 18) +(defconstant $SQL_COLATT_OPT_MAX $SQL_COLUMN_LABEL) + +(defconstant $SQL_COLUMN_DRIVER_START 1000) + +(defconstant $SQL_COLATT_OPT_MIN $SQL_COLUMN_COUNT) + +;; SQLColAttributes subdefines for SQL_COLUMN_UPDATABLE +(defconstant $SQL_ATTR_READONLY 0) +(defconstant $SQL_ATTR_WRITE 1) +(defconstant $SQL_ATTR_READWRITE_UNKNOWN 2) + +;; SQLColAttributes subdefines for SQL_COLUMN_SEARCHABLE +;; These are also used by SQLGetInfo +(defconstant $SQL_UNSEARCHABLE 0) +(defconstant $SQL_LIKE_ONLY 1) +(defconstant $SQL_ALL_EXCEPT_LIKE 2) +(defconstant $SQL_SEARCHABLE 3) + +;; SQLError defines +(defconstant $SQL_NULL_HENV 0) +(defconstant $SQL_NULL_HDBC 0) +(defconstant $SQL_NULL_HSTMT 0) + +;; Defines for SQLGetFunctions +;; Core Functions +;; +(defconstant $SQL_API_SQLALLOCCONNECT 1) +(defconstant $SQL_API_SQLALLOCENV 2) +(defconstant $SQL_API_SQLALLOCSTMT 3) +(defconstant $SQL_API_SQLBINDCOL 4) +(defconstant $SQL_API_SQLCANCEL 5) +(defconstant $SQL_API_SQLCOLATTRIBUTES 6) +(defconstant $SQL_API_SQLCONNECT 7) +(defconstant $SQL_API_SQLDESCRIBECOL 8) +(defconstant $SQL_API_SQLDISCONNECT 9) +(defconstant $SQL_API_SQLERROR 10) +(defconstant $SQL_API_SQLEXECDIRECT 11) +(defconstant $SQL_API_SQLEXECUTE 12) +(defconstant $SQL_API_SQLFETCH 13) +(defconstant $SQL_API_SQLFREECONNECT 14) +(defconstant $SQL_API_SQLFREEENV 15) +(defconstant $SQL_API_SQLFREESTMT 16) +(defconstant $SQL_API_SQLGETCURSORNAME 17) +(defconstant $SQL_API_SQLNUMRESULTCOLS 18) +(defconstant $SQL_API_SQLPREPARE 19) +(defconstant $SQL_API_SQLROWCOUNT 20) +(defconstant $SQL_API_SQLSETCURSORNAME 21) +(defconstant $SQL_API_SQLSETPARAM 22) +(defconstant $SQL_API_SQLTRANSACT 23) +(defconstant $SQL_NUM_FUNCTIONS 23) +(defconstant $SQL_EXT_API_START 40) + +;; Level 1 Functions + +(defconstant $SQL_API_SQLCOLUMNS 40) +(defconstant $SQL_API_SQLDRIVERCONNECT 41) +(defconstant $SQL_API_SQLGETCONNECTOPTION 42) +(defconstant $SQL_API_SQLGETDATA 43) +(defconstant $SQL_API_SQLGETFUNCTIONS 44) +(defconstant $SQL_API_SQLGETINFO 45) +(defconstant $SQL_API_SQLGETSTMTOPTION 46) +(defconstant $SQL_API_SQLGETTYPEINFO 47) +(defconstant $SQL_API_SQLPARAMDATA 48) +(defconstant $SQL_API_SQLPUTDATA 49) +(defconstant $SQL_API_SQLSETCONNECTOPTION 50) +(defconstant $SQL_API_SQLSETSTMTOPTION 51) +(defconstant $SQL_API_SQLSPECIALCOLUMNS 52) +(defconstant $SQL_API_SQLSTATISTICS 53) +(defconstant $SQL_API_SQLTABLES 54) + +;; Level 2 Functions + +(defconstant $SQL_API_SQLBROWSECONNECT 55) +(defconstant $SQL_API_SQLCOLUMNPRIVILEGES 56) +(defconstant $SQL_API_SQLDATASOURCES 57) +(defconstant $SQL_API_SQLDESCRIBEPARAM 58) +(defconstant $SQL_API_SQLEXTENDEDFETCH 59) +(defconstant $SQL_API_SQLFOREIGNKEYS 60) +(defconstant $SQL_API_SQLMORERESULTS 61) +(defconstant $SQL_API_SQLNATIVESQL 62) +(defconstant $SQL_API_SQLNUMPARAMS 63) +(defconstant $SQL_API_SQLPARAMOPTIONS 64) +(defconstant $SQL_API_SQLPRIMARYKEYS 65) +(defconstant $SQL_API_SQLPROCEDURECOLUMNS 66) +(defconstant $SQL_API_SQLPROCEDURES 67) +(defconstant $SQL_API_SQLSETPOS 68) +(defconstant $SQL_API_SQLSETSCROLLOPTIONS 69) +(defconstant $SQL_API_SQLTABLEPRIVILEGES 70) + +;/* SDK 2.0 Additions */ +(defconstant $SQL_API_SQLDRIVERS 71) +(defconstant $SQL_API_SQLBINDPARAMETER 72) +(defconstant $SQL_EXT_API_LAST $SQL_API_SQLBINDPARAMETER) + +(defconstant $SQL_API_ALL_FUNCTIONS 0) + +(defconstant $SQL_NUM_EXTENSIONS (- $SQL_EXT_API_LAST $SQL_EXT_API_START -1)) +(defconstant $SQL_API_LOADBYORDINAL 199) + +;;; Defines for SQLGetInfo +(defconstant $SQL_INFO_FIRST 0) +(defconstant $SQL_ACTIVE_CONNECTIONS 0) +(defconstant $SQL_ACTIVE_STATEMENTS 1) +(defconstant $SQL_DATA_SOURCE_NAME 2) +(defconstant $SQL_DRIVER_HDBC 3) +(defconstant $SQL_DRIVER_HENV 4) +(defconstant $SQL_DRIVER_HSTMT 5) +(defconstant $SQL_DRIVER_NAME 6) +(defconstant $SQL_DRIVER_VER 7) +(defconstant $SQL_FETCH_DIRECTION 8) +(defconstant $SQL_ODBC_API_CONFORMANCE 9) +(defconstant $SQL_ODBC_VER 10) +(defconstant $SQL_ROW_UPDATES 11) +(defconstant $SQL_ODBC_SAG_CLI_CONFORMANCE 12) +(defconstant $SQL_SERVER_NAME 13) +(defconstant $SQL_SEARCH_PATTERN_ESCAPE 14) +(defconstant $SQL_ODBC_SQL_CONFORMANCE 15) + +(defconstant $SQL_DBMS_NAME 17) +(defconstant $SQL_DBMS_VER 18) + +(defconstant $SQL_ACCESSIBLE_TABLES 19) +(defconstant $SQL_ACCESSIBLE_PROCEDURES 20) +(defconstant $SQL_PROCEDURES 21) +(defconstant $SQL_CONCAT_NULL_BEHAVIOR 22) +(defconstant $SQL_CURSOR_COMMIT_BEHAVIOR 23) +(defconstant $SQL_CURSOR_ROLLBACK_BEHAVIOR 24) +(defconstant $SQL_DATA_SOURCE_READ_ONLY 25) +(defconstant $SQL_DEFAULT_TXN_ISOLATION 26) +(defconstant $SQL_EXPRESSIONS_IN_ORDERBY 27) +(defconstant $SQL_IDENTIFIER_CASE 28) +(defconstant $SQL_IDENTIFIER_QUOTE_CHAR 29) +(defconstant $SQL_MAX_COLUMN_NAME_LEN 30) +(defconstant $SQL_MAX_CURSOR_NAME_LEN 31) +(defconstant $SQL_MAX_OWNER_NAME_LEN 32) +(defconstant $SQL_MAX_PROCEDURE_NAME_LEN 33) +(defconstant $SQL_MAX_QUALIFIER_NAME_LEN 34) +(defconstant $SQL_MAX_TABLE_NAME_LEN 35) +(defconstant $SQL_MULT_RESULT_SETS 36) +(defconstant $SQL_MULTIPLE_ACTIVE_TXN 37) +(defconstant $SQL_OUTER_JOINS 38) +(defconstant $SQL_OWNER_TERM 39) +(defconstant $SQL_PROCEDURE_TERM 40) +(defconstant $SQL_QUALIFIER_NAME_SEPARATOR 41) +(defconstant $SQL_QUALIFIER_TERM 42) +(defconstant $SQL_SCROLL_CONCURRENCY 43) +(defconstant $SQL_SCROLL_OPTIONS 44) +(defconstant $SQL_TABLE_TERM 45) +(defconstant $SQL_TXN_CAPABLE 46) +(defconstant $SQL_USER_NAME 47) + +(defconstant $SQL_CONVERT_FUNCTIONS 48) +(defconstant $SQL_NUMERIC_FUNCTIONS 49) +(defconstant $SQL_STRING_FUNCTIONS 50) +(defconstant $SQL_SYSTEM_FUNCTIONS 51) +(defconstant $SQL_TIMEDATE_FUNCTIONS 52) + +(defconstant $SQL_CONVERT_BIGINT 53) +(defconstant $SQL_CONVERT_BINARY 54) +(defconstant $SQL_CONVERT_BIT 55) +(defconstant $SQL_CONVERT_CHAR 56) +(defconstant $SQL_CONVERT_DATE 57) +(defconstant $SQL_CONVERT_DECIMAL 58) +(defconstant $SQL_CONVERT_DOUBLE 59) +(defconstant $SQL_CONVERT_FLOAT 60) +(defconstant $SQL_CONVERT_INTEGER 61) +(defconstant $SQL_CONVERT_LONGVARCHAR 62) +(defconstant $SQL_CONVERT_NUMERIC 63) +(defconstant $SQL_CONVERT_REAL 64) +(defconstant $SQL_CONVERT_SMALLINT 65) +(defconstant $SQL_CONVERT_TIME 66) +(defconstant $SQL_CONVERT_TIMESTAMP 67) +(defconstant $SQL_CONVERT_TINYINT 68) +(defconstant $SQL_CONVERT_VARBINARY 69) +(defconstant $SQL_CONVERT_VARCHAR 70) +(defconstant $SQL_CONVERT_LONGVARBINARY 71) + +(defconstant $SQL_TXN_ISOLATION_OPTION 72) +(defconstant $SQL_ODBC_SQL_OPT_IEF 73) + +;;; ODBC SDK 1.0 Additions +(defconstant $SQL_CORRELATION_NAME 74) +(defconstant $SQL_NON_NULLABLE_COLUMNS 75) + +;;; ODBC SDK 2.0 Additions +(defconstant $SQL_DRIVER_HLIB 76) +(defconstant $SQL_DRIVER_ODBC_VER 77) +(defconstant $SQL_LOCK_TYPES 78) +(defconstant $SQL_POS_OPERATIONS 79) +(defconstant $SQL_POSITIONED_STATEMENTS 80) +(defconstant $SQL_GETDATA_EXTENSIONS 81) +(defconstant $SQL_BOOKMARK_PERSISTENCE 82) +(defconstant $SQL_STATIC_SENSITIVITY 83) +(defconstant $SQL_FILE_USAGE 84) +(defconstant $SQL_NULL_COLLATION 85) +(defconstant $SQL_ALTER_TABLE 86) +(defconstant $SQL_COLUMN_ALIAS 87) +(defconstant $SQL_GROUP_BY 88) +(defconstant $SQL_KEYWORDS 89) +(defconstant $SQL_ORDER_BY_COLUMNS_IN_SELECT 90) +(defconstant $SQL_OWNER_USAGE 91) +(defconstant $SQL_QUALIFIER_USAGE 92) +(defconstant $SQL_QUOTED_IDENTIFIER_CASE 93) +(defconstant $SQL_SPECIAL_CHARACTERS 94) +(defconstant $SQL_SUBQUERIES 95) +(defconstant $SQL_UNION 96) +(defconstant $SQL_MAX_COLUMNS_IN_GROUP_BY 97) +(defconstant $SQL_MAX_COLUMNS_IN_INDEX 98) +(defconstant $SQL_MAX_COLUMNS_IN_ORDER_BY 99) +(defconstant $SQL_MAX_COLUMNS_IN_SELECT 100) +(defconstant $SQL_MAX_COLUMNS_IN_TABLE 101) +(defconstant $SQL_MAX_INDEX_SIZE 102) +(defconstant $SQL_MAX_ROW_SIZE_INCLUDES_LONG 103) +(defconstant $SQL_MAX_ROW_SIZE 104) +(defconstant $SQL_MAX_STATEMENT_LEN 105) +(defconstant $SQL_MAX_TABLES_IN_SELECT 106) +(defconstant $SQL_MAX_USER_NAME_LEN 107) +(defconstant $SQL_MAX_CHAR_LITERAL_LEN 108) +(defconstant $SQL_TIMEDATE_ADD_INTERVALS 109) +(defconstant $SQL_TIMEDATE_DIFF_INTERVALS 110) +(defconstant $SQL_NEED_LONG_DATA_LEN 111) +(defconstant $SQL_MAX_BINARY_LITERAL_LEN 112) +(defconstant $SQL_LIKE_ESCAPE_CLAUSE 113) +(defconstant $SQL_QUALIFIER_LOCATION 114) +(defconstant $SQL_ACTIVE_ENVIRONMENTS 116) + +#| + +/*** ODBC SDK 2.01 Additions ***/) +(defconstant $SQL_OJ_CAPABILITIES 65003 ;; Temp value until ODBC 3.0 + +(defconstant $SQL_INFO_LAST SQL_QUALIFIER_LOCATION +) +(defconstant $SQL_INFO_DRIVER_START 1000 + +;; SQL_CONVERT_* return value bitmasks +) +(defconstant $SQL_CVT_CHAR #x00000001L) +(defconstant $SQL_CVT_NUMERIC #x00000002L) +(defconstant $SQL_CVT_DECIMAL #x00000004L) +(defconstant $SQL_CVT_INTEGER #x00000008L) +(defconstant $SQL_CVT_SMALLINT #x00000010L) +(defconstant $SQL_CVT_FLOAT #x00000020L) +(defconstant $SQL_CVT_REAL #x00000040L) +(defconstant $SQL_CVT_DOUBLE #x00000080L) +(defconstant $SQL_CVT_VARCHAR #x00000100L) +(defconstant $SQL_CVT_LONGVARCHAR #x00000200L) +(defconstant $SQL_CVT_BINARY #x00000400L) +(defconstant $SQL_CVT_VARBINARY #x00000800L) +(defconstant $SQL_CVT_BIT #x00001000L) +(defconstant $SQL_CVT_TINYINT #x00002000L) +(defconstant $SQL_CVT_BIGINT #x00004000L) +(defconstant $SQL_CVT_DATE #x00008000L) +(defconstant $SQL_CVT_TIME #x00010000L) +(defconstant $SQL_CVT_TIMESTAMP #x00020000L) +(defconstant $SQL_CVT_LONGVARBINARY #x00040000L) + +;; SQL_CONVERT_FUNCTIONS functions) +(defconstant $SQL_FN_CVT_CONVERT #x00000001L) + +;; SQL_STRING_FUNCTIONS functions + +(defconstant $SQL_FN_STR_CONCAT #x00000001L) +(defconstant $SQL_FN_STR_INSERT #x00000002L) +(defconstant $SQL_FN_STR_LEFT #x00000004L) +(defconstant $SQL_FN_STR_LTRIM #x00000008L) +(defconstant $SQL_FN_STR_LENGTH #x00000010L) +(defconstant $SQL_FN_STR_LOCATE #x00000020L) +(defconstant $SQL_FN_STR_LCASE #x00000040L) +(defconstant $SQL_FN_STR_REPEAT #x00000080L) +(defconstant $SQL_FN_STR_REPLACE #x00000100L) +(defconstant $SQL_FN_STR_RIGHT #x00000200L) +(defconstant $SQL_FN_STR_RTRIM #x00000400L) +(defconstant $SQL_FN_STR_SUBSTRING #x00000800L) +(defconstant $SQL_FN_STR_UCASE #x00001000L) +(defconstant $SQL_FN_STR_ASCII #x00002000L) +(defconstant $SQL_FN_STR_CHAR #x00004000L +(defconstant $SQL_FN_STR_DIFFERENCE #x00008000L) +(defconstant $SQL_FN_STR_LOCATE_2 #x00010000L) +(defconstant $SQL_FN_STR_SOUNDEX #x00020000L) +(defconstant $SQL_FN_STR_SPACE #x00040000L + +;; SQL_NUMERIC_FUNCTIONS functions +) +(defconstant $SQL_FN_NUM_ABS #x00000001L) +(defconstant $SQL_FN_NUM_ACOS #x00000002L) +(defconstant $SQL_FN_NUM_ASIN #x00000004L) +(defconstant $SQL_FN_NUM_ATAN #x00000008L) +(defconstant $SQL_FN_NUM_ATAN2 #x00000010L) +(defconstant $SQL_FN_NUM_CEILING #x00000020L) +(defconstant $SQL_FN_NUM_COS #x00000040L) +(defconstant $SQL_FN_NUM_COT #x00000080L) +(defconstant $SQL_FN_NUM_EXP #x00000100L) +(defconstant $SQL_FN_NUM_FLOOR #x00000200L) +(defconstant $SQL_FN_NUM_LOG #x00000400L) +(defconstant $SQL_FN_NUM_MOD #x00000800L) +(defconstant $SQL_FN_NUM_SIGN #x00001000L) +(defconstant $SQL_FN_NUM_SIN #x00002000L) +(defconstant $SQL_FN_NUM_SQRT #x00004000L) +(defconstant $SQL_FN_NUM_TAN #x00008000L) +(defconstant $SQL_FN_NUM_PI #x00010000L) +(defconstant $SQL_FN_NUM_RAND #x00020000L +(defconstant $SQL_FN_NUM_DEGREES #x00040000L) +(defconstant $SQL_FN_NUM_LOG10 #x00080000L) +(defconstant $SQL_FN_NUM_POWER #x00100000L) +(defconstant $SQL_FN_NUM_RADIANS #x00200000L) +(defconstant $SQL_FN_NUM_ROUND #x00400000L) +(defconstant $SQL_FN_NUM_TRUNCATE #x00800000L + +;; SQL_TIMEDATE_FUNCTIONS functions +) +(defconstant $SQL_FN_TD_NOW #x00000001L) +(defconstant $SQL_FN_TD_CURDATE #x00000002L) +(defconstant $SQL_FN_TD_DAYOFMONTH #x00000004L) +(defconstant $SQL_FN_TD_DAYOFWEEK #x00000008L) +(defconstant $SQL_FN_TD_DAYOFYEAR #x00000010L) +(defconstant $SQL_FN_TD_MONTH #x00000020L) +(defconstant $SQL_FN_TD_QUARTER #x00000040L) +(defconstant $SQL_FN_TD_WEEK #x00000080L) +(defconstant $SQL_FN_TD_YEAR #x00000100L) +(defconstant $SQL_FN_TD_CURTIME #x00000200L) +(defconstant $SQL_FN_TD_HOUR #x00000400L) +(defconstant $SQL_FN_TD_MINUTE #x00000800L) +(defconstant $SQL_FN_TD_SECOND #x00001000L +(defconstant $SQL_FN_TD_TIMESTAMPADD #x00002000L) +(defconstant $SQL_FN_TD_TIMESTAMPDIFF #x00004000L) +(defconstant $SQL_FN_TD_DAYNAME #x00008000L) +(defconstant $SQL_FN_TD_MONTHNAME #x00010000L + +;; SQL_SYSTEM_FUNCTIONS functions +) +(defconstant $SQL_FN_SYS_USERNAME #x00000001L) +(defconstant $SQL_FN_SYS_DBNAME #x00000002L) +(defconstant $SQL_FN_SYS_IFNULL #x00000004L + +;; SQL_TIMEDATE_ADD_INTERVALS and SQL_TIMEDATE_DIFF_INTERVALS functions + +(defconstant $SQL_FN_TSI_FRAC_SECOND #x00000001L) +(defconstant $SQL_FN_TSI_SECOND #x00000002L) +(defconstant $SQL_FN_TSI_MINUTE #x00000004L) +(defconstant $SQL_FN_TSI_HOUR #x00000008L) +(defconstant $SQL_FN_TSI_DAY #x00000010L) +(defconstant $SQL_FN_TSI_WEEK #x00000020L) +(defconstant $SQL_FN_TSI_MONTH #x00000040L) +(defconstant $SQL_FN_TSI_QUARTER #x00000080L) +(defconstant $SQL_FN_TSI_YEAR #x00000100L + +;; SQL_ODBC_API_CONFORMANCE values +) +(defconstant $SQL_OAC_NONE #x0000) +(defconstant $SQL_OAC_LEVEL1 #x0001) +(defconstant $SQL_OAC_LEVEL2 #x0002 + +;; SQL_ODBC_SAG_CLI_CONFORMANCE values +) +(defconstant $SQL_OSCC_NOT_COMPLIANT #x0000) +(defconstant $SQL_OSCC_COMPLIANT #x0001 + +;; SQL_ODBC_SQL_CONFORMANCE values +) +(defconstant $SQL_OSC_MINIMUM #x0000) +(defconstant $SQL_OSC_CORE #x0001) +(defconstant $SQL_OSC_EXTENDED #x0002 + +;; SQL_CONCAT_NULL_BEHAVIOR values +) +(defconstant $SQL_CB_NULL #x0000) +(defconstant $SQL_CB_NON_NULL #x0001 + +;; SQL_CURSOR_COMMIT_BEHAVIOR and SQL_CURSOR_ROLLBACK_BEHAVIOR values +) +(defconstant $SQL_CB_DELETE #x0000) +(defconstant $SQL_CB_CLOSE #x0001) +(defconstant $SQL_CB_PRESERVE #x0002 + +;; SQL_IDENTIFIER_CASE values +) +(defconstant $SQL_IC_UPPER #x0001) +(defconstant $SQL_IC_LOWER #x0002) +(defconstant $SQL_IC_SENSITIVE #x0003) +(defconstant $SQL_IC_MIXED #x0004 + +;; SQL_TXN_CAPABLE values +|# + +(defconstant $SQL_TC_NONE 0) +(defconstant $SQL_TC_DML 1) +(defconstant $SQL_TC_ALL 2) + +(defconstant $SQL_TC_DDL_COMMIT 3) +(defconstant $SQL_TC_DDL_IGNORE 4) + +;; SQL_SCROLL_OPTIONS masks + + +(defconstant $SQL_SO_FORWARD_ONLY #x00000001) +(defconstant $SQL_SO_KEYSET_DRIVEN #x00000002) +(defconstant $SQL_SO_DYNAMIC #x00000004) +(defconstant $SQL_SO_MIXED #x00000008) +(defconstant $SQL_SO_STATIC #x00000010) + +;; SQL_SCROLL_CONCURRENCY masks + +(defconstant $SQL_SCCO_READ_ONLY #x00000001) +(defconstant $SQL_SCCO_LOCK #x00000002) +(defconstant $SQL_SCCO_OPT_ROWVER #x00000004) +(defconstant $SQL_SCCO_OPT_VALUES #x00000008) + +;; SQL_FETCH_DIRECTION masks + +(defconstant $SQL_FD_FETCH_NEXT #x00000001) +(defconstant $SQL_FD_FETCH_FIRST #x00000002) +(defconstant $SQL_FD_FETCH_LAST #x00000004) +(defconstant $SQL_FD_FETCH_PRIOR #x00000008) +(defconstant $SQL_FD_FETCH_ABSOLUTE #x00000010) +(defconstant $SQL_FD_FETCH_RELATIVE #x00000020) +(defconstant $SQL_FD_FETCH_RESUME #x00000040) +(defconstant $SQL_FD_FETCH_BOOKMARK #x00000080) + +#| +;; SQL_TXN_ISOLATION_OPTION masks +) +(defconstant $SQL_TXN_READ_UNCOMMITTED #x00000001L) +(defconstant $SQL_TXN_READ_COMMITTED #x00000002L) +(defconstant $SQL_TXN_REPEATABLE_READ #x00000004L) +(defconstant $SQL_TXN_SERIALIZABLE #x00000008L) +(defconstant $SQL_TXN_VERSIONING #x00000010L + +;; SQL_CORRELATION_NAME values +) +(defconstant $SQL_CN_NONE #x0000) +(defconstant $SQL_CN_DIFFERENT #x0001) +(defconstant $SQL_CN_ANY #x0002 + +;; SQL_NON_NULLABLE_COLUMNS values +) +(defconstant $SQL_NNC_NULL #x0000) +(defconstant $SQL_NNC_NON_NULL #x0001 + +;; SQL_NULL_COLLATION values + ) +(defconstant $SQL_NC_HIGH #x0000) +(defconstant $SQL_NC_LOW #x0001) +(defconstant $SQL_NC_START #x0002) +(defconstant $SQL_NC_END #x0004 + +;; SQL_FILE_USAGE values +) +(defconstant $SQL_FILE_NOT_SUPPORTED #x0000) +(defconstant $SQL_FILE_TABLE #x0001) +(defconstant $SQL_FILE_QUALIFIER #x0002 + +;; SQL_GETDATA_EXTENSIONS values +) +(defconstant $SQL_GD_ANY_COLUMN #x00000001L) +(defconstant $SQL_GD_ANY_ORDER #x00000002L) +(defconstant $SQL_GD_BLOCK #x00000004L) +(defconstant $SQL_GD_BOUND #x00000008L + +;; SQL_ALTER_TABLE values +) +(defconstant $SQL_AT_ADD_COLUMN #x00000001L) +(defconstant $SQL_AT_DROP_COLUMN #x00000002L + +;; SQL_POSITIONED_STATEMENTS masks +) +(defconstant $SQL_PS_POSITIONED_DELETE #x00000001L) +(defconstant $SQL_PS_POSITIONED_UPDATE #x00000002L) +(defconstant $SQL_PS_SELECT_FOR_UPDATE #x00000004L + +;; SQL_GROUP_BY values +) +(defconstant $SQL_GB_NOT_SUPPORTED #x0000) +(defconstant $SQL_GB_GROUP_BY_EQUALS_SELECT #x0001) +(defconstant $SQL_GB_GROUP_BY_CONTAINS_SELECT #x0002) +(defconstant $SQL_GB_NO_RELATION #x0003 + +;; SQL_OWNER_USAGE masks +) +(defconstant $SQL_OU_DML_STATEMENTS #x00000001L) +(defconstant $SQL_OU_PROCEDURE_INVOCATION #x00000002L) +(defconstant $SQL_OU_TABLE_DEFINITION #x00000004L) +(defconstant $SQL_OU_INDEX_DEFINITION #x00000008L) +(defconstant $SQL_OU_PRIVILEGE_DEFINITION #x00000010L + +;; SQL_QUALIFIER_USAGE masks +) +(defconstant $SQL_QU_DML_STATEMENTS #x00000001L) +(defconstant $SQL_QU_PROCEDURE_INVOCATION #x00000002L) +(defconstant $SQL_QU_TABLE_DEFINITION #x00000004L) +(defconstant $SQL_QU_INDEX_DEFINITION #x00000008L) +(defconstant $SQL_QU_PRIVILEGE_DEFINITION #x00000010L + +;; SQL_SUBQUERIES masks +) +(defconstant $SQL_SQ_COMPARISON #x00000001L) +(defconstant $SQL_SQ_EXISTS #x00000002L) +(defconstant $SQL_SQ_IN #x00000004L) +(defconstant $SQL_SQ_QUANTIFIED #x00000008L) +(defconstant $SQL_SQ_CORRELATED_SUBQUERIES #x00000010L + +;; SQL_UNION masks +) +(defconstant $SQL_U_UNION #x00000001L) +(defconstant $SQL_U_UNION_ALL #x00000002L + +;; SQL_BOOKMARK_PERSISTENCE values +) +(defconstant $SQL_BP_CLOSE #x00000001L) +(defconstant $SQL_BP_DELETE #x00000002L) +(defconstant $SQL_BP_DROP #x00000004L) +(defconstant $SQL_BP_TRANSACTION #x00000008L) +(defconstant $SQL_BP_UPDATE #x00000010L) +(defconstant $SQL_BP_OTHER_HSTMT #x00000020L) +(defconstant $SQL_BP_SCROLL #x00000040L + +;; SQL_STATIC_SENSITIVITY values +) +(defconstant $SQL_SS_ADDITIONS #x00000001L) +(defconstant $SQL_SS_DELETIONS #x00000002L) +(defconstant $SQL_SS_UPDATES #x00000004L + +;; SQL_LOCK_TYPESL masks +) +(defconstant $SQL_LCK_NO_CHANGE #x00000001L) +(defconstant $SQL_LCK_EXCLUSIVE #x00000002L) +(defconstant $SQL_LCK_UNLOCK #x00000004L + +;; SQL_POS_OPERATIONS masks +|# + +(defconstant $SQL_POS_POSITION 1) ;; #x00000001L +(defconstant $SQL_POS_REFRESH 2) ;; #x00000002L +(defconstant $SQL_POS_UPDATE 4) ;; #x00000004L +(defconstant $SQL_POS_DELETE 8) ;; #x00000008L +(defconstant $SQL_POS_ADD 16) ;; #x00000010L + +#| +;; SQL_QUALIFIER_LOCATION values +) +(defconstant $SQL_QL_START #x0001L) +(defconstant $SQL_QL_END #x0002L + +;; SQL_OJ_CAPABILITIES values + +(defconstant $SQL_OJ_LEFT #x00000001L) +(defconstant $SQL_OJ_RIGHT #x00000002L) +(defconstant $SQL_OJ_FULL #x00000004L) +(defconstant $SQL_OJ_NESTED #x00000008L) +(defconstant $SQL_OJ_NOT_ORDERED #x00000010L) +(defconstant $SQL_OJ_INNER #x00000020L) +(defconstant $SQL_OJ_ALL_COMPARISON_OPS #x00000040L + +;; options for SQLGetStmtOption/SQLSetStmtOption) +(defconstant $SQL_QUERY_TIMEOUT 0) +(defconstant $SQL_MAX_ROWS 1) +(defconstant $SQL_NOSCAN 2) +(defconstant $SQL_MAX_LENGTH 3) +(defconstant $SQL_ASYNC_ENABLE 4) +(defconstant $SQL_BIND_TYPE 5 +(defconstant $SQL_CURSOR_TYPE 6) +(defconstant $SQL_CONCURRENCY 7) +(defconstant $SQL_KEYSET_SIZE 8) +(defconstant $SQL_ROWSET_SIZE 9) +(defconstant $SQL_SIMULATE_CURSOR 10) +(defconstant $SQL_RETRIEVE_DATA 11) +(defconstant $SQL_USE_BOOKMARKS 12) +(defconstant $SQL_GET_BOOKMARK 13 /* GetStmtOption Only) +(defconstant $SQL_ROW_NUMBER 14 /* GetStmtOption Only) +(defconstant $SQL_STMT_OPT_MAX SQL_ROW_NUMBER +) +(defconstant $SQL_STMT_OPT_MIN SQL_QUERY_TIMEOUT + + +;; SQL_QUERY_TIMEOUT options) +(defconstant $SQL_QUERY_TIMEOUT_DEFAULT 0UL + +;; SQL_MAX_ROWS options) +(defconstant $SQL_MAX_ROWS_DEFAULT 0UL + +;; SQL_NOSCAN options) +(defconstant $SQL_NOSCAN_OFF 0UL /* 1.0 FALSE) +(defconstant $SQL_NOSCAN_ON 1UL /* 1.0 TRUE) +(defconstant $SQL_NOSCAN_DEFAULT SQL_NOSCAN_OFF + +;; SQL_MAX_LENGTH options) +(defconstant $SQL_MAX_LENGTH_DEFAULT 0UL + +;; SQL_ASYNC_ENABLE options) +(defconstant $SQL_ASYNC_ENABLE_OFF 0UL) +(defconstant $SQL_ASYNC_ENABLE_ON 1UL) +(defconstant $SQL_ASYNC_ENABLE_DEFAULT SQL_ASYNC_ENABLE_OFF + +;; SQL_BIND_TYPE options) +(defconstant $SQL_BIND_BY_COLUMN 0UL) +(defconstant $SQL_BIND_TYPE_DEFAULT SQL_BIND_BY_COLUMN ;; Default value + +;; SQL_CONCURRENCY options) +(defconstant $SQL_CONCUR_READ_ONLY 1) +(defconstant $SQL_CONCUR_LOCK 2) +(defconstant $SQL_CONCUR_ROWVER 3) +(defconstant $SQL_CONCUR_VALUES 4) +(defconstant $SQL_CONCUR_DEFAULT SQL_CONCUR_READ_ONLY ;; Default value + +;; SQL_CURSOR_TYPE options) +(defconstant $SQL_CURSOR_FORWARD_ONLY 0UL) +(defconstant $SQL_CURSOR_KEYSET_DRIVEN 1UL) +(defconstant $SQL_CURSOR_DYNAMIC 2UL) +(defconstant $SQL_CURSOR_STATIC 3UL) +(defconstant $SQL_CURSOR_TYPE_DEFAULT SQL_CURSOR_FORWARD_ONLY ;; Default value + +;; SQL_ROWSET_SIZE options) +(defconstant $SQL_ROWSET_SIZE_DEFAULT 1UL + +;; SQL_KEYSET_SIZE options) +(defconstant $SQL_KEYSET_SIZE_DEFAULT 0UL + +;; SQL_SIMULATE_CURSOR options) +(defconstant $SQL_SC_NON_UNIQUE 0UL) +(defconstant $SQL_SC_TRY_UNIQUE 1UL) +(defconstant $SQL_SC_UNIQUE 2UL + +;; SQL_RETRIEVE_DATA options) +(defconstant $SQL_RD_OFF 0UL) +(defconstant $SQL_RD_ON 1UL) +(defconstant $SQL_RD_DEFAULT SQL_RD_ON + +;; SQL_USE_BOOKMARKS options) +(defconstant $SQL_UB_OFF 0UL) +(defconstant $SQL_UB_ON 1UL) +(defconstant $SQL_UB_DEFAULT SQL_UB_OFF + + +|# + +;; options for SQLSetConnectOption/SQLGetConnectOption) +(defconstant $SQL_ACCESS_MODE 101) +(defconstant $SQL_AUTOCOMMIT 102) +(defconstant $SQL_LOGIN_TIMEOUT 103) +(defconstant $SQL_OPT_TRACE 104) +(defconstant $SQL_OPT_TRACEFILE 105) +(defconstant $SQL_TRANSLATE_DLL 106) +(defconstant $SQL_TRANSLATE_OPTION 107) +(defconstant $SQL_TXN_ISOLATION 108) +(defconstant $SQL_CURRENT_QUALIFIER 109) +(defconstant $SQL_ODBC_CURSORS 110) +(defconstant $SQL_QUIET_MODE 111) +(defconstant $SQL_PACKET_SIZE 112) +(defconstant $SQL_CONN_OPT_MAX $SQL_PACKET_SIZE) +(defconstant $SQL_CONNECT_OPT_DRVR_START 1000) + +;;#define SQL_CONN_OPT_MIN SQL_ACCESS_MODE + +;; SQL_ACCESS_MODE options +(defconstant $SQL_MODE_READ_WRITE 0) ; 0UL +(defconstant $SQL_MODE_READ_ONLY 1) ; 1UL +(defconstant $SQL_MODE_DEFAULT $SQL_MODE_READ_WRITE) + +;; SQL_AUTOCOMMIT options) +(defconstant $SQL_AUTOCOMMIT_OFF 0) ;0UL +(defconstant $SQL_AUTOCOMMIT_ON 1) ;1UL +(defconstant $SQL_AUTOCOMMIT_DEFAULT $SQL_AUTOCOMMIT_ON) + +;; SQL_LOGIN_TIMEOUT options) +(defconstant $SQL_LOGIN_TIMEOUT_DEFAULT 15) ; 15UL + +;; SQL_OPT_TRACE options) +(defconstant $SQL_OPT_TRACE_OFF 0) ; 0UL +(defconstant $SQL_OPT_TRACE_ON 1) ; 1UL +(defconstant $SQL_OPT_TRACE_DEFAULT $SQL_OPT_TRACE_OFF) +; #ifndef SQL_OPT_TRACE_FILE_DEFAULT +; (defconstant $SQL_OPT_TRACE_FILE_DEFAULT "\\SQL.LOG" +;; #endif + +(defconstant $SQL_CUR_USE_IF_NEEDED 0) ; 0UL +(defconstant $SQL_CUR_USE_ODBC 1) ; 1UL +(defconstant $SQL_CUR_USE_DRIVER 2) ; 2UL +(defconstant $SQL_CUR_DEFAULT $SQL_CUR_USE_DRIVER) + +#| +;; Column types and scopes in SQLSpecialColumns. ) +(defconstant $SQL_BEST_ROWID 1) +(defconstant $SQL_ROWVER 2) +) +(defconstant $SQL_SCOPE_CURROW 0) +(defconstant $SQL_SCOPE_TRANSACTION 1) +(defconstant $SQL_SCOPE_SESSION 2 + +;; Defines for SQLSetPos) +(defconstant $SQL_ENTIRE_ROWSET 0 +|# + +;; Operations in SQLSetPos + +(defconstant $SQL_POSITION 0) ;; 1.0 FALSE +(defconstant $SQL_REFRESH 1) ;; 1.0 TRUE +(defconstant $SQL_UPDATE 2) +(defconstant $SQL_DELETE 3) +(defconstant $SQL_ADD 4) + +;; Lock options in SQLSetPos) +(defconstant $SQL_LOCK_NO_CHANGE 0) ;; 1.0 FALSE +(defconstant $SQL_LOCK_EXCLUSIVE 1) ;; 1.0 TRUE +(defconstant $SQL_LOCK_UNLOCK 2) + +;; SQLBindParameter extensions +(defconstant $SQL_DEFAULT_PARAM -5) +(defconstant $SQL_IGNORE -6) +(defconstant $SQL_LEN_DATA_AT_EXEC_OFFSET -100) +;(defconstant $SQL_LEN_DATA_AT_EXEC(length) (-length+SQL_LEN_DATA_AT_EXEC_OFFSET) + +;; Special return values for SQLGetData +(defconstant $SQL_NO_TOTAL -4) + +#| +;; Macros for SQLSetPos) +(defconstant $SQL_POSITION_TO(hstmt,irow) SQLSetPos(hstmt,irow,SQL_POSITION,SQL_LOCK_NO_CHANGE)) +(defconstant $SQL_LOCK_RECORD(hstmt,irow,fLock) SQLSetPos(hstmt,irow,SQL_POSITION,fLock)) +(defconstant $SQL_REFRESH_RECORD(hstmt,irow,fLock) SQLSetPos(hstmt,irow,SQL_REFRESH,fLock)) +(defconstant $SQL_UPDATE_RECORD(hstmt,irow) SQLSetPos(hstmt,irow,SQL_UPDATE,SQL_LOCK_NO_CHANGE)) +(defconstant $SQL_DELETE_RECORD(hstmt,irow) SQLSetPos(hstmt,irow,SQL_DELETE,SQL_LOCK_NO_CHANGE)) +(defconstant $SQL_ADD_RECORD(hstmt,irow) SQLSetPos(hstmt,irow,SQL_ADD,SQL_LOCK_NO_CHANGE) + +; #ifndef RC_INVOKED + +/* This define is too large for RC) +(defconstant $SQL_ODBC_KEYWORDS \ +"ABSOLUTE,ACTION,ADA,ADD,ALL,ALLOCATE,ALTER,AND,ANY,ARE,AS,"\ +"ASC,ASSERTION,AT,AUTHORIZATION,AVG,"\ +"BEGIN,BETWEEN,BIT,BIT_LENGTH,BOTH,BY,CASCADE,CASCADED,CASE,CAST,CATALOG,"\ +"CHAR,CHAR_LENGTH,CHARACTER,CHARACTER_LENGTH,CHECK,CLOSE,COALESCE,"\ +"COBOL,COLLATE,COLLATION,COLUMN,COMMIT,CONNECT,CONNECTION,CONSTRAINT,"\ +"CONSTRAINTS,CONTINUE,CONVERT,CORRESPONDING,COUNT,CREATE,CROSS,CURRENT,"\ +"CURRENT_DATE,CURRENT_TIME,CURRENT_TIMESTAMP,CURRENT_USER,CURSOR,"\ +"DATE,DAY,DEALLOCATE,DEC,DECIMAL,DECLARE,DEFAULT,DEFERRABLE,"\ +"DEFERRED,DELETE,DESC,DESCRIBE,DESCRIPTOR,DIAGNOSTICS,DISCONNECT,"\ +"DISTINCT,DOMAIN,DOUBLE,DROP,"\ +"ELSE,END,END-EXEC,ESCAPE,EXCEPT,EXCEPTION,EXEC,EXECUTE,"\ +"EXISTS,EXTERNAL,EXTRACT,"\ +"FALSE,FETCH,FIRST,FLOAT,FOR,FOREIGN,FORTRAN,FOUND,FROM,FULL,"\ +"GET,GLOBAL,GO,GOTO,GRANT,GROUP,HAVING,HOUR,"\ +"IDENTITY,IMMEDIATE,IN,INCLUDE,INDEX,INDICATOR,INITIALLY,INNER,"\ +"INPUT,INSENSITIVE,INSERT,INTEGER,INTERSECT,INTERVAL,INTO,IS,ISOLATION,"\ +"JOIN,KEY,LANGUAGE,LAST,LEADING,LEFT,LEVEL,LIKE,LOCAL,LOWER,"\ +"MATCH,MAX,MIN,MINUTE,MODULE,MONTH,MUMPS,"\ +"NAMES,NATIONAL,NATURAL,NCHAR,NEXT,NO,NONE,NOT,NULL,NULLIF,NUMERIC,"\ +"OCTET_LENGTH,OF,ON,ONLY,OPEN,OPTION,OR,ORDER,OUTER,OUTPUT,OVERLAPS,"\ +"PAD,PARTIAL,PASCAL,PLI,POSITION,PRECISION,PREPARE,PRESERVE,"\ +"PRIMARY,PRIOR,PRIVILEGES,PROCEDURE,PUBLIC,"\ +"REFERENCES,RELATIVE,RESTRICT,REVOKE,RIGHT,ROLLBACK,ROWS,"\ +"SCHEMA,SCROLL,SECOND,SECTION,SELECT,SEQUENCE,SESSION,SESSION_USER,SET,SIZE,"\ +"SMALLINT,SOME,SPACE,SQL,SQLCA,SQLCODE,SQLERROR,SQLSTATE,SQLWARNING,"\ +"SUBSTRING,SUM,SYSTEM_USER,"\ +"TABLE,TEMPORARY,THEN,TIME,TIMESTAMP,TIMEZONE_HOUR,TIMEZONE_MINUTE,"\ +"TO,TRAILING,TRANSACTION,TRANSLATE,TRANSLATION,TRIM,TRUE,"\ +"UNION,UNIQUE,UNKNOWN,UPDATE,UPPER,USAGE,USER,USING,"\ +"VALUE,VALUES,VARCHAR,VARYING,VIEW,WHEN,WHENEVER,WHERE,WITH,WORK,YEAR") +|# + +(defconstant $SQL_PARAM_TYPE_UNKNOWN 0) +(defconstant $SQL_PARAM_INPUT 1) +(defconstant $SQL_PARAM_INPUT_OUTPUT 2) +(defconstant $SQL_RESULT_COL 3) +(defconstant $SQL_PARAM_OUTPUT 4) +(defconstant $SQL_RETURN_VALUE 5) + + +;; Defines used by both Level 1 and Level 2 functions + +;; generally useful constants +(defconstant $SQL_MAX_OPTION_STRING_LENGTH 256) + +;; Additional return codes) +(defconstant $SQL_STILL_EXECUTING 2) +(defconstant $SQL_NEED_DATA 99) + +;; SQL extended datatypes) +(defconstant $SQL_DATE 9) +(defconstant $SQL_TIME 10) +(defconstant $SQL_TIMESTAMP 11) +(defconstant $SQL_LONGVARCHAR -1) +(defconstant $SQL_BINARY -2) +(defconstant $SQL_VARBINARY -3) +(defconstant $SQL_LONGVARBINARY -4) +(defconstant $SQL_BIGINT -5) +(defconstant $SQL_TINYINT -6) +(defconstant $SQL_BIT -7) + +;; For ODBC3 +(defconstant $SQL_TYPE_DATE 91) +(defconstant $SQL_TYPE_TIME 92) +(defconstant $SQL_TYPE_TIMESTAMP 93) + +(defconstant $SQL_INTERVAL_YEAR -80) +(defconstant $SQL_INTERVAL_MONTH -81) +(defconstant $SQL_INTERVAL_YEAR_TO_MONTH -82) +(defconstant $SQL_INTERVAL_DAY -83) +(defconstant $SQL_INTERVAL_HOUR -84) +(defconstant $SQL_INTERVAL_MINUTE -85) +(defconstant $SQL_INTERVAL_SECOND -86) +(defconstant $SQL_INTERVAL_DAY_TO_HOUR -87) +(defconstant $SQL_INTERVAL_DAY_TO_MINUTE -88) +(defconstant $SQL_INTERVAL_DAY_TO_SECOND -89) +(defconstant $SQL_INTERVAL_HOUR_TO_MINUTE -90) +(defconstant $SQL_INTERVAL_HOUR_TO_SECOND -91) +(defconstant $SQL_INTERVAL_MINUTE_TO_SECOND -92) +(defconstant $SQL_UNICODE -95) +(defconstant $SQL_TYPE_DRIVER_START $SQL_INTERVAL_YEAR) +(defconstant $SQL_TYPE_DRIVER_END $SQL_UNICODE) + + +(defconstant $SQL_SIGNED_OFFSET -20) +(defconstant $SQL_UNSIGNED_OFFSET -22) + +;; C datatype to SQL datatype mapping +(defconstant $SQL_C_DATE $SQL_DATE) +(defconstant $SQL_C_TIME $SQL_TIME) +(defconstant $SQL_C_TIMESTAMP $SQL_TIMESTAMP) +(defconstant $SQL_C_BINARY $SQL_BINARY) +(defconstant $SQL_C_BIT $SQL_BIT) +(defconstant $SQL_C_TINYINT $SQL_TINYINT) +(defconstant $SQL_C_SBIGINT (+ $SQL_BIGINT $SQL_SIGNED_OFFSET)) +(defconstant $SQL_C_SLONG (+ $SQL_C_LONG $SQL_SIGNED_OFFSET)) ;; SIGNED INTEGER +(defconstant $SQL_C_SSHORT (+ $SQL_C_SHORT $SQL_SIGNED_OFFSET)) ;; SIGNED SMALLINT +(defconstant $SQL_C_STINYINT (+ $SQL_TINYINT $SQL_SIGNED_OFFSET)) ;; SIGNED TINYINT +(defconstant $SQL_C_ULONG (+ $SQL_C_LONG $SQL_UNSIGNED_OFFSET)) ;; UNSIGNED INTEGER +(defconstant $SQL_C_USHORT (+ $SQL_C_SHORT $SQL_UNSIGNED_OFFSET)) ;; UNSIGNED SMALLINT +(defconstant $SQL_C_UTINYINT (+ $SQL_TINYINT $SQL_UNSIGNED_OFFSET)) ;;UNSIGNED TINYINT +(defconstant $SQL_C_BOOKMARK $SQL_C_ULONG) ;; BOOKMARK + +;;; ODBC3 +(defconstant $SQL_C_TYPE_DATE $SQL_TYPE_DATE) +(defconstant $SQL_C_TYPE_TIME $SQL_TYPE_TIME) +(defconstant $SQL_C_TYPE_TIMESTAMP $SQL_TYPE_TIMESTAMP) + +;; Options for SQLDriverConnect +(defconstant $SQL_DRIVER_NOPROMPT 0) +(defconstant $SQL_DRIVER_COMPLETE 1) +(defconstant $SQL_DRIVER_PROMPT 2) +(defconstant $SQL_DRIVER_COMPLETE_REQUIRED 3) + +(defconstant $SQL_MAX_CONN_OUT 1024) + +;; Level 2 Functions + +;; SQLExtendedFetch "fFetchType" values +(defconstant $SQL_FETCH_NEXT 1) +(defconstant $SQL_FETCH_FIRST 2) +(defconstant $SQL_FETCH_LAST 3) +(defconstant $SQL_FETCH_PRIOR 4) +(defconstant $SQL_FETCH_ABSOLUTE 5) +(defconstant $SQL_FETCH_RELATIVE 6) +(defconstant $SQL_FETCH_BOOKMARK 8) + +;;; ODBC3 constants, added by KMR + +(defconstant $SQL_ATTR_ODBC_VERSION 200) +(defconstant $SQL_OV_ODBC2 2) +(defconstant $SQL_OV_ODBC3 3) +(defconstant $SQL_INDEX_UNIQUE 0) +(defconstant $SQL_INDEX_ALL 1) +(defconstant $SQL_QUICK 0) +(defconstant $SQL_ENSURE 1) + + diff --git a/db-odbc/odbc-dbi.lisp b/db-odbc/odbc-dbi.lisp new file mode 100644 index 0000000..90cea24 --- /dev/null +++ b/db-odbc/odbc-dbi.lisp @@ -0,0 +1,706 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: odbc-dbi.cl +;;;; Purpose: Mid-level (DBI) interface for CLSQL ODBC backend +;;;; Author: Kevin M. Rosenberg +;;;; Create: April 2004 +;;;; +;;;; 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. +;;;; ************************************************************************* + +(in-package #:cl-user) + +(defpackage #:odbc-dbi + (:use #:cl #:odbc) + (:export + #:bind-parameter + #:close-query + #:connect + #:db-external-format + #:db-hstmt + #:db-width + #:disconnect + #:end-transaction + #:fetch-row + #:list-all-data-sources + #:list-all-database-tables + #:list-all-table-columns + #:list-table-indexes + #:loop-over-results + #:prepare-sql + #:rr-sql + #:run-prepared-sql + #:set-autocommit + #:sql + + #:*auto-trim-strings* + #:*default-database* + #:*default-odbc-external-format* + #:*null-value* + ) + (:documentation "This is the mid-level interface ODBC.")) + +(in-package #:odbc-dbi) + +(defgeneric terminate (src)) +(defgeneric db-open-query (src query-expression + &key arglen col-positions result-types width + &allow-other-keys)) +(defgeneric db-fetch-query-results (src &optional count)) +(defgeneric %db-execute (src sql-expression &key &allow-other-keys)) +(defgeneric db-execute-command (src sql-string)) + +(defgeneric %initialize-query (src arglen col-positions + &key result-types width)) + +(defgeneric %read-query-data (src ignore-columns)) +(defgeneric db-map-query (src type function query-exp &key result-types)) +(defgeneric db-prepare-statement (src sql &key parameter-table + parameter-columns)) +(defgeneric get-odbc-info (src info-type)) + +(defvar *reuse-query-objects* t) + + +;;; SQL Interface + +(defclass odbc-db () + (;; any reason to have more than one henv? + (width :initform +max-precision+ :accessor db-width) + (hstmt :initform nil :accessor db-hstmt) + (henv :initform nil :allocation :class :initarg :henv :accessor henv) + (hdbc :initform nil :initarg :hdbc :accessor hdbc) + ;; info returned from SQLGetInfo + (info :initform (make-hash-table) :reader db-info) + (type :initform nil :initarg :db-type :reader db-type) + (connected-p :initform nil :accessor db-connected-p) + ;; not used yet + (count :initform 0 :initarg :count :accessor db-count) + ;; not used yet + (total-count :initform 0 :allocation :class :accessor db-total-count) + ;; the use of this slot is deprecated; it will be removed when dtf works without it. + (query :initform nil :accessor db-query-object) + ;; resource of (active and inactive) query objects + (queries :initform () :accessor db-queries))) + +(defclass odbc-query () + ((hstmt :initform nil :initarg :hstmt :accessor hstmt) ; = cursor?? + (width :initform +max-precision+ :accessor query-width) + (computed-result-types :initform nil :initarg :computed-result-types :accessor computed-result-types) + (column-count :initform nil :accessor column-count) + (column-names :initform (make-array 0 :element-type 'string :adjustable t :fill-pointer t) + :accessor column-names) + (column-c-types :initform (make-array 0 :element-type 'fixnum :adjustable t :fill-pointer t) + :accessor column-c-types) + (column-sql-types :initform (make-array 0 :element-type 'fixnum :adjustable t :fill-pointer t) + :accessor column-sql-types) + (column-data-ptrs :initform (make-array 0 :adjustable t :fill-pointer t) + :accessor data-ptrs) + (column-out-len-ptrs :initform (make-array 0 :adjustable t :fill-pointer t) + :accessor column-out-len-ptrs) + (column-precisions :initform (make-array 0 :element-type 'integer :adjustable t :fill-pointer t) + :accessor column-precisions) + (column-scales :initform (make-array 0 :element-type 'fixnum :adjustable t :fill-pointer t) + :accessor column-scales) + (column-nullables-p :initform (make-array 0 :element-type 'fixnum :adjustable t :fill-pointer t) + :accessor column-nullables-p) + ;;(parameter-count :initform 0 :accessor parameter-count) + (parameter-data-ptrs :initform (make-array 0 :adjustable t :fill-pointer t) + :accessor parameter-ptrs) + ;; a query string or a query expression object + (sql-expression :initform nil :initarg :sql-expression :accessor sql-expression) + ;; database object the query is to be run against + (database :initarg :database :reader query-database) + (active-p :initform nil :initarg :active-p :accessor query-active-p)) + (:documentation + "Stores query information, like SQL query string/expression and database to run +the query against." )) + +;;; AODBC Compatible interface + +(defun connect (&key data-source-name user password connection-string completion window-handle (autocommit t)) + (let ((db (make-instance 'odbc-db))) + (unless (henv db) ;; has class allocation! + (setf (henv db) (%new-environment-handle))) + (setf (hdbc db) (%new-db-connection-handle (henv db))) + (if connection-string + (%sql-driver-connect (hdbc db) + connection-string + (ecase completion + (:no-prompt odbc::$SQL_DRIVER_NOPROMPT) + (:complete odbc::$SQL_DRIVER_COMPLETE) + (:prompt odbc::$SQL_DRIVER_PROMPT) + (:complete-required odbc::$SQL_DRIVER_COMPLETE_REQUIRED)) + window-handle) + (%sql-connect (hdbc db) data-source-name user password)) + #+ignore (setf (db-hstmt db) (%new-statement-handle (hdbc db))) + (when (/= (get-odbc-info db odbc::$SQL_TXN_CAPABLE) odbc::$SQL_TC_NONE) + (if autocommit + (enable-autocommit (hdbc db)) + (disable-autocommit (hdbc db)))) + db)) + +(defun disconnect (database) + "This is set in the generic-odbc-database disconnect-fn slot so xref fails + but this does get called on generic ODBC connections " + (with-slots (hdbc queries) database + (dolist (query queries) + (db-close-query query :drop-p T)) + (when (db-hstmt database) + (%free-statement (db-hstmt database) :drop)) + (%disconnect hdbc))) + + +(defun sql (expr &key db result-types row-count (column-names t) query + hstmt width) + (declare (ignore hstmt)) + (cond + (query + (let ((q (db-open-query db expr :result-types result-types :width width))) + (if column-names + (values q (column-names q)) + q))) + (t + (multiple-value-bind (data col-names) + (db-query db expr :result-types result-types :width width) + (cond + (row-count + (if (consp data) (length data) data)) + (column-names + (values data col-names)) + (t + data)))))) + +(defun fetch-row (query &optional (eof-errorp t) eof-value) + (multiple-value-bind (row query count) (db-fetch-query-results query 1) + (cond + ((zerop count) + (close-query query) + (when eof-errorp + (error 'clsql:sql-database-data-error + :message "ODBC: Ran out of data in fetch-row")) + eof-value) + (t + (car row))))) + + +(defun close-query (query) + (db-close-query query)) + +(defun list-all-database-tables (&key db hstmt) + (declare (ignore hstmt)) + (let ((query (get-free-query db))) + (unwind-protect + (progn + (with-slots (hstmt) query + (unless hstmt (setf hstmt (%new-statement-handle (hdbc db)))) + (%list-tables hstmt) + (%initialize-query query nil nil) + (values + (db-fetch-query-results query) + (coerce (column-names query) 'list)))) + (db-close-query query)))) + +(defun list-table-indexes (table &key db unique hstmt + &aux (table + (princ-to-string + (clsql-sys::unescaped-database-identifier table)))) + (declare (ignore hstmt)) + (let ((query (get-free-query db))) + (unwind-protect + (progn + (with-slots (hstmt) query + (unless hstmt + (setf hstmt (%new-statement-handle (hdbc db)))) + (%table-statistics table hstmt :unique unique) + (%initialize-query query nil nil) + (values + (db-fetch-query-results query) + (coerce (column-names query) 'list)))) + (db-close-query query)))) + +(defun list-all-table-columns (table &key db hstmt + &aux (table + (princ-to-string + (clsql-sys::unescaped-database-identifier table)))) + (declare (ignore hstmt)) + (db-describe-columns db nil nil table nil)) ;; use nil rather than "" for unspecified values + +(defun list-all-data-sources () + (let ((db (make-instance 'odbc-db))) + (unless (henv db) ;; has class allocation! + (setf (henv db) (%new-environment-handle))) + (%list-data-sources (henv db)))) + +(defun rr-sql (hstmt sql-statement &key db) + (declare (ignore hstmt sql-statement db)) + (warn "rr-sql not implemented.")) + +;;; Mid-level interface + +(defun db-commit (database) + (%commit (henv database) (hdbc database))) + +(defun db-rollback (database) + (%rollback (henv database) (hdbc database))) + +(defun db-cancel-query (query) + (with-slots (hstmt) query + (%sql-cancel hstmt) + (setf (query-active-p query) nil))) + +#+simple-version +(defmacro with-transaction (&body body) + `(%with-transaction + (:henv (henv ,*default-database*) :hdbc (hdbc ,*default-database*)) + ,@body)) + +(defmethod initialize-instance :after ((query odbc-query) + &key sql henv hdbc &allow-other-keys) + (when sql + (let ((hstmt (%new-statement-handle hdbc))) + (%sql-exec-direct sql hstmt henv hdbc) + (with-slots (column-count + column-names column-c-types column-sql-types column-data-ptrs + column-out-len-ptrs column-precisions column-scales + column-nullables-p active-p) query + (setf (hstmt query) hstmt) + (%initialize-query query nil nil) + (setf active-p t))))) + +;; one for odbc-db is missing +;; TODO: Seems to be uncalled +(defmethod terminate ((query odbc-query)) + ;;(format tb::*local-output* "~%*** terminated: ~s" query) + (db-close-query query)) + +(defun %dispose-column-ptrs (query) + "frees memory allocated for query object column-data and column-data-length" + (with-slots (column-data-ptrs column-out-len-ptrs hstmt) query + (loop for data-ptr across column-data-ptrs + for out-len-ptr across column-out-len-ptrs + when data-ptr + do (uffi:free-foreign-object data-ptr) + when out-len-ptr + do (uffi:free-foreign-object out-len-ptr)) + (setf (fill-pointer column-data-ptrs) 0 + (fill-pointer column-out-len-ptrs) 0))) + +(defmethod db-open-query ((database odbc-db) query-expression + &key arglen col-positions result-types width + &allow-other-keys) + (db-open-query (get-free-query database) query-expression + :arglen arglen :col-positions col-positions + :result-types result-types + :width (if width width (db-width database)))) + +(defmethod db-open-query ((query odbc-query) query-expression + &key arglen col-positions result-types width + &allow-other-keys) + (%db-execute query query-expression) + (%initialize-query query arglen col-positions :result-types result-types + :width width)) + +(defmethod db-fetch-query-results ((database odbc-db) &optional count) + (db-fetch-query-results (db-query-object database) count)) + +(defmethod db-fetch-query-results ((query odbc-query) &optional count) + (when (query-active-p query) + (with-slots (column-count column-data-ptrs column-c-types column-sql-types + column-out-len-ptrs column-precisions hstmt computed-result-types) + query + (let* ((rows-fetched 0) + (rows + (loop for i from 0 + until (or (and count (= i count)) + (= (%sql-fetch hstmt) odbc::$SQL_NO_DATA_FOUND)) + collect + (loop for result-type across computed-result-types + for data-ptr across column-data-ptrs + for c-type across column-c-types + for sql-type across column-sql-types + for out-len-ptr across column-out-len-ptrs + for precision across column-precisions + for j from 0 ; column count is zero based in lisp + collect + (progn + (incf rows-fetched) + (cond ((< 0 precision (query-width query)) + (read-data data-ptr c-type sql-type out-len-ptr result-type)) + ((zerop (get-cast-long out-len-ptr)) + nil) + (t + (read-data-in-chunks hstmt j data-ptr c-type sql-type + out-len-ptr result-type)))))))) + (values rows query rows-fetched))))) + +(defun db-query (database query-expression &key result-types width) + (let ((free-query (get-free-query database))) + (setf (sql-expression free-query) query-expression) + (unwind-protect + (progn + (%db-execute free-query query-expression) + (%initialize-query free-query nil nil :result-types result-types :width width) + (if (plusp (column-count free-query)) ;; KMR: Added check for commands that don't return columns + (values + (db-fetch-query-results free-query nil) + (map 'list #'identity (column-names free-query))) + (values + (result-rows-count (hstmt free-query)) + nil))) + (db-close-query free-query) + ))) + +(defmethod %db-execute ((database odbc-db) sql-expression &key &allow-other-keys) + (%db-execute (get-free-query database) sql-expression)) + +(defmethod %db-execute ((query odbc-query) sql-expression &key &allow-other-keys) + (with-slots (henv hdbc) (odbc::query-database query) + (with-slots (hstmt) query + (unless hstmt (setf hstmt (%new-statement-handle hdbc))) + (setf (sql-expression query) sql-expression) + (%sql-exec-direct sql-expression hstmt henv hdbc) + query))) + +;; reuse inactive queries +(defun get-free-query (database) + "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 (and *reuse-query-objects* + (clsql-sys:without-interrupts + (let ((inactive-query (find-if (lambda (query) + (not (query-active-p query))) + queries))) + (when inactive-query + (with-slots (column-count column-names column-c-types + width hstmt + column-sql-types column-data-ptrs + column-out-len-ptrs column-precisions + column-scales column-nullables-p) + inactive-query + (setf column-count 0 + width +max-precision+ + ;; KMR hstmt (%new-statement-handle hdbc) + (fill-pointer column-names) 0 + (fill-pointer column-c-types) 0 + (fill-pointer column-sql-types) 0 + (fill-pointer column-data-ptrs) 0 + (fill-pointer column-out-len-ptrs) 0 + (fill-pointer column-precisions) 0 + (fill-pointer column-scales) 0 + (fill-pointer column-nullables-p) 0)) + (setf (query-active-p inactive-query) t)) + inactive-query))) + (let ((new-query (make-instance 'odbc-query + :database database + ;;(clone-database database) + :active-p t))) + (push new-query queries) + new-query)))) + +(defmethod db-execute-command ((database odbc-db) sql-string) + (db-execute-command (get-free-query database) sql-string)) + +(defmethod db-execute-command ((query odbc-query) sql-string) + (with-slots (hstmt database) query + (with-slots (henv hdbc) database + (unless hstmt (setf hstmt (%new-statement-handle hdbc))) + (unwind-protect + (%sql-exec-direct sql-string hstmt henv hdbc) + (db-close-query query))))) + +(defmethod %initialize-query ((database odbc-db) arglen col-positions &key result-types width) + (%initialize-query (db-query-object database) arglen col-positions + :result-types result-types + :width (if width width (db-width database)))) + +(defmethod %initialize-query ((query odbc-query) arglen col-positions &key result-types width) + (with-slots (hstmt computed-result-types + column-count column-names column-c-types column-sql-types + column-data-ptrs column-out-len-ptrs column-precisions + column-scales column-nullables-p) + query + (setf column-count (if arglen + (min arglen (result-columns-count hstmt)) + (result-columns-count hstmt))) + (when width (setf (query-width query) width)) + ;;(format tb::*local-output* "~%column-count: ~d, col-positions: ~d" column-count col-positions) + (labels ((initialize-column (col-nr) + (multiple-value-bind (name sql-type precision scale nullable-p) + (%describe-column hstmt (1+ col-nr)) + ;; allocate space to bind result rows to + (multiple-value-bind (c-type data-ptr out-len-ptr size long-p) + (%allocate-bindings sql-type precision) + (if long-p ;; if long-p we fetch in chunks with %sql-get-data but must ensure that out_len_ptr is non zero + (setf (uffi:deref-pointer out-len-ptr #.odbc::$ODBC-LONG-TYPE) #.odbc::$SQL_NO_TOTAL) + (%bind-column hstmt col-nr c-type data-ptr (1+ size) out-len-ptr)) + (vector-push-extend name column-names) + (vector-push-extend sql-type column-sql-types) + (vector-push-extend (sql-to-c-type sql-type) column-c-types) + (vector-push-extend precision column-precisions) + (vector-push-extend scale column-scales) + (vector-push-extend nullable-p column-nullables-p) + (vector-push-extend data-ptr column-data-ptrs) + (vector-push-extend out-len-ptr column-out-len-ptrs))))) + (if col-positions + (dolist (col-nr col-positions) + (initialize-column col-nr)) + (dotimes (col-nr column-count) + ;; get column information + (initialize-column col-nr)))) + + ;; TODO: move this into the above loop + (setf computed-result-types (make-array column-count)) + (dotimes (i column-count) + (setf (aref computed-result-types i) + (cond + ((consp result-types) + (nth i result-types)) + ((eq result-types :auto) + (case (aref column-c-types i) + (#.odbc::$SQL_C_SLONG :int) + (#.odbc::$SQL_C_DOUBLE :double) + (#.odbc::$SQL_C_FLOAT :float) + (#.odbc::$SQL_C_SSHORT :short) + (#.odbc::$SQL_C_STINYINT :short) + (#.odbc::$SQL_C_SBIGINT #.odbc::$ODBC-BIG-TYPE) + (#.odbc::$SQL_C_TYPE_TIMESTAMP :time) + (#.odbc::$SQL_C_CHAR ;; TODO: Read this as rational instead of double + (or (case (aref column-sql-types i) + ((#.odbc::$SQL_NUMERIC #.odbc::$SQL_DECIMAL) :double)) + T)) + + (t t))) + (t t))))) + query) + +(defun db-close-query (query &key (drop-p (not *reuse-query-objects*))) + (with-slots (hstmt column-count column-names column-c-types column-sql-types + column-data-ptrs column-out-len-ptrs column-precisions + column-scales column-nullables-p database) query + (%dispose-column-ptrs query) + (cond ((null hstmt) nil) + (drop-p + (%free-statement hstmt :drop) + ;; dont free with uffi/ this is a double free and crashes everything + ;; (uffi:free-foreign-object hstmt) + (setf hstmt nil)) + (t + (%free-statement hstmt :unbind) + (%free-statement hstmt :reset) + (%free-statement hstmt :close))) + (setf (query-active-p query) nil) + (when drop-p + (clsql-sys:without-interrupts + (with-slots (queries) database + (setf queries (remove query queries)))))) + query) + +(defmethod %read-query-data ((database odbc-db) ignore-columns) + (%read-query-data (db-query-object database) ignore-columns)) + +(defmethod %read-query-data ((query odbc-query) ignore-columns) + (with-slots (hstmt column-count column-c-types column-sql-types + column-data-ptrs column-out-len-ptrs column-precisions + computed-result-types) + query + (unless (= (odbc::SQLFetch hstmt) odbc::$SQL_NO_DATA_FOUND) + (values + (loop for col-nr from 0 to (- column-count + (if (eq ignore-columns :last) 2 1)) + for result-type across computed-result-types + collect + (let ((precision (aref column-precisions col-nr)) + (sql-type (aref column-sql-types col-nr))) + (cond ((or (< 0 precision (query-width query)) + (and (zerop precision) (not (find sql-type '($SQL_C_CHAR))))) + (read-data (aref column-data-ptrs col-nr) + (aref column-c-types col-nr) + sql-type + (aref column-out-len-ptrs col-nr) + result-type)) + ((zerop (get-cast-long (aref column-out-len-ptrs col-nr))) + *null*) + (t + (read-data-in-chunks hstmt col-nr + (aref column-data-ptrs col-nr) + (aref column-c-types col-nr) + (aref column-sql-types col-nr) + (aref column-out-len-ptrs col-nr) + result-type))))) + t)))) + +(defmethod db-map-query ((database odbc-db) type function query-exp &key result-types) + (db-map-query (get-free-query database) type function query-exp :result-types result-types)) + +(defmethod db-map-query ((query odbc-query) type function query-exp &key result-types) + (declare (ignore type)) ; preliminary. Do a type coersion here + (%db-execute query (sql-expression query-exp)) + (unwind-protect + (progn + (%initialize-query query nil nil :result-types result-types) + ;; the main loop + (loop for data = (%read-query-data query nil) + while data + do (apply function data))) + ;; dispose of memory and set query inactive or get rid of it + (db-close-query query))) + +(defun db-map-bind-query (query type function + &rest parameters) + (declare (ignore type)) ; preliminary. Do a type coersion here + (unwind-protect + (progn + (apply #'%db-bind-execute query parameters) + ;; the main loop + (loop with data + while (setf data (%read-query-data query nil)) + do (apply function data))) + ;; dispose of memory and set query inactive or get rid of it + (%db-reset-query query))) + +;; does not always return exactly a lisp type... +(defun sql-to-lisp-type (sql-type) + (ecase sql-type + ((#.odbc::$SQL_CHAR #.odbc::$SQL_VARCHAR #.odbc::$SQL_LONGVARCHAR) :string) + ((#.odbc::$SQL_NUMERIC #.odbc::$SQL_DECIMAL) :string) ; ?? + (#.odbc::$SQL_BIGINT #.odbc::$ODBC-BIG-TYPE) + (#.odbc::$SQL_INTEGER #.odbc::$ODBC-LONG-TYPE) + (#.odbc::$SQL_SMALLINT :short) + ((#.odbc::$SQL_FLOAT #.odbc::$SQL_DOUBLE) #.odbc::$ODBC-LONG-TYPE) + (#.odbc::$SQL_REAL #.odbc::$ODBC-LONG-TYPE) + ((#.odbc::$SQL_DATE #.odbc::$SQL_TYPE_DATE) 'sql-c-date) + ((#.odbc::$SQL_TIME #.odbc::$SQL_TYPE_TIME) 'sql-c-time) + ((#.odbc::$SQL_TIMESTAMP #.odbc::$SQL_TYPE_TIMESTAMP) 'sql-c-timestamp) + ;;((#.odbc::$SQL_BINARY #.odbc::$SQL_VARBINARY #.odbc::$SQL_LONGVARBINARY) odbc::$SQL_C_BINARY) ; ?? + (#.odbc::$SQL_TINYINT :short) + ;;(#.odbc::$SQL_BIT odbc::$SQL_C_BIT) ; ?? + (#.odbc::$SQL_BIT :short) + ((#.odbc::$SQL_VARBINARY #.odbc::$SQL_LONGVARBINARY) :binary) + )) + +;; prepared queries + +(defmethod db-prepare-statement ((database odbc-db) sql + &key parameter-table parameter-columns) + (with-slots (hdbc) database + (let ((query (get-free-query database))) + (with-slots (hstmt) query + (unless hstmt (setf hstmt (%new-statement-handle hdbc)))) + (db-prepare-statement + query sql :parameter-table parameter-table :parameter-columns parameter-columns)))) + +(defmethod db-prepare-statement ((query odbc-query) (sql string) + &key parameter-table parameter-columns) + ;; this is a workaround to get hold of the column types when the driver does not + ;; support SQLDescribeParam. To do: put code in here for drivers that do + ;; support it. + (unless (string-equal sql "insert" :end1 6) + (error 'clsql:sql-database-error + (format nil + "Only insert expressions are supported in literal ODBC: '~a'." sql))) + (%db-execute query (format nil "select ~{~a~^,~} from ~a where 0 = 1" + (or parameter-columns '("*")) parameter-table)) + (%initialize-query query nil nil) + (with-slots (hstmt) query + (%free-statement hstmt :unbind) + (%free-statement hstmt :reset) + (setf (sql-expression query) sql) + (%sql-prepare hstmt sql)) + query) + + +(defun %db-bind-execute (query &rest parameters) + "Only used from db-map-bind-query + parameters are released in %reset-query + " + (with-slots (hstmt parameter-data-ptrs) query + (loop for parameter in parameters + with data-ptr and size and parameter-string + do + (setf parameter-string + (if (stringp parameter) + parameter + (write-to-string parameter)) + size (length parameter-string) + data-ptr + (uffi:allocate-foreign-string (1+ size))) + (vector-push-extend data-ptr parameter-data-ptrs) + (%sql-bind-parameter + hstmt (1- (fill-pointer parameter-data-ptrs)) odbc::$SQL_PARAM_INPUT + odbc::$SQL_C_CHAR ; (aref column-c-types parameter-count) + odbc::$SQL_CHAR ; sql-type + (query-width query) ;precision ; this should be the actual precision! + ;; scale + 0 ;; should be calculated for odbc::$SQL_DECIMAL, + ;;$SQL_NUMERIC and odbc::$SQL_TIMESTAMP + data-ptr ;; = rgbValue + 0 + ;; *pcbValue; + ;; change this for output and binary input! (see 3-32) + +null-ptr+) + (%put-str data-ptr parameter-string size)) + (%sql-execute hstmt))) + + +(defun %db-reset-query (query) + "Only used from db-map-bind-query + parameters are allocated in %db-bind-execute + " + (with-slots (hstmt parameter-data-ptrs) query + (prog1 + (db-fetch-query-results query nil) + (%free-statement hstmt :reset) ;; but _not_ :unbind ! + (%free-statement hstmt :close) + (dotimes (param-nr (fill-pointer parameter-data-ptrs)) + (let ((data-ptr (aref parameter-data-ptrs param-nr))) + (when data-ptr (uffi:free-foreign-object data-ptr)))) + (setf (fill-pointer parameter-data-ptrs) 0)))) + +(defun data-parameter-ptr (hstmt) + (uffi:with-foreign-object (param-ptr :pointer-void) + (let ((return-code (%sql-param-data hstmt param-ptr))) + ;;(format t "~%return-code from %sql-param-data: ~a~%" return-code) + (when (= return-code odbc::$SQL_NEED_DATA) + ;;(ffc::%pointer-to-address (%get-ptr param-ptr)) + (uffi:deref-pointer param-ptr :pointer-void))))) + +;; database inquiery functions + +(defun db-describe-columns (database table-qualifier table-owner + table-name column-name) + (with-slots (hdbc) database + (%describe-columns hdbc table-qualifier table-owner table-name column-name))) + +;; should translate info-type integers to keywords in order to make this +;; more readable? +(defmethod get-odbc-info ((database odbc-db) info-type) + (with-slots (hdbc info) database + (or (gethash info-type info) + (setf (gethash info-type info) + (%sql-get-info hdbc info-type))))) + +(defmethod get-odbc-info ((query odbc-query) info-type) + (get-odbc-info (odbc::query-database query) info-type)) + +;; driver inquiry +;; How does this differ from list-data-sources? +(defgeneric db-data-sources (db-type)) +(defmethod db-data-sources ((db-type (eql :odbc))) + "Returns a list of (data-source description) - pairs" + (let ((henv (%new-environment-handle))) + (unwind-protect + (loop with direction = :first + for data-source+description + = (multiple-value-list (%sql-data-sources henv :direction direction)) + while (car data-source+description) + collect data-source+description + do (setf direction :next)) + (%sql-free-environment henv)))) diff --git a/db-odbc/odbc-ff-interface.lisp b/db-odbc/odbc-ff-interface.lisp new file mode 100644 index 0000000..0fa0824 --- /dev/null +++ b/db-odbc/odbc-ff-interface.lisp @@ -0,0 +1,418 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Package: odbc -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: odbc-ff-interface.lisp +;;;; Purpose: Function definitions for UFFI interface to ODBC +;;;; Author: Kevin M. Rosenberg +;;;; +;;;; This file, part of CLSQL, is Copyright (c) 2004 by Kevin M. Rosenberg +;;;; and Copyright (C) Paul Meurer 1999 - 2001. All rights reserved. +;;;; +;;;; 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 #:odbc) + +(def-foreign-type sql-handle :pointer-void) +(def-foreign-type sql-handle-ptr (* sql-handle)) +(def-foreign-type string-ptr (* :unsigned-char)) +(def-type long-ptr-type (* #.$ODBC-LONG-TYPE)) + +;; ODBC3 +(def-function "SQLAllocHandle" + ((handle-type :short) + (input-handle sql-handle) + (*phenv sql-handle-ptr)) + :module "odbc" + :returning :short) + +;; ODBC3 version of SQLFreeStmt, SQLFreeConnect, and SSQLFreeStmt +(def-function "SQLFreeHandle" + ((handle-type :short) ; HandleType + (input-handle sql-handle)) ; Handle + :module "odbc" + :returning :short) ; RETCODE_SQL_API + + +;; deprecated +(def-function "SQLAllocEnv" + ((*phenv sql-handle-ptr) ; HENV FAR *phenv + ) + :module "odbc" + :returning :short) ; RETCODE_SQL_API + +;; deprecated +(def-function "SQLAllocConnect" + ((henv sql-handle) ; HENV henv + (*phdbc sql-handle-ptr) ; HDBC FAR *phdbc + ) + :module "odbc" + :returning :short) ; RETCODE_SQL_API + +(def-function "SQLConnect" + ((hdbc sql-handle) ; HDBC hdbc + (*szDSN :cstring) ; UCHAR FAR *szDSN + (cbDSN :short) ; SWORD cbDSN + (*szUID :cstring) ; UCHAR FAR *szUID + (cbUID :short) ; SWORD cbUID + (*szAuthStr :cstring) ; UCHAR FAR *szAuthStr + (cbAuthStr :short) ; SWORD cbAuthStr + ) + :module "odbc" + :returning :short) ; RETCODE_SQL_API + +(def-function "SQLDriverConnect" + ((hdbc sql-handle) ; HDBC hdbc + (hwnd sql-handle) ; SQLHWND hwnd + (*szConnStrIn :cstring) ; UCHAR FAR *szConnStrIn + (cbConnStrIn :short) ; SWORD cbConnStrIn + (*szConnStrOut string-ptr) ; UCHAR FAR *szConnStrOut + (cbConnStrOutMax :short) ; SWORD cbConnStrOutMax + (*pcbConnStrOut :pointer-void) ; SWORD FAR *pcbConnStrOut + (fDriverCompletion :short) ; UWORD fDriverCompletion + ) + :module "odbc" + :returning :short) ; RETCODE_SQL_API + +(def-function "SQLDisconnect" + ((hdbc sql-handle)) ; HDBC hdbc + :module "odbc" + :returning :short) ; RETCODE_SQL_API + + +;;deprecated +(def-function "SQLFreeConnect" + ((hdbc sql-handle)) ; HDBC hdbc + :module "odbc" + :returning :short) ; RETCODE_SQL_API + +;; deprecated +(def-function "SQLAllocStmt" + ((hdbc sql-handle) ; HDBC hdbc + (*phstmt sql-handle-ptr) ; HSTMT FAR *phstmt + ) + :module "odbc" + :returning :short) ; RETCODE_SQL_API + +(def-function "SQLGetInfo" + ((hdbc sql-handle) ; HDBC hdbc + (fInfoType :short) ; UWORD fInfoType + (rgbInfoValue :pointer-void) ; PTR rgbInfoValue + (cbInfoValueMax :short) ; SWORD cbInfoValueMax + (*pcbInfoValue :pointer-void) ; SWORD FAR *pcbInfoValue + ) + :module "odbc" + :returning :short) ; RETCODE_SQL_API + +(def-function "SQLPrepare" + ((hstmt sql-handle) ; HSTMT hstmt + (*szSqlStr :cstring) ; UCHAR FAR *szSqlStr + (cbSqlStr :int) ; SDWORD cbSqlStr + ) + :module "odbc" + :returning :short) ; RETCODE_SQL_API + +(def-function "SQLExecute" + ((hstmt sql-handle) ; HSTMT hstmt + ) + :module "odbc" + :returning :short) ; RETCODE_SQL_API + +(def-function "SQLExecDirect" + ((hstmt sql-handle) ; HSTMT hstmt + (*szSqlStr :cstring) ; UCHAR FAR *szSqlStr + (cbSqlStr :int) ; SDWORD cbSqlStr + ) + :module "odbc" + :returning :short) ; RETCODE_SQL_API + +(def-function "SQLFreeStmt" + ((hstmt sql-handle) ; HSTMT hstmt + (fOption :short)) ; UWORD fOption + :module "odbc" + :returning :short) ; RETCODE_SQL_API + + (def-function "SQLCancel" + ((hstmt sql-handle) ; HSTMT hstmt + ) + :module "odbc" + :returning :short) ; RETCODE_SQL_API + +(def-function "SQLError" + ((henv sql-handle) ; HENV henv + (hdbc sql-handle) ; HDBC hdbc + (hstmt sql-handle) ; HSTMT hstmt + (*szSqlState string-ptr) ; UCHAR FAR *szSqlState + (*pfNativeError (* :int)) ; SDWORD FAR *pfNativeError + (*szErrorMsg string-ptr) ; UCHAR FAR *szErrorMsg + (cbErrorMsgMax :short) ; SWORD cbErrorMsgMax + (*pcbErrorMsg (* :short)) ; SWORD FAR *pcbErrorMsg + ) + :module "odbc" + :returning :short) ; RETCODE_SQL_API + +(def-function "SQLNumResultCols" + ((hstmt sql-handle) ; HSTMT hstmt + (*pccol (* :short)) ; SWORD FAR *pccol + ) + :module "odbc" + :returning :short) ; RETCODE_SQL_API + +(def-function "SQLRowCount" + ((hstmt sql-handle) ; HSTMT hstmt + (*pcrow (* :int)) ; SDWORD FAR *pcrow + ) + :module "odbc" + :returning :short) ; RETCODE_SQL_API + +(def-function "SQLDescribeCol" + ((hstmt sql-handle) ; HSTMT hstmt + (icol :short) ; UWORD icol + (*szColName string-ptr) ; UCHAR FAR *szColName + (cbColNameMax :short) ; SWORD cbColNameMax + (*pcbColName (* :short)) ; SWORD FAR *pcbColName + (*pfSqlType (* :short)) ; SWORD FAR *pfSqlType + (*pcbColDef (* #.$ODBC-ULONG-TYPE)) ; UDWORD FAR *pcbColDef + (*pibScale (* :short)) ; SWORD FAR *pibScale + (*pfNullable (* :short)) ; SWORD FAR *pfNullable + ) + :module "odbc" + :returning :short) ; RETCODE_SQL_API + +(def-function "SQLColAttributes" + ((hstmt sql-handle) ; HSTMT hstmt + (icol :short) ; UWORD icol + (fDescType :short) ; UWORD fDescType + (rgbDesc string-ptr) ; PTR rgbDesc + (cbDescMax :short) ; SWORD cbDescMax + (*pcbDesc (* :short)) ; SWORD FAR *pcbDesc + (*pfDesc (* :int)) ; SDWORD FAR *pfDesc + ) + :module "odbc" + :returning :short) ; RETCODE_SQL_API + +(def-function "SQLColumns" + ((hstmt sql-handle) ; HSTMT hstmt + (*szTableQualifier :cstring) ; UCHAR FAR *szTableQualifier + (cbTableQualifier :short) ; SWORD cbTableQualifier + (*szTableOwner :cstring) ; UCHAR FAR *szTableOwner + (cbTableOwner :short) ; SWORD cbTableOwner + (*szTableName :cstring) ; UCHAR FAR *szTableName + (cbTableName :short) ; SWORD cbTableName + (*szColumnName :cstring) ; UCHAR FAR *szColumnName + (cbColumnName :short) ; SWORD cbColumnName + ) + :module "odbc" + :returning :short) ; RETCODE_SQL_API + +(def-function "SQLBindCol" + ((hstmt sql-handle) ; HSTMT hstmt + (icol :short) ; UWORD icol + (fCType :short) ; SWORD fCType + (rgbValue :pointer-void) ; PTR rgbValue + (cbValueMax :int) ; SDWORD cbValueMax + (*pcbValue (* :int)) ; SDWORD FAR *pcbValue + ) + :module "odbc" + :returning :short) ; RETCODE_SQL_API + +(def-function "SQLFetch" + ((hstmt sql-handle) ; HSTMT hstmt + ) + :module "odbc" + :returning :short) ; RETCODE_SQL_API + +(def-function "SQLTransact" + ((henv sql-handle) ; HENV henv + (hdbc sql-handle) ; HDBC hdbc + (fType :short) ; UWORD fType ($SQL_COMMIT or $SQL_ROLLBACK) + ) + :module "odbc" + :returning :short) ; RETCODE_SQL_API + +;; ODBC 2.0 +(def-function "SQLDescribeParam" + ((hstmt sql-handle) ; HSTMT hstmt + (ipar :short) ; UWORD ipar + (*pfSqlType (* :short)) ; SWORD FAR *pfSqlType + (*pcbColDef (* :unsigned-int)) ; UDWORD FAR *pcbColDef + (*pibScale (* :short)) ; SWORD FAR *pibScale + (*pfNullable (* :short)) ; SWORD FAR *pfNullable + ) + :module "odbc" + :returning :short) ; RETCODE_SQL_API + +;; ODBC 2.0 +(def-function "SQLBindParameter" + ((hstmt sql-handle) ; HSTMT hstmt + (ipar :short) ; UWORD ipar + (fParamType :short) ; SWORD fParamType + (fCType :short) ; SWORD fCType + (fSqlType :short) ; SWORD fSqlType + (cbColDef :int) ; UDWORD cbColDef + (ibScale :short) ; SWORD ibScale + (rgbValue :pointer-void) ; PTR rgbValue + (cbValueMax :int) ; SDWORD cbValueMax + (*pcbValue :pointer-void) ; SDWORD FAR *pcbValue + ) + :module "odbc" + :returning :short) ; RETCODE_SQL_API + +;; level 1 +(def-function "SQLGetData" + ((hstmt sql-handle) ; HSTMT hstmt + (icol :short) ; UWORD icol + (fCType :short) ; SWORD fCType + (rgbValue :pointer-void) ; PTR rgbValue + (cbValueMax :int) ; SDWORD cbValueMax + (*pcbValue :pointer-void) ; SDWORD FAR *pcbValue + ) + :module "odbc" + :returning :short) ; RETCODE_SQL_API + +(def-function "SQLParamData" + ((hstmt sql-handle) ; HSTMT hstmt + (*prgbValue :pointer-void) ; PTR FAR *prgbValue + ) + :module "odbc" + :returning :short) ; RETCODE_SQL_API + +(def-function "SQLPutData" + ((hstmt sql-handle) ; HSTMT hstmt + (rgbValue :pointer-void) ; PTR rgbValue + (cbValue :int) ; SDWORD cbValue + ) + :module "odbc" + :returning :short) ; RETCODE_SQL_API + +(def-function "SQLGetConnectOption" + ((hdbc sql-handle) ; HDBC hdbc + (fOption :short) ; UWORD fOption + (pvParam :pointer-void) ; PTR pvParam + ) + :module "odbc" + :returning :short) ; RETCODE_SQL_API + +(def-function "SQLSetConnectOption" + ((hdbc sql-handle) ; HDBC hdbc + (fOption :short) ; UWORD fOption + (vParam :int) ; UDWORD vParam + ) + :module "odbc" + :returning :short) ; RETCODE_SQL_API + +(def-function "SQLSetPos" + ((hstmt sql-handle) ; HSTMT hstmt + (irow :short) ; UWORD irow + (fOption :short) ; UWORD fOption + (fLock :short) ; UWORD fLock + ) + :module "odbc" + :returning :short) ; RETCODE_SQL_API + + ; level 2 +(def-function "SQLExtendedFetch" + ((hstmt sql-handle) ; HSTMT hstmt + (fFetchType :short) ; UWORD fFetchType + (irow :int) ; SDWORD irow + (*pcrow :pointer-void) ; UDWORD FAR *pcrow + (*rgfRowStatus :pointer-void) ; UWORD FAR *rgfRowStatus + ) + :module "odbc" + :returning :short) ; RETCODE_SQL_API + +(def-function "SQLDataSources" + ((henv sql-handle) ; HENV henv + (fDirection :short) + (*szDSN string-ptr) ; UCHAR FAR *szDSN + (cbDSNMax :short) ; SWORD cbDSNMax + (*pcbDSN (* :short)) ; SWORD *pcbDSN + (*szDescription string-ptr) ; UCHAR *szDescription + (cbDescriptionMax :short) ; SWORD cbDescriptionMax + (*pcbDescription (* :short)) ; SWORD *pcbDescription + ) + :module "odbc" + :returning :short) ; RETCODE_SQL_API + +(def-function "SQLFreeEnv" + ((henv sql-handle) ; HSTMT hstmt + ) + :module "odbc" + :returning :short) ; RETCODE_SQL_API + + +;;; foreign type definitions + +;;(defmacro %sql-len-data-at-exec (length) +;; `(- $SQL_LEN_DATA_AT_EXEC_OFFSET ,length)) + + +(def-struct sql-c-time + (hour :short) + (minute :short) + (second :short)) + +(def-struct sql-c-date + (year :short) + (month :short) + (day :short)) + +(def-struct sql-c-timestamp + (year :short) + (month :short) + (day :short) + (hour :short) + (minute :short) + (second :short) + (fraction :int)) + +;;; Added by KMR + +(def-function "SQLSetEnvAttr" + ((henv sql-handle) ; HENV henv + (attr :int) + (*value :pointer-void) + (szLength :int)) + :module "odbc" + :returning :short) + +(def-function "SQLGetEnvAttr" + ((henv sql-handle) ; HENV henv + (attr :int) + (*value :pointer-void) + (szLength :int) + (string-length-ptr (* :int))) + :module "odbc" + :returning :short) + +(def-function "SQLTables" + ((hstmt :pointer-void) + (catalog-name :pointer-void) + (catalog-name-length :short) + (schema-name :pointer-void) + (schema-name-length :short) + (table-name :pointer-void) + (table-name-length :short) + (table-type-name :pointer-void) + (table-type-name-length :short)) + :module "odbc" + :returning :short) + + +(def-function "SQLStatistics" + ((hstmt :pointer-void) + (catalog-name :pointer-void) + (catalog-name-length :short) + (schema-name :pointer-void) + (schema-name-length :short) + (table-name :cstring) + (table-name-length :short) + (unique :short) + (reserved :short)) + :module "odbc" + :returning :short) + + diff --git a/db-odbc/odbc-loader.lisp b/db-odbc/odbc-loader.lisp new file mode 100644 index 0000000..16f1ec1 --- /dev/null +++ b/db-odbc/odbc-loader.lisp @@ -0,0 +1,41 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: odbc-loader.sql +;;;; Purpose: ODBC library loader using UFFI +;;;; Programmers: Kevin M. Rosenberg +;;;; Date Started: April 2004 +;;;; +;;;; This file, part of CLSQL, is Copyright (c) 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 #:odbc) + +(defparameter *odbc-library-filenames* + '("odbc32" "libodbc" "libiodbc")) + +(defvar *odbc-supporting-libraries* '("c") + "Used only by CMU. List of library flags needed to be passed to ld to +load the Odbc client library succesfully. If this differs at your site, +set to the right path before compiling or loading the system.") + +(defvar *odbc-library-loaded* nil + "T if foreign library was able to be loaded successfully") + +(defmethod clsql-sys:database-type-library-loaded ((database-type (eql :odbc))) + *odbc-library-loaded*) + +(defmethod clsql-sys:database-type-load-foreign ((database-type (eql :odbc))) + (clsql-uffi:find-and-load-foreign-library *odbc-library-filenames* + :module "odbc") + (setq *odbc-library-loaded* t)) + +(clsql-sys:database-type-load-foreign :odbc) + + + diff --git a/db-odbc/odbc-package.lisp b/db-odbc/odbc-package.lisp new file mode 100644 index 0000000..40214eb --- /dev/null +++ b/db-odbc/odbc-package.lisp @@ -0,0 +1,69 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: odbc-package.lisp +;;;; Purpose: Package definition for low-level ODBC interface +;;;; Author: Kevin M. Rosenberg +;;;; Created: April 2004 +;;;; +;;;; This file, part of CLSQL, is Copyright (c) 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 #:odbc + (:use #:cl #:uffi) + (:export + #:database-library-loaded + + #:*null* + #:+null-ptr+ + #:+max-precision+ + #:*info-output* + #:*time-format* + #:get-cast-long + #:%free-statement + #:%disconnect + #:%commit + #:%rollback + #:%sql-fetch + #:%sql-cancel + #:db-connect + #:%new-db-connection-handle + #:%new-environment-handle + #:%sql-connect + #:%sql-driver-connect + #:disable-autocommit + #:enable-autocommit + #:%sql-free-environment + #:%sql-data-sources + #:%sql-get-info + #:%sql-param-data + #:%sql-execute + #:%put-str + #:%sql-bind-parameter + #:%sql-prepare + #:sqlfetch + #:%bind-column + #:%allocate-bindings + #:%describe-column + #:%describe-columns + #:read-data + #:read-data-in-chunks + #:query-database + #:%new-statement-handle + #:%sql-exec-direct + #:result-columns-count + #:result-rows-count + #:sql-to-c-type + #:%list-tables + #:%table-statistics + #:%list-data-sources + ) + (:documentation "This is the low-level interface ODBC.")) + diff --git a/db-odbc/odbc-sql.lisp b/db-odbc/odbc-sql.lisp new file mode 100644 index 0000000..b36833e --- /dev/null +++ b/db-odbc/odbc-sql.lisp @@ -0,0 +1,163 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: odbc-sql.cl +;;;; Purpose: Medium-level interface for CLSQL ODBC backend +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Feb 2002 +;;;; +;;;; 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-odbc + (:use #:common-lisp #:clsql-sys) + (:export #:odbc-database) + (:documentation "This is the CLSQL interface to ODBC.")) + +(in-package #:clsql-odbc) + +;; ODBC interface + +(defclass odbc-database (generic-odbc-database) + ()) + +(defclass odbc-postgresql-database (generic-odbc-database + generic-postgresql-database) + ()) + +(defmethod database-name-from-spec (connection-spec + (database-type (eql :odbc))) + (check-connection-spec connection-spec database-type + (dsn user password &key connection-string completion window-handle)) + (destructuring-bind (dsn user password &key connection-string completion window-handle) connection-spec + (declare (ignore password connection-string completion window-handle)) + (concatenate 'string dsn "/" user))) + +(defmethod database-connect (connection-spec (database-type (eql :odbc))) + (check-connection-spec connection-spec database-type + (dsn user password &key connection-string completion window-handle)) + (destructuring-bind (dsn user password &key connection-string (completion :no-prompt) window-handle) connection-spec + (handler-case + (let ((db (make-instance 'odbc-database + :name (database-name-from-spec connection-spec :odbc) + :database-type :odbc + :connection-spec connection-spec + :dbi-package (find-package '#:odbc-dbi) + :odbc-conn + (odbc-dbi:connect :user user + :password password + :data-source-name dsn + :connection-string connection-string + :completion completion + :window-handle window-handle)))) + (store-type-of-connected-database db) + ;; Ensure this database type is initialized so can check capabilities of + ;; underlying database + (initialize-database-type :database-type database-type) + (if (eql :postgresql (database-underlying-type db)) + (make-instance 'odbc-postgresql-database + :name (database-name-from-spec connection-spec :odbc) + :database-type :odbc + :connection-spec connection-spec + :dbi-package (find-package '#:odbc-dbi) + :odbc-db-type :postgresql + :odbc-conn (clsql-sys::odbc-conn db)) + db)) + #+ignore + (error () ;; Init or Connect failed + (error 'sql-connection-error + :database-type database-type + :connection-spec connection-spec + :message "Connection failed"))))) + +(defmethod database-underlying-type ((database generic-odbc-database)) + (clsql-sys::database-odbc-db-type database)) + +(defun store-type-of-connected-database (db) + (let* ((odbc-conn (clsql-sys::odbc-conn db)) + (server-name (odbc-dbi::get-odbc-info odbc-conn odbc::$SQL_SERVER_NAME)) + (dbms-name (odbc-dbi::get-odbc-info odbc-conn odbc::$SQL_DBMS_NAME)) + (type + ;; need SERVER-NAME and DBMS-NAME because many drivers mix this up + (cond + ((or (search "postgresql" server-name :test #'char-equal) + (search "postgresql" dbms-name :test #'char-equal)) + (unless (find-package 'clsql-postgresql) + (ignore-errors (asdf:operate 'asdf:load-op 'clsql-postgresql-socket))) + :postgresql) + ((or (search "Microsoft SQL Server" server-name :test #'char-equal) + (search "Microsoft SQL Server" dbms-name :test #'char-equal)) + :mssql) + ((or (search "mysql" server-name :test #'char-equal) + (search "mysql" dbms-name :test #'char-equal)) + (unless (find-package 'clsql-mysql) + ;; ignore errors on platforms where the shared libraries are not available + (ignore-errors (asdf:operate 'asdf:load-op 'clsql-mysql))) + :mysql) + ((or (search "oracle" server-name :test #'char-equal) + (search "oracle" dbms-name :test #'char-equal)) + :oracle)))) + (setf (clsql-sys::database-odbc-db-type db) type))) + + + +(defmethod database-create (connection-spec (type (eql :odbc))) + (declare (ignore connection-spec)) + (warn "Not implemented.")) + +(defmethod database-destroy (connection-spec (type (eql :odbc))) + (declare (ignore connection-spec)) + (warn "Not implemented.")) + +(defmethod database-probe (connection-spec (type (eql :odbc))) + (when (find (car connection-spec) (database-list connection-spec type) + :test #'string-equal) + t)) + +(defmethod database-list (connection-spec (type (eql :odbc))) + (declare (ignore connection-spec)) + (odbc-dbi:list-all-data-sources)) + +(defmethod database-list-indexes ((database odbc-database) + &key (owner nil)) + (let ((result '())) + (dolist (table (database-list-tables database :owner owner) result) + (setq result + (append (database-list-table-indexes table database :owner owner) + result))))) + +(defmethod database-list-table-indexes (table (database odbc-database) + &key (owner nil)) + (declare (ignore owner)) + (multiple-value-bind (rows col-names) + (odbc-dbi:list-table-indexes + table + :db (clsql-sys::odbc-conn database)) + (declare (ignore col-names)) + ;; INDEX_NAME is hard-coded in sixth position by ODBC driver + ;; FIXME: ??? is hard-coded in the fourth position + (do ((results nil) + (loop-rows rows (cdr loop-rows))) + ((null loop-rows) (nreverse results)) + (let* ((row (car loop-rows)) + (col (nth 5 row))) + (unless (or (null col) (find col results :test #'string-equal)) + (push col results)))))) + +;;; Database capabilities + +(defmethod db-backend-has-create/destroy-db? ((db-type (eql :odbc))) + nil) + + +(defmethod database-initialize-database-type ((database-type (eql :odbc))) + ;; nothing to do + t) + +(when (clsql-sys:database-type-library-loaded :odbc) + (clsql-sys:initialize-database-type :database-type :odbc)) diff --git a/db-oracle/Makefile b/db-oracle/Makefile new file mode 100644 index 0000000..f2d791e --- /dev/null +++ b/db-oracle/Makefile @@ -0,0 +1,23 @@ +#!/usr/bin/make +########################################################################## +# FILE IDENTIFICATION +# +# Name: Makefile +# Purpose: Makefile for CLSQL Oracle interface +# Author: Kevin M. Rosenberg +# Created: May 2004 +# +# This file, part of CLSQL, is Copyright (c) 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. +########################################################################## + + +SUBDIRS= + +include ../Makefile.common + +.PHONY: distclean +distclean: clean diff --git a/db-oracle/README b/db-oracle/README new file mode 100644 index 0000000..76b8095 --- /dev/null +++ b/db-oracle/README @@ -0,0 +1,21 @@ +This is the header of the cadabra source file. + +;;;; The original version of this code was copyright (c) 1999-2000 Cadabra Inc. +;;;; It was placed in the public domain by Cadabra in January 2000. +;;;; +;;;; The implementors of the original version were Winton Davies +;;;; <wdavies@cadabra.com> and William Newman <william.newman@airmail.net>. + +;;;; known issues: +;;;; * The code will leak C resources if errors occur in the the wrong +;;;; places, since it doesn't wrap its allocation/deallocation +;;;; logic in the necessary EVAL-WHENs to prevent this. (This could be +;;;; easily be an issue for long-running processes which recover from +;;;; database errors instead of simply terminating when they occur. It's +;;;; not an issue for programs which consider database errors so abnormal +;;;; that they die immediately when they encounter one.) +;;;; * Instead of reading Oracle header files automatically, this code +;;;; uses constants, types, and function signatures manually transcribed +;;;; from the Oracle header files. Thus, changes in the header files +;;;; may require manual maintenance of the code. (This version was written +;;;; for Oracle 8.1.5.) diff --git a/db-oracle/foreign-resources.lisp b/db-oracle/foreign-resources.lisp new file mode 100644 index 0000000..3344cb4 --- /dev/null +++ b/db-oracle/foreign-resources.lisp @@ -0,0 +1,57 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; 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-oracle) + +(defparameter *foreign-resource-hash* (make-hash-table :test #'equal)) + +(defstruct (foreign-resource) + (type (error "Missing TYPE.") + :read-only t) + (sizeof (error "Missing SIZEOF.") + :read-only t) + (buffer (error "Missing BUFFER.") + :read-only t) + (in-use nil :type boolean)) + + +(defun %get-resource (type sizeof) + (let ((resources (gethash type *foreign-resource-hash*))) + (car (member-if + #'(lambda (res) + (and (= (foreign-resource-sizeof res) sizeof) + (not (foreign-resource-in-use res)))) + resources)))) + +(defun %insert-foreign-resource (type res) + (let ((resource (gethash type *foreign-resource-hash*))) + (setf (gethash type *foreign-resource-hash*) + (cons res resource)))) + +(defmacro acquire-foreign-resource (type &optional size) + `(let ((res (%get-resource ,type ,size))) + (unless res + (setf res (make-foreign-resource + :type ,type :sizeof ,size + :buffer (uffi:allocate-foreign-object ,type ,size))) + (%insert-foreign-resource ',type res)) + (claim-foreign-resource res))) + +(defun free-foreign-resource (ares) + (setf (foreign-resource-in-use ares) nil) + ares) + +(defun claim-foreign-resource (ares) + (setf (foreign-resource-in-use ares) t) + ares) + + + diff --git a/db-oracle/oracle-api.lisp b/db-oracle/oracle-api.lisp new file mode 100644 index 0000000..1ebb0d9 --- /dev/null +++ b/db-oracle/oracle-api.lisp @@ -0,0 +1,356 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: oracle.lisp +;;;; Purpose: Package definition for CLSQL Oracle interface +;;;; +;;;; 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-oracle) + +;; +;; OCI integer types +;; + +(uffi:def-foreign-type ub2 :unsigned-short) +(uffi:def-foreign-type sb2 :short) +(uffi:def-foreign-type ub4 :unsigned-int) +(uffi:def-foreign-type sb4 :int) +(uffi:def-foreign-type size_t :unsigned-long) + +;; +;; Opaque pointer types +;; + +(uffi:def-foreign-type void-pointer :pointer-void) +(uffi:def-foreign-type oci-env :pointer-void) +(uffi:def-foreign-type oci-server :pointer-void) +(uffi:def-foreign-type oci-error :pointer-void) +(uffi:def-foreign-type oci-svc-ctx :pointer-void) +(uffi:def-foreign-type oci-stmt :pointer-void) + +(uffi:def-pointer-var +null-void-pointer+ + (uffi:make-null-pointer :void)) +(uffi:def-pointer-var +null-void-pointer-pointer+ + (uffi:make-null-pointer :pointer-void)) + +;;; Check an OCI return code for erroricity and signal a reasonably +;;; informative condition if so. +;;; +;;; ERRHP provides an error handle which can be used to find +;;; subconditions; if it's not provided, subcodes won't be checked. +;;; +;;; NULLS-OK says that a NULL-VALUE-RETURNED subcondition condition is +;;; normal and needn't cause any signal. An error handle is required +;;; to detect this subcondition, so it doesn't make sense to set ERRHP +;;; unless NULLS-OK is set. + +(defmacro def-oci-routine ((c-oci-symbol lisp-oci-fn) c-return &rest c-parms) + (let ((ll (mapcar (lambda (x) (declare (ignore x)) (gensym)) c-parms)) + (c-oci-fn (intern (concatenate 'string "%" (symbol-name lisp-oci-fn))))) + `(progn + (declaim (inline ,c-oci-fn ,lisp-oci-fn)) + (uffi:def-function (,c-oci-symbol ,c-oci-fn) + ,c-parms + :returning ,c-return) + (defun ,lisp-oci-fn (,@ll &key database nulls-ok) + (let ((result (,c-oci-fn ,@ll))) + (if (= result #.+oci-success+) + +oci-success+ + (handle-oci-result result database nulls-ok))))))) + + +(defmacro def-raw-oci-routine + ((c-oci-symbol lisp-oci-fn) c-return &rest c-parms) + (let ((ll (mapcar (lambda (x) (declare (ignore x)) (gensym)) c-parms))) + `(let ((%lisp-oci-fn (uffi:def-function (,c-oci-symbol ,(intern (concatenate 'string "%" (symbol-name lisp-oci-fn)))) + ,c-parms + :returning ,c-return))) + (defun ,lisp-oci-fn (,@ll &key database nulls-ok) + (declare (ignore database nulls-ok)) + (funcall %lisp-oci-fn ,@ll))))) + + +(def-oci-routine ("OCIInitialize" oci-initialize) + :int + (mode ub4) ; ub4 + (ctxp :pointer-void) ; dvoid * + (malocfp :pointer-void) ; dvoid *(*) + (ralocfp :pointer-void) ; dvoid *(*) + (mfreefp (* :pointer-void))) ; void *(*) + + +(def-oci-routine ("OCIEnvInit" oci-env-init) + :int + (envpp :pointer-void) ; OCIEnv ** + (mode ub4) ; ub4 + (xtramem-sz size_t) ; size_t + (usermempp (* :pointer-void))) ; dvoid ** + +#-oci7 +(def-oci-routine ("OCIEnvCreate" oci-env-create) + :int + (envhpp (* :pointer-void)) + (mode ub4) + (ctxp :pointer-void) + (malocfp :pointer-void) + (ralocfp :pointer-void) + (mfreefp :pointer-void) + (xtramemsz size_t) + (usrmempp (* :pointer-void))) + +(def-oci-routine ("OCIHandleAlloc" oci-handle-alloc) + :int + (parenth :pointer-void) ; const dvoid * + (hndlpp (* :pointer-void)) ; dvoid ** + (type ub4) ; ub4 + (xtramem_sz size_t) ; size_t + (usrmempp (* :pointer-void))) ; dvoid ** + +(def-oci-routine ("OCIServerAttach" oci-server-attach) + :int + (srvhp :pointer-void) ; oci-server + (errhp :pointer-void) ; oci-error + (dblink :cstring) ; :in + (dblink-len sb4) ; sb4 + (mode ub4)) ; ub4 + + +(def-oci-routine ("OCIHandleFree" oci-handle-free) + :int + (p0 :pointer-void) ;; handle + (p1 ub4)) ;;type + +(def-oci-routine ("OCILogon" oci-logon) + :int + (envhp :pointer-void) ; env + (errhp :pointer-void) ; err + (svchpp (* :pointer-void)) ; svc + (username (* :unsigned-char)) ; username + (uname-len ub4) ; + (passwd (* :unsigned-char)) ; passwd + (password-len ub4) ; + (dsn (* :unsigned-char)) ; datasource + (dsn-len ub4)) ; + +(def-oci-routine ("OCILogoff" oci-logoff) + :int + (p0 :pointer-void) ; svc + (p1 :pointer-void)) ; err + +(declaim (inline oci-error-get)) +(uffi:def-function ("OCIErrorGet" oci-error-get) + ((handlp :pointer-void) + (recordno ub4) + (sqlstate :cstring) + (errcodep (* sb4)) + (bufp (* :unsigned-char)) + (bufsize ub4) + (type ub4)) + :returning :void) + +(def-oci-routine ("OCIStmtPrepare" oci-stmt-prepare) + :int + (stmtp :pointer-void) + (errhp :pointer-void) + (stmt (* :unsigned-char)) + (stmt_len ub4) + (language ub4) + (mode ub4)) + +(def-oci-routine ("OCIStmtExecute" oci-stmt-execute) + :int + (svchp :pointer-void) + (stmtp1 :pointer-void) + (errhp :pointer-void) + (iters ub4) + (rowoff ub4) + (snap_in :pointer-void) + (snap_out :pointer-void) + (mode ub4)) + +(def-raw-oci-routine ("OCIParamGet" oci-param-get) + :int + (hndlp :pointer-void) + (htype ub4) + (errhp :pointer-void) + (parmdpp (* :pointer-void)) + (pos ub4)) + +(def-oci-routine ("OCIAttrGet" oci-attr-get) + :int + (trgthndlp :pointer-void) + (trghndltyp ub4) + (attributep :pointer-void) + (sizep (* ub4)) + (attrtype ub4) + (errhp :pointer-void)) + +(def-oci-routine ("OCIAttrSet" oci-attr-set) + :int + (trgthndlp :pointer-void) + (trgthndltyp ub4 :in) + (attributep :pointer-void) + (size ub4) + (attrtype ub4) + (errhp oci-error)) + +(def-oci-routine ("OCIDefineByPos" oci-define-by-pos) + :int + (stmtp :pointer-void) + (defnpp (* :pointer-void)) + (errhp :pointer-void) + (position ub4) + (valuep :pointer-void) + (value_sz sb4) + (dty ub2) + (indp (* sb2)) + (rlenp (* ub2)) + (rcodep (* ub2)) + (mode ub4)) + +(def-oci-routine ("OCIStmtFetch" oci-stmt-fetch) + :int + (stmthp :pointer-void) + (errhp :pointer-void) + (p2 ub4) + (p3 ub2) + (p4 ub4)) + + +(def-oci-routine ("OCITransStart" oci-trans-start) + :int + (svchp :pointer-void) + (errhp :pointer-void) + (p2 :unsigned-short) + (p3 :unsigned-short)) + +(def-oci-routine ("OCITransCommit" oci-trans-commit) + :int + (svchp :pointer-void) + (errhp :pointer-void) + (p2 :unsigned-short)) + +(def-oci-routine ("OCITransRollback" oci-trans-rollback) + :int + (svchp :pointer-void) + (errhp :pointer-void) + (p2 :unsigned-short)) + + +(def-oci-routine ("OCIServerVersion" oci-server-version) + :int + (handlp :pointer-void) + (errhp :pointer-void) + (bufp (* :unsigned-char)) + (bufsz :int) + (hndltype :short)) + + + +;;; Low-level routines that don't do error checking. They are used +;;; for setting up global environment. + +(uffi:def-function "OCIInitialize" + ((mode ub4) ; ub4 + (ctxp :pointer-void) ; dvoid * + (malocfp :pointer-void) ; dvoid *(*) + (ralocfp :pointer-void) ; dvoid *(*) + (mfreefp (* :pointer-void))) + :returning :int) + +(uffi:def-function "OCIEnvInit" + ((envpp :pointer-void) ; OCIEnv ** + (mode ub4) ; ub4 + (xtramem-sz size_t) ; size_t + (usermempp (* :pointer-void))) + :returning :int) + + +(uffi:def-function "OCIHandleAlloc" + ((parenth :pointer-void) ; const dvoid * + (hndlpp (* :pointer-void)) ; dvoid ** + (type ub4) ; ub4 + (xtramem_sz size_t) ; size_t + (usrmempp (* :pointer-void))) + :returning :int) + +(defstruct oci-handle + (type :unknown) + (pointer (uffi:allocate-foreign-object :pointer-void))) + +(defvar *oci-initialized* nil) +(defvar *oci-env* nil) + +(defvar *oci-handle-types* + '(:error ; error report handle (OCIError) + :service-context ; service context handle (OCISvcCtx) + :statement ; statement (application request) handle (OCIStmt) + :describe ; select list description handle (OCIDescribe) + :server ; server context handle (OCIServer) + :session ; user session handle (OCISession) + :transaction ; transaction context handle (OCITrans) + :complex-object ; complex object retrieval handle (OCIComplexObject) + :security)) ; security handle (OCISecurity) + + + +(defun oci-init (&key (mode +oci-default+)) + (let ((x (OCIInitialize mode +null-void-pointer+ +null-void-pointer+ + +null-void-pointer+ +null-void-pointer-pointer+))) + (if (= x 0) + (let ((env (uffi:allocate-foreign-object :pointer-void))) + (setq *oci-initialized* mode) + (let ((x (OCIEnvInit env +oci-default+ 0 +null-void-pointer+))) + (format t ";; OEI: returned ~d~%" x) + (setq *oci-env* env)))))) + +(defun oci-check-return (value) + (when (= value +oci-invalid-handle+) + (error 'sql-database-error :message "Invalid Handle"))) + +(defun oci-get-handle (&key type) + (if (null *oci-initialized*) + (oci-init)) + (case type + (:error + (let ((ptr (uffi:allocate-foreign-object :pointer-void))) + (let ((x (OCIHandleAlloc + (uffi:deref-pointer *oci-env* void-pointer) + ptr + +oci-default+ + 0 + +null-void-pointer-pointer+))) + (oci-check-return x) + ptr))) + (:service-context + "OCISvcCtx") + (:statement + "OCIStmt") + (:describe + "OCIDescribe") + (:server + "OCIServer") + (:session + "OCISession") + (:transaction + "OCITrans") + (:complex-object + "OCIComplexObject") + (:security + "OCISecurity") + (t + (error 'sql-database-error + :message + (format nil "'~s' is not a valid OCI handle type" type))))) + +(defun oci-environment () + (let ((envhp (oci-get-handle :type :env))) + (oci-env-init envhp 0 0 +null-void-pointer+) + envhp)) diff --git a/db-oracle/oracle-constants.lisp b/db-oracle/oracle-constants.lisp new file mode 100644 index 0000000..9f76323 --- /dev/null +++ b/db-oracle/oracle-constants.lisp @@ -0,0 +1,541 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: oracle-constants.lisp +;;;; Purpose: Constants for CLSQL Oracle interface +;;;; +;;;; 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-oracle) + +(defconstant +oci-default+ #x00) ; default value for parameters and attributes +(defconstant +oci-threaded+ #x01) ; application is in threaded environment +(defconstant +oci-object+ #x02) ; the application is in object environment +(defconstant +oci-non-blocking+ #x04) ; non blocking mode of operation +(defconstant +oci-env-no-mutex+ #x08) ; the environment handle will not be protected by a mutex internally + +;; Handle types + +(defconstant +oci-htype-env+ 1) ; environment handle +(defconstant +oci-htype-error+ 2) ; error handle +(defconstant +oci-htype-svcctx+ 3) ; service handle +(defconstant +oci-htype-stmt+ 4) ; statement handle +(defconstant +oci-htype-bind+ 5) ; bind handle +(defconstant +oci-htype-define+ 6) ; define handle +(defconstant +oci-htype-describe+ 7) ; describe handle +(defconstant +oci-htype-server+ 8) ; server handle +(defconstant +oci-htype-session+ 9) ; authentication handle +(defconstant +oci-htype-trans+ 10) ; transaction handle +(defconstant +oci-htype-complexobject+ 11) ; complex object retrieval handle +(defconstant +oci-htype-security+ 12) ; security handle + +;; Descriptor types + +(defconstant +oci-dtype-lob+ 50) ; lob locator +(defconstant +oci-dtype-snap+ 51) ; snapshot +(defconstant +oci-dtype-rset+ 52) ; result set +(defconstant +oci-dtype-param+ 53) ; parameter descriptor obtained from ocigparm +(defconstant +oci-dtype-rowid+ 54) ; rowid +(defconstant +oci-dtype-complexobjectcomp+ 55) ; complex object retrieval descriptor +(defconstant +oci-dtype-file+ 56) ; File Lob locator +(defconstant +oci-dtype-aqenq-options+ 57) ; enqueue options +(defconstant +oci-dtype-aqdeq-options+ 58) ; dequeue options +(defconstant +oci-dtype-aqmsg-properties+ 59) ; message properties +(defconstant +oci-dtype-aqagent+ 60) ; aq agent + +;; Objectr pointer types + +(defconstant +oci-otype-name+ 1) ; object name +(defconstant +oci-otype-ref+ 2) ; REF to TDO +(defconstant +oci-otype-ptr+ 3) ; PTR to TDO + +;; Attribute types + +(defconstant +oci-attr-fncode+ 1) ; the OCI function code +(defconstant +oci-attr-object+ 2) ; is the environment initialized in object mode +(defconstant +oci-attr-nonblocking-mode+ 3) ; non blocking mode +(defconstant +oci-attr-sqlcode+ 4) ; the SQL verb +(defconstant +oci-attr-env+ 5) ; the environment handle +(defconstant +oci-attr-server+ 6) ; the server handle +(defconstant +oci-attr-session+ 7) ; the user session handle +(defconstant +oci-attr-trans+ 8) ; the transaction handle +(defconstant +oci-attr-row-count+ 9) ; the rows processed so far +(defconstant +oci-attr-sqlfncode+ 10) ; the SQL verb of the statement +(defconstant +oci-attr-prefetch-rows+ 11) ; sets the number of rows to prefetch +(defconstant +oci-attr-nested-prefetch-rows+ 12) ; the prefetch rows of nested table +(defconstant +oci-attr-prefetch-memory+ 13) ; memory limit for rows fetched +(defconstant +oci-attr-nested-prefetch-memory+ 14) ; memory limit for nested rows +(defconstant +oci-attr-char-count+ 15) ; this specifies the bind and define size in characters +(defconstant +oci-attr-pdscl+ 16) ; packed decimal scale +(defconstant +oci-attr-pdfmt+ 17) ; packed decimal format +(defconstant +oci-attr-param-count+ 18) ; number of column in the select list +(defconstant +oci-attr-rowid+ 19) ; the rowid +(defconstant +oci-attr-charset+ 20) ; the character set value +(defconstant +oci-attr-nchar+ 21) ; NCHAR type +(defconstant +oci-attr-username+ 22) ; username attribute +(defconstant +oci-attr-password+ 23) ; password attribute +(defconstant +oci-attr-stmt-type+ 24) ; statement type +(defconstant +oci-attr-internal-name+ 25) ; user friendly global name +(defconstant +oci-attr-external-name+ 26) ; the internal name for global txn +(defconstant +oci-attr-xid+ 27) ; XOPEN defined global transaction id +(defconstant +oci-attr-trans-lock+ 28) ; +(defconstant +oci-attr-trans-name+ 29) ; string to identify a global transaction +(defconstant +oci-attr-heapalloc+ 30) ; memory allocated on the heap +(defconstant +oci-attr-charset-id+ 31) ; Character Set ID +(defconstant +oci-attr-charset-form+ 32) ; Character Set Form +(defconstant +oci-attr-maxdata-size+ 33) ; Maximumsize of data on the server +(defconstant +oci-attr-cache-opt-size+ 34) ; object cache optimal size +(defconstant +oci-attr-cache-max-size+ 35) ; object cache maximum size percentage +(defconstant +oci-attr-pinoption+ 36) ; object cache default pin option +(defconstant +oci-attr-alloc-duration+ 37) ; object cache default allocation duration +(defconstant +oci-attr-pin-duration+ 38) ; object cache default pin duration +(defconstant +oci-attr-fdo+ 39) ; Format Descriptor object attribute +(defconstant +oci-attr-postprocessing-callback+ 40) ; Callback to process outbind data +(defconstant +oci-attr-postprocessing-context+ 41) ; Callback context to process outbind data +(defconstant +oci-attr-rows-returned+ 42) ; Number of rows returned in current iter - for Bind handles +(defconstant +oci-attr-focbk+ 43) ; Failover Callback attribute +(defconstant +oci-attr-in-v8-mode+ 44) ; is the server/service context in V8 mode +(defconstant +oci-attr-lobempty+ 45) ; empty lob ? +(defconstant +oci-attr-sesslang+ 46) ; session language handle + +;; AQ Attribute Types +;; Enqueue Options + +(defconstant +oci-attr-visibility+ 47) ; visibility +(defconstant +oci-attr-relative-msgid+ 48) ; relative message id +(defconstant +oci-attr-sequence-deviation+ 49) ; sequence deviation + +; - Dequeue Options - + ; consumer name +;#define OCI-ATTR-DEQ-MODE 50 +;(defconstant +OCI-ATTR-CONSUMER-NAME 50 + 51) ; dequeue mode +;#define OCI-ATTR-NAVIGATION 52 ; navigation +;#define OCI-ATTR-WAIT 53 ; wait +;#define OCI-ATTR-DEQ-MSGID 54 ; dequeue message id + +; - Message Properties - +(defconstant +OCI-ATTR-PRIORITY+ 55) ; priority +(defconstant +OCI-ATTR-DELAY+ 56) ; delay +(defconstant +OCI-ATTR-EXPIRATION+ 57) ; expiration +(defconstant +OCI-ATTR-CORRELATION+ 58) ; correlation id +(defconstant +OCI-ATTR-ATTEMPTS+ 59) ; # of attempts +(defconstant +OCI-ATTR-RECIPIENT-LIST+ 60) ; recipient list +(defconstant +OCI-ATTR-EXCEPTION-QUEUE+ 61) ; exception queue name +(defconstant +OCI-ATTR-ENQ-TIME+ 62) ; enqueue time (only OCIAttrGet) +(defconstant +OCI-ATTR-MSG-STATE+ 63) ; message state (only OCIAttrGet) + +;; AQ Agent +(defconstant +OCI-ATTR-AGENT-NAME+ 64) ; agent name +(defconstant +OCI-ATTR-AGENT-ADDRESS+ 65) ; agent address +(defconstant +OCI-ATTR-AGENT-PROTOCOL+ 66) ; agent protocol + +;- Server handle - +(defconstant +OCI-ATTR-NATIVE-FDES+ 67) ; native cncxn file desc + +;-Parameter Attribute Types- + +(defconstant +OCI-ATTR-UNK+ 101) ; unknown attribute +(defconstant +OCI-ATTR-NUM-COLS+ 102) ; number of columns +(defconstant +OCI-ATTR-LIST-COLUMNS+ 103) ; parameter of the column list +(defconstant +OCI-ATTR-RDBA+ 104) ; DBA of the segment header +(defconstant +OCI-ATTR-CLUSTERED+ 105) ; whether the table is clustered +(defconstant +OCI-ATTR-PARTITIONED+ 106) ; whether the table is partitioned +(defconstant +OCI-ATTR-INDEX-ONLY+ 107) ; whether the table is index only +(defconstant +OCI-ATTR-LIST-ARGUMENTS+ 108) ; parameter of the argument list +(defconstant +OCI-ATTR-LIST-SUBPROGRAMS+ 109) ; parameter of the subprogram list +(defconstant +OCI-ATTR-REF-TDO+ 110) ; REF to the type descriptor +(defconstant +OCI-ATTR-LINK+ 111) ; the database link name +(defconstant +OCI-ATTR-MIN+ 112) ; minimum value +(defconstant +OCI-ATTR-MAX+ 113) ; maximum value +(defconstant +OCI-ATTR-INCR+ 114) ; increment value +(defconstant +OCI-ATTR-CACHE+ 115) ; number of sequence numbers cached +(defconstant +OCI-ATTR-ORDER+ 116) ; whether the sequence is ordered +(defconstant +OCI-ATTR-HW-MARK+ 117) ; high-water mark +(defconstant +OCI-ATTR-TYPE-SCHEMA+ 118) ; type's schema name +(defconstant +OCI-ATTR-TIMESTAMP+ 119) ; timestamp of the object +(defconstant +OCI-ATTR-NUM-ATTRS+ 120) ; number of sttributes +(defconstant +OCI-ATTR-NUM-PARAMS+ 121) ; number of parameters +(defconstant +OCI-ATTR-OBJID+ 122) ; object id for a table or view +(defconstant +OCI-ATTR-PTYPE+ 123) ; type of info described by +(defconstant +OCI-ATTR-PARAM+ 124) ; parameter descriptor +(defconstant +OCI-ATTR-OVERLOAD-ID+ 125) ; overload ID for funcs and procs +(defconstant +OCI-ATTR-TABLESPACE+ 126) ; table name space +(defconstant +OCI-ATTR-TDO+ 127) ; TDO of a type +(defconstant +OCI-ATTR-PARSE-ERROR-OFFSET+ 128) ; Parse Error offset +;-Credential Types- +(defconstant +OCI-CRED-RDBMS+ 1) ; database username/password +(defconstant +OCI-CRED-EXT+ 2) ; externally provided credentials + +;; Error Return Values- + +(defconstant +oci-continue+ -24200) ; Continue with the body of the OCI function +(defconstant +oci-still-executing+ -3123) ; OCI would block error +(defconstant +oci-invalid-handle+ -2) ; maps to SQL-INVALID-HANDLE +(defconstant +oci-error+ -1) ; maps to SQL-ERROR +(defconstant +oci-success+ 0) ; maps to SQL-SUCCESS of SAG CLI +(defconstant +oci-success-with-info+ 1) ; maps to SQL-SUCCESS-WITH-INFO +(defconstant +oci-need-data+ 99) ; maps to SQL-NEED-DATA +(defconstant +oci-no-data+ 100) ; maps to SQL-NO-DATA + +;; Parsing Syntax Types- + +(defconstant +oci-ntv-syntax+ 1) ; Use what so ever is the native lang of server +(defconstant +oci-v7-syntax+ 2) ; V7 language +(defconstant +oci-v8-syntax+ 3) ; V8 language + +;-Scrollable Cursor Options- + +(defconstant +oci-fetch-next+ #x02) ; next row +(defconstant +oci-fetch-first+ #x04) ; first row of the result set +(defconstant +oci-fetch-last+ #x08) ; the last row of the result set +(defconstant +oci-fetch-prior+ #x10) ; the previous row relative to current +(defconstant +oci-fetch-absolute+ #x20) ; absolute offset from first +(defconstant +oci-fetch-relative+ #x40) ; offset relative to current + +;-Bind and Define Options- + +(defconstant +OCI-SB2-IND-PTR+ #x01) ; unused +(defconstant +OCI-DATA-AT-EXEC+ #x02) ; data at execute time +(defconstant +OCI-DYNAMIC-FETCH+ #x02) ; fetch dynamically +(defconstant +OCI-PIECEWISE+ #x04) ; piecewise DMLs or fetch +;- + +;-Execution Modes- +(defconstant +OCI-BATCH-MODE+ #x01) ; batch the oci statement for execution +(defconstant +OCI-EXACT-FETCH+ #x02) ; fetch the exact rows specified +(defconstant +OCI-KEEP-FETCH-STATE+ #x04) ; unused +(defconstant +OCI-SCROLLABLE-CURSOR+ #x08) ; cursor scrollable +(defconstant +OCI-DESCRIBE-ONLY+ #x10) ; only describe the statement +(defconstant +OCI-COMMIT-ON-SUCCESS+ #x20) ; commit, if successful execution +;- + +;-Authentication Modes- +(defconstant +OCI-MIGRATE+ #x0001) ; migratable auth context +(defconstant +OCI-SYSDBA+ #x0002) ; for SYSDBA authorization +(defconstant +OCI-SYSOPER+ #x0004) ; for SYSOPER authorization +(defconstant +OCI-PRELIM-AUTH+ #x0008) ; for preliminary authorization +;- + +;-Piece Information- +(defconstant +OCI-PARAM-IN+ #x01) ; in parameter +(defconstant +OCI-PARAM-OUT+ #x02) ; out parameter +;- + +;- Transaction Start Flags - +; NOTE: OCI-TRANS-JOIN and OCI-TRANS-NOMIGRATE not supported in 8.0.X +(defconstant +OCI-TRANS-NEW+ #x00000001) ; starts a new transaction branch +(defconstant +OCI-TRANS-JOIN+ #x00000002) ; join an existing transaction +(defconstant +OCI-TRANS-RESUME+ #x00000004) ; resume this transaction +(defconstant +OCI-TRANS-STARTMASK+ #x000000ff) + + +(defconstant +OCI-TRANS-READONLY+ #x00000100) ; starts a readonly transaction +(defconstant +OCI-TRANS-READWRITE+ #x00000200) ; starts a read-write transaction +(defconstant +OCI-TRANS-SERIALIZABLE+ #x00000400) + ; starts a serializable transaction +(defconstant +OCI-TRANS-ISOLMASK+ #x0000ff00) + +(defconstant +OCI-TRANS-LOOSE+ #x00010000) ; a loosely coupled branch +(defconstant +OCI-TRANS-TIGHT+ #x00020000) ; a tightly coupled branch +(defconstant +OCI-TRANS-TYPEMASK+ #x000f0000) ; + +(defconstant +OCI-TRANS-NOMIGRATE+ #x00100000) ; non migratable transaction + +;- + +;- Transaction End Flags - +(defconstant +OCI-TRANS-TWOPHASE+ #x01000000) ; use two phase commit +;- + +;; AQ Constants +;; NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE +;; The following constants must match the PL/SQL dbms-aq constants +;; NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE + +; - Visibility flags - +(defconstant +OCI-ENQ-IMMEDIATE+ 1) ; enqueue is an independent transaction +(defconstant +OCI-ENQ-ON-COMMIT+ 2) ; enqueue is part of current transaction + +; - Dequeue mode flags - +(defconstant +OCI-DEQ-BROWSE+ 1) ; read message without acquiring a lock +(defconstant +OCI-DEQ-LOCKED+ 2) ; read and obtain write lock on message +(defconstant +OCI-DEQ-REMOVE+ 3) ; read the message and delete it + +; - Dequeue navigation flags - +(defconstant +OCI-DEQ-FIRST-MSG+ 1) ; get first message at head of queue +(defconstant +OCI-DEQ-NEXT-MSG+ 3) ; next message that is available +(defconstant +OCI-DEQ-NEXT-TRANSACTION+ 2) ; get first message of next txn group + +; - Message states - +(defconstant +OCI-MSG-WAITING+ 1) ; the message delay has not yet completed +(defconstant +OCI-MSG-READY+ 0) ; the message is ready to be processed +(defconstant +OCI-MSG-PROCESSED+ 2) ; the message has been processed +(defconstant +OCI-MSG-EXPIRED+ 3) ; message has moved to exception queue + +; - Sequence deviation - +(defconstant +OCI-ENQ-BEFORE+ 2) ; enqueue message before another message +(defconstant +OCI-ENQ-TOP+ 3) ; enqueue message before all messages + +; - Visibility flags - +(defconstant +OCI-DEQ-IMMEDIATE+ 1) ; dequeue is an independent transaction +(defconstant +OCI-DEQ-ON-COMMIT+ 2) ; dequeue is part of current transaction + +; - Wait - +(defconstant +OCI-DEQ-WAIT-FOREVER+ -1) ; wait forever if no message available +(defconstant +OCI-DEQ-NO-WAIT+ 0) ; do not wait if no message is available + +; - Delay - +(defconstant +OCI-MSG-NO-DELAY+ 0) ; message is available immediately + +;; Expiration +(defconstant +OCI-MSG-NO-EXPIRATION+ -1) ; message will never expire + +;; Describe Handle Parameter Attributes +;; Attributes common to Columns and Stored Procs + +(defconstant +oci-attr-data-size+ 1) ; maximum size of the data +(defconstant +oci-attr-data-type+ 2) ; the sql type of the column/argument +(defconstant +oci-attr-disp-size+ 3) ; the display size +(defconstant +oci-attr-name+ 4) ; the name of the column/argument +(defconstant +oci-attr-precision+ 5) ; precision if number type +(defconstant +oci-attr-scale+ 6) ; scale if number type +(defconstant +oci-attr-is-null+ 7) ; is it null ? +(defconstant +oci-attr-type-name+ 8) + +;; name of the named data type or a package name for package private types + +(defconstant +OCI-ATTR-SCHEMA-NAME+ 9) ; the schema name +(defconstant +OCI-ATTR-SUB-NAME+ 10) ; type name if package private type +(defconstant +OCI-ATTR-POSITION+ 11) ; relative position of col/arg in the list of cols/args + +; complex object retrieval parameter attributes +(defconstant +OCI-ATTR-COMPLEXOBJECTCOMP-TYPE+ 50) ; +(defconstant +OCI-ATTR-COMPLEXOBJECTCOMP-TYPE-LEVEL+ 51) ; +(defconstant +OCI-ATTR-COMPLEXOBJECT-LEVEL+ 52) ; +(defconstant +OCI-ATTR-COMPLEXOBJECT-COLL-OUTOFLINE+ 53) ; + +; Only Columns +(defconstant +OCI-ATTR-DISP-NAME+ 100) ; the display name + +;; stored procs + +(defconstant +OCI-ATTR-OVERLOAD+ 210) ; is this position overloaded +(defconstant +OCI-ATTR-LEVEL+ 211) ; level for structured types +(defconstant +OCI-ATTR-HAS-DEFAULT+ 212) ; has a default value +(defconstant +OCI-ATTR-IOMODE+ 213) ; in, out inout +(defconstant +OCI-ATTR-RADIX+ 214) ; returns a radix +(defconstant +OCI-ATTR-NUM-ARGS+ 215) ; total number of arguments + +;; named type attributes + +(defconstant +oci-attr-typecode+ 216) ; lobject or collection +(defconstant +oci-attr-collection-typecode+ 217) ; varray or nested table +(defconstant +oci-attr-version+ 218) ; user assigned version +(defconstant +oci-attr-is-incomplete-type+ 219) ; is this an incomplete type +(defconstant +oci-attr-is-system-type+ 220) ; a system type +(defconstant +oci-attr-is-predefined-type+ 221) ; a predefined type +(defconstant +oci-attr-is-transient-type+ 222) ; a transient type +(defconstant +oci-attr-is-system-generated-type+ 223) ; system generated type +(defconstant +oci-attr-has-nested-table+ 224) ; contains nested table attr +(defconstant +oci-attr-has-lob+ 225) ; has a lob attribute +(defconstant +oci-attr-has-file+ 226) ; has a file attribute +(defconstant +oci-attr-collection-element+ 227) ; has a collection attribute +(defconstant +oci-attr-num-type-attrs+ 228) ; number of attribute types +(defconstant +oci-attr-list-type-attrs+ 229) ; list of type attributes +(defconstant +oci-attr-num-type-methods+ 230) ; number of type methods +(defconstant +oci-attr-list-type-methods+ 231) ; list of type methods +(defconstant +oci-attr-map-method+ 232) ; map method of type +(defconstant +oci-attr-order-method+ 233) ; order method of type + +; only collection element +(defconstant +OCI-ATTR-NUM-ELEMS+ 234) ; number of elements + +; only type methods +(defconstant +OCI-ATTR-ENCAPSULATION+ 235) ; encapsulation level +(defconstant +OCI-ATTR-IS-SELFISH+ 236) ; method selfish +(defconstant +OCI-ATTR-IS-VIRTUAL+ 237) ; virtual +(defconstant +OCI-ATTR-IS-INLINE+ 238) ; inline +(defconstant +OCI-ATTR-IS-CONSTANT+ 239) ; constant +(defconstant +OCI-ATTR-HAS-RESULT+ 240) ; has result +(defconstant +OCI-ATTR-IS-CONSTRUCTOR+ 241) ; constructor +(defconstant +OCI-ATTR-IS-DESTRUCTOR+ 242) ; destructor +(defconstant +OCI-ATTR-IS-OPERATOR+ 243) ; operator +(defconstant +OCI-ATTR-IS-MAP+ 244) ; a map method +(defconstant +OCI-ATTR-IS-ORDER+ 245) ; order method +(defconstant +OCI-ATTR-IS-RNDS+ 246) ; read no data state method +(defconstant +OCI-ATTR-IS-RNPS+ 247) ; read no process state +(defconstant +OCI-ATTR-IS-WNDS+ 248) ; write no data state method +(defconstant +OCI-ATTR-IS-WNPS+ 249) ; write no process state + +; describing public objects +(defconstant +OCI-ATTR-DESC-PUBLIC+ 250) ; public object +;- + +;-OCIPasswordChange- +(defconstant +OCI-AUTH+ #x08) ; Change the password but do not login + + +;-Other Constants- +(defconstant +OCI-MAX-FNS+ 100) ; max number of OCI Functions +(defconstant +OCI-SQLSTATE-SIZE+ 5) ; +(defconstant +OCI-ERROR-MAXMSG-SIZE+ 1024) ; max size of an error message +;; (defconstant +OCI-LOBMAXSIZE+ 4MAXVAL) ; maximum lob data size +(defconstant +OCI-ROWID-LEN+ 23) ; +;- + +;- Fail Over Events - +(defconstant +OCI-FO-END+ #x00000001) ; +(defconstant +OCI-FO-ABORT+ #x00000002) ; +(defconstant +OCI-FO-REAUTH+ #x00000004) ; +(defconstant +OCI-FO-BEGIN+ #x00000008) ; +(defconstant +OCI-FO-ERROR+ #x00000010) ; +;- + +;- Fail Over Types - +(defconstant +OCI-FO-NONE+ #x00000001) ; +(defconstant +OCI-FO-SESSION+ #x00000002) ; +(defconstant +OCI-FO-SELECT+ #x00000004) ; +(defconstant +OCI-FO-TXNAL+ #x00000008) ; +;- + +;-Function Codes- +(defconstant +OCI-FNCODE-INITIALIZE+ 1) ; OCIInitialize +(defconstant +OCI-FNCODE-HANDLEALLOC+ 2) ; OCIHandleAlloc +(defconstant +OCI-FNCODE-HANDLEFREE+ 3) ; OCIHandleFree +(defconstant +OCI-FNCODE-DESCRIPTORALLOC+ 4) ; OCIDescriptorAlloc +(defconstant +OCI-FNCODE-DESCRIPTORFREE+ 5) ; OCIDescriptorFree +(defconstant +OCI-FNCODE-ENVINIT+ 6) ; OCIEnvInit +(defconstant +OCI-FNCODE-SERVERATTACH+ 7) ; OCIServerAttach +(defconstant +OCI-FNCODE-SERVERDETACH+ 8) ; OCIServerDetach +; unused 9 +(defconstant +OCI-FNCODE-SESSIONBEGIN+ 10) ; OCISessionBegin +(defconstant +OCI-FNCODE-SESSIONEND+ 11) ; OCISessionEnd +(defconstant +OCI-FNCODE-PASSWORDCHANGE+ 12) ; OCIPasswordChange +(defconstant +OCI-FNCODE-STMTPREPARE+ 13) ; OCIStmtPrepare + ; unused 14- 16 +(defconstant +OCI-FNCODE-BINDDYNAMIC+ 17) ; OCIBindDynamic +(defconstant +OCI-FNCODE-BINDOBJECT+ 18) ; OCIBindObject + ; 19 unused +(defconstant +OCI-FNCODE-BINDARRAYOFSTRUCT+ 20) ; OCIBindArrayOfStruct +(defconstant +OCI-FNCODE-STMTEXECUTE+ 21) ; OCIStmtExecute + ; unused 22-24 +(defconstant +OCI-FNCODE-DEFINEOBJECT+ 25) ; OCIDefineObject +(defconstant +OCI-FNCODE-DEFINEDYNAMIC+ 26) ; OCIDefineDynamic +(defconstant +OCI-FNCODE-DEFINEARRAYOFSTRUCT+ 27) ; OCIDefineArrayOfStruct +(defconstant +OCI-FNCODE-STMTFETCH+ 28) ; OCIStmtFetch +(defconstant +OCI-FNCODE-STMTGETBIND+ 29) ; OCIStmtGetBindInfo + ; 30, 31 unused +(defconstant +OCI-FNCODE-DESCRIBEANY+ 32) ; OCIDescribeAny +(defconstant +OCI-FNCODE-TRANSSTART+ 33) ; OCITransStart +(defconstant +OCI-FNCODE-TRANSDETACH+ 34) ; OCITransDetach +(defconstant +OCI-FNCODE-TRANSCOMMIT+ 35) ; OCITransCommit + ; 36 unused +(defconstant +OCI-FNCODE-ERRORGET+ 37) ; OCIErrorGet +(defconstant +OCI-FNCODE-LOBOPENFILE+ 38) ; OCILobFileOpen +(defconstant +OCI-FNCODE-LOBCLOSEFILE+ 39) ; OCILobFileClose + ; 40 was LOBCREATEFILE, unused + ; 41 was OCILobFileDelete, unused +(defconstant +OCI-FNCODE-LOBCOPY+ 42) ; OCILobCopy +(defconstant +OCI-FNCODE-LOBAPPEND+ 43) ; OCILobAppend +(defconstant +OCI-FNCODE-LOBERASE+ 44) ; OCILobErase +(defconstant +OCI-FNCODE-LOBLENGTH+ 45) ; OCILobGetLength +(defconstant +OCI-FNCODE-LOBTRIM+ 46) ; OCILobTrim +(defconstant +OCI-FNCODE-LOBREAD+ 47) ; OCILobRead +(defconstant +OCI-FNCODE-LOBWRITE+ 48) ; OCILobWrite + ; 49 unused +(defconstant +OCI-FNCODE-SVCCTXBREAK+ 50) ; OCIBreak +(defconstant +OCI-FNCODE-SERVERVERSION+ 51) ; OCIServerVersion +; unused 52, 53 +(defconstant +OCI-FNCODE-ATTRGET+ 54) ; OCIAttrGet +(defconstant +OCI-FNCODE-ATTRSET+ 55) ; OCIAttrSet +(defconstant +OCI-FNCODE-PARAMSET+ 56) ; OCIParamSet +(defconstant +OCI-FNCODE-PARAMGET+ 57) ; OCIParamGet +(defconstant +OCI-FNCODE-STMTGETPIECEINFO+ 58) ; OCIStmtGetPieceInfo +(defconstant +OCI-FNCODE-LDATOSVCCTX+ 59) ; OCILdaToSvcCtx + ; 60 unused +(defconstant +OCI-FNCODE-STMTSETPIECEINFO+ 61) ; OCIStmtSetPieceInfo +(defconstant +OCI-FNCODE-TRANSFORGET+ 62) ; OCITransForget +(defconstant +OCI-FNCODE-TRANSPREPARE+ 63) ; OCITransPrepare +(defconstant +OCI-FNCODE-TRANSROLLBACK+ 64) ; OCITransRollback +(defconstant +OCI-FNCODE-DEFINEBYPOS+ 65) ; OCIDefineByPos +(defconstant +OCI-FNCODE-BINDBYPOS+ 66) ; OCIBindByPos +(defconstant +OCI-FNCODE-BINDBYNAME+ 67) ; OCIBindByName +(defconstant +OCI-FNCODE-LOBASSIGN+ 68) ; OCILobAssign +(defconstant +OCI-FNCODE-LOBISEQUAL+ 69) ; OCILobIsEqual +(defconstant +OCI-FNCODE-LOBISINIT+ 70) ; OCILobLocatorIsInit +; 71 was lob locator size in beta2 +(defconstant +OCI-FNCODE-LOBENABLEBUFFERING+ 71) ; OCILobEnableBuffering +(defconstant +OCI-FNCODE-LOBCHARSETID+ 72) ; OCILobCharSetID +(defconstant +OCI-FNCODE-LOBCHARSETFORM+ 73) ; OCILobCharSetForm +(defconstant +OCI-FNCODE-LOBFILESETNAME+ 74) ; OCILobFileSetName +(defconstant +OCI-FNCODE-LOBFILEGETNAME+ 75) ; OCILobFileGetName +(defconstant +OCI-FNCODE-LOGON+ 76) ; OCILogon +(defconstant +OCI-FNCODE-LOGOFF+ 77) ; OCILogoff +(defconstant +OCI-FNCODE-LOBDISABLEBUFFERING+ 78) ; OCILobDisableBuffering +(defconstant +OCI-FNCODE-LOBFLUSHBUFFER+ 79) ; OCILobFlushBuffer +(defconstant +OCI-FNCODE-LOBLOADFROMFILE+ 80) ; OCILobLoadFromFile + + +;- + +;- FILE open modes - +(defconstant +OCI-FILE-READONLY+ 1) ; readonly mode open for FILE types +;- + +;- LOB Buffering Flush Flags - +(defconstant +OCI-LOB-BUFFER-FREE+ 1) ; +(defconstant +OCI-LOB-BUFFER-NOFREE+ 2) ; +;- + +;- OCI Statement Types - + +(defconstant +oci-stmt-select+ 1) ; select statement +(defconstant +oci-stmt-update+ 2) ; update statement +(defconstant +oci-stmt-delete+ 3) ; delete statement +(defconstant +oci-stmt-insert+ 4) ; insert statement +(defconstant +oci-stmt-create+ 5) ; create statement +(defconstant +oci-stmt-drop+ 6) ; drop statement +(defconstant +oci-stmt-alter+ 7) ; alter statement +(defconstant +oci-stmt-begin+ 8) ; begin ... (pl/sql statement) +(defconstant +oci-stmt-declare+ 9) ; declare .. (pl/sql statement ) +;- + +;- OCI Parameter Types - +(defconstant +OCI-PTYPE-UNK+ 0) ; unknown +(defconstant +OCI-PTYPE-TABLE+ 1) ; table +(defconstant +OCI-PTYPE-VIEW+ 2) ; view +(defconstant +OCI-PTYPE-PROC+ 3) ; procedure +(defconstant +OCI-PTYPE-FUNC+ 4) ; function +(defconstant +OCI-PTYPE-PKG+ 5) ; package +(defconstant +OCI-PTYPE-TYPE+ 6) ; user-defined type +(defconstant +OCI-PTYPE-SYN+ 7) ; synonym +(defconstant +OCI-PTYPE-SEQ+ 8) ; sequence +(defconstant +OCI-PTYPE-COL+ 9) ; column +(defconstant +OCI-PTYPE-ARG+ 10) ; argument +(defconstant +OCI-PTYPE-LIST+ 11) ; list +(defconstant +OCI-PTYPE-TYPE-ATTR+ 12) ; user-defined type's attribute +(defconstant +OCI-PTYPE-TYPE-COLL+ 13) ; collection type's element +(defconstant +OCI-PTYPE-TYPE-METHOD+ 14) ; user-defined type's method +(defconstant +OCI-PTYPE-TYPE-ARG+ 15) ; user-defined type method's argument +(defconstant +OCI-PTYPE-TYPE-RESULT+ 16) ; user-defined type method's result +;- + +;- OCI List Types - +(defconstant +OCI-LTYPE-UNK+ 0) ; unknown +(defconstant +OCI-LTYPE-COLUMN+ 1) ; column list +(defconstant +OCI-LTYPE-ARG-PROC+ 2) ; procedure argument list +(defconstant +OCI-LTYPE-ARG-FUNC+ 3) ; function argument list +(defconstant +OCI-LTYPE-SUBPRG+ 4) ; subprogram list +(defconstant +OCI-LTYPE-TYPE-ATTR+ 5) ; type attribute +(defconstant +OCI-LTYPE-TYPE-METHOD+ 6) ; type method +(defconstant +OCI-LTYPE-TYPE-ARG-PROC+ 7) ; type method w/o result argument list +(defconstant +OCI-LTYPE-TYPE-ARG-FUNC+ 8) ; type method w/result argument list + +;; typecodes + diff --git a/db-oracle/oracle-loader.lisp b/db-oracle/oracle-loader.lisp new file mode 100644 index 0000000..f1493d3 --- /dev/null +++ b/db-oracle/oracle-loader.lisp @@ -0,0 +1,53 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: oracle-loader.lisp +;;;; Purpose: Foreign library loader for CLSQL Oracle interface +;;;; +;;;; 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-oracle) + +(defparameter *oracle-home* + (let ((oracle-home (getenv "ORACLE_HOME"))) + (when oracle-home + (parse-namestring (concatenate 'string oracle-home "/")))) + "Pathname of ORACLE_HOME as set in user environment.") + +(defparameter *oracle-client-library-filenames* + (list "libclntsh" "oci")) + +(defvar *oracle-supporting-libraries* '("c") + "Used only by CMU. List of library flags needed to be passed to ld to +load the Oracle client library succesfully. If this differs at your site, +set to the right path before compiling or loading the system.") + +(defvar *oracle-library-loaded* nil + "T if foreign library was able to be loaded successfully") + +(defmethod clsql-sys:database-type-library-loaded ((database-type (eql :oracle))) + *oracle-library-loaded*) + +(defmethod clsql-sys:database-type-load-foreign ((database-type (eql :oracle))) + (when *oracle-home* + (dolist (dir-name '("lib" "bin")) + (dolist (lib-name '("libclntsh" "oci")) + (clsql:push-library-path + (make-pathname :name lib-name + :directory (append (pathname-directory *oracle-home*) + (list dir-name))))))) + + (clsql-uffi:find-and-load-foreign-library *oracle-client-library-filenames* + :module "clsql-oracle" + :supporting-libraries *oracle-supporting-libraries*) + (setq *oracle-library-loaded* t)) + +(clsql-sys:database-type-load-foreign :oracle) + + diff --git a/db-oracle/oracle-objects.lisp b/db-oracle/oracle-objects.lisp new file mode 100644 index 0000000..3e5a6b7 --- /dev/null +++ b/db-oracle/oracle-objects.lisp @@ -0,0 +1,128 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: oracle-objects.lisp +;;;; +;;;; 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-oracle) + +(defmethod database-get-type-specifier (type args database (db-type (eql :oracle))) + (declare (ignore type args database)) + (format nil "VARCHAR2(~D)" *default-string-length*)) + +(defmethod database-get-type-specifier ((type (eql 'integer)) args + database (db-type (eql :oracle))) + (declare (ignore database)) + (if args + (format nil "NUMBER(~A,~A)" + (or (first args) 38) (or (second args) 0)) + "INTEGER")) + +(defmethod database-get-type-specifier ((type (eql 'bigint)) args + database (db-type (eql :oracle))) + (declare (ignore args database)) + "CHAR(20)") + +(defmethod database-get-type-specifier ((type (eql 'universal-time)) args + database (db-type (eql :oracle))) + (declare (ignore args database)) + "CHAR(20)") + +(defmethod database-get-type-specifier ((type (eql 'string)) args + database (db-type (eql :oracle))) + (declare (ignore database)) + (if args + (format nil "CHAR(~A)" (car args)) + (format nil "VARCHAR2(~D)" *default-string-length*))) + +(defmethod database-get-type-specifier ((type (eql 'varchar)) args + database (db-type (eql :oracle))) + (declare (ignore database)) + (if args + (format nil "VARCHAR2(~A)" (car args)) + (format nil "VARCHAR2(~D)" *default-string-length*))) + +(defmethod database-get-type-specifier ((type (eql 'float)) args + database (db-type (eql :oracle))) + (declare (ignore database)) + (if args + (format nil "NUMBER(~A,~A)" (or (first args) 38) (or (second args) 38)) + "DOUBLE PRECISION")) + +(defmethod database-get-type-specifier ((type (eql 'long-float)) args + database (db-type (eql :oracle))) + (declare (ignore database)) + (if args + (format nil "NUMBER(~A,~A)" + (or (first args) 38) (or (second args) 38)) + "DOUBLE PRECISION")) + +(defmethod database-get-type-specifier ((type (eql 'boolean)) args + database (db-type (eql :oracle))) + (declare (ignore args database)) + "CHAR(1)") + +(defmethod database-get-type-specifier ((type (eql 'generalized-boolean)) args + database (db-type (eql :oracle))) + (declare (ignore args database)) + "CHAR(1)") + +(defmethod read-sql-value (val type + database (db-type (eql :oracle))) + ;;(format t "value is \"~A\" of type ~A~%" val (type-of val)) + (declare (ignore type database)) + (etypecase val + (string + (read-from-string val)) + (symbol + nil))) + +(defmethod read-sql-value (val (type (eql 'integer)) + database (db-type (eql :oracle))) + (declare (ignore database)) + val) + +(defmethod read-sql-value (val (type (eql 'float)) + database (db-type (eql :oracle))) + (declare (ignore database)) + val) + +(defmethod read-sql-value (val (type (eql 'boolean)) + database (db-type (eql :oracle))) + (declare (ignore database)) + (when (char-equal #\t (schar val 0)) + t)) + +(defmethod read-sql-value (val (type (eql 'generalized-boolean)) + database (db-type (eql :oracle))) + (declare (ignore database)) + (when (char-equal #\t (schar val 0)) + t)) + +(defmethod read-sql-value (val (type (eql 'bigint)) + database (db-type (eql :oracle))) + (declare (ignore database)) + (parse-integer val)) + +(defmethod read-sql-value (val (type (eql 'universal-time)) + database (db-type (eql :oracle))) + (declare (ignore database)) + (parse-integer val)) + + +(defmethod database-get-type-specifier ((type (eql 'wall-time)) args + database (db-type (eql :oracle))) + (declare (ignore args database)) + "DATE") + +(defmethod database-get-type-specifier ((type (eql 'duration)) args + database (db-type (eql :oracle))) + (declare (ignore args database)) + "NUMBER(38)") diff --git a/db-oracle/oracle-package.lisp b/db-oracle/oracle-package.lisp new file mode 100644 index 0000000..d5c229f --- /dev/null +++ b/db-oracle/oracle-package.lisp @@ -0,0 +1,23 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: oracle-package.cl +;;;; Purpose: Package definition for CLSQL Oracle interface +;;;; +;;;; 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 #:cl-user) + +(defpackage #:clsql-oracle + (:use #:common-lisp #:clsql-sys #:clsql-uffi) + (:export #:oracle-database + #:*oracle-server-version* + #:*oracle-so-load-path* + #:*oracle-so-libraries*) + (:documentation "This is the CLSQL interface to Oracle.")) diff --git a/db-oracle/oracle-sql.lisp b/db-oracle/oracle-sql.lisp new file mode 100644 index 0000000..9460011 --- /dev/null +++ b/db-oracle/oracle-sql.lisp @@ -0,0 +1,1074 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: oracle-sql.lisp +;;;; +;;;; 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-oracle) + +(defmethod database-initialize-database-type ((database-type (eql :oracle))) + t) + +;;;; arbitrary parameters, tunable for performance or other reasons + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defconstant +errbuf-len+ 512 + "the number of characters that we allocate for an error message buffer") + (defconstant +n-buf-rows+ 200 + "the number of table rows that we buffer at once when reading a table. +CMUCL has a compiled-in limit on how much C data can be allocated +(through malloc() and friends) at any given time, typically 8 Mb. +Setting this constant to a moderate value should make it less +likely that we'll have to worry about the CMUCL limit.")) + + +(uffi:def-type vp-type :pointer-void) +(uffi:def-type vpp-type (* :pointer-void)) + +(defmacro deref-vp (foreign-object) + `(the vp-type (uffi:deref-pointer (the vpp-type ,foreign-object) :pointer-void))) + +(uffi:def-pointer-var +unsigned-char-null-pointer+ + (uffi:make-null-pointer :unsigned-char)) +(uffi:def-pointer-var +unsigned-short-null-pointer+ + (uffi:make-null-pointer :unsigned-short)) +(uffi:def-pointer-var +unsigned-int-null-pointer+ + (uffi:make-null-pointer :unsigned-int)) + +;; constants - from OCI? + +(defconstant +var-not-in-list+ 1007) +(defconstant +no-data-found+ 1403) +(defconstant +null-value-returned+ 1405) +(defconstant +field-truncated+ 1406) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defconstant SQLT-NUMBER 2) + (defconstant SQLT-INT 3) + (defconstant SQLT-FLT 4) + (defconstant SQLT-STR 5) + (defconstant SQLT-DATE 12)) + +;;; Note that despite the suggestive class name (and the way that the +;;; *DEFAULT-DATABASE* variable holds an object of this class), a DB +;;; object is not actually a database but is instead a connection to a +;;; database. Thus, there's no obstacle to having any number of DB +;;; objects referring to the same database. + +(uffi:def-type pointer-pointer-void (* :pointer-void)) + +(defclass oracle-database (database) ; was struct db + ((envhp + :reader envhp + :initarg :envhp + :type pointer-pointer-void + :documentation + "OCI environment handle") + (errhp + :reader errhp + :initarg :errhp + :type pointer-pointer-void + :documentation + "OCI error handle") + (svchp + :reader svchp + :initarg :svchp + :type pointer-pointer-void + :documentation + "OCI service context handle") + (data-source-name + :initarg :dsn + :initform nil + :documentation + "optional data source name (used only for debugging/printing)") + (user + :initarg :user + :reader user + :type string + :documentation + "the \"user\" value given when data source connection was made") + (date-format + :initarg :date-format + :reader date-format + :initform "YYYY-MM-DD HH24:MI:SS\".0\"") + (date-format-length + :type number + :documentation + "Each database connection can be configured with its own date +output format. In order to extract date strings from output buffers +holding multiple date strings in fixed-width fields, we need to know +the length of that format.") + (server-version + :type (or null string) + :initarg :server-version + :reader server-version + :documentation + "Version string of Oracle server.") + (major-server-version + :type (or null fixnum) + :initarg :major-server-version + :reader major-server-version + :documentation + "The major version number of the Oracle server, should be 8, 9, or 10"))) + +;;; Handle a non-successful result from an OCI function. +(defun handle-oci-result (result database nulls-ok) + (case result + (#.+oci-success+ + +oci-success+) + (#.+oci-error+ + (handle-oci-error :database database :nulls-ok nulls-ok)) + (#.+oci-no-data+ + (error 'sql-database-error :message "OCI No Data Found")) + (#.+oci-success-with-info+ + (error 'sql-database-error :message "internal error: unexpected +oci-success-with-info")) + (#.+oci-invalid-handle+ + (error 'sql-database-error :message "OCI Invalid Handle")) + (#.+oci-need-data+ + (error 'sql-database-error :message "OCI Need Data")) + (#.+oci-still-executing+ + (error 'sql-temporary-error :message "OCI Still Executing")) + (#.+oci-continue+ + (error 'sql-database-error :message "OCI Continue")) + (1804 + (error 'sql-database-error :message "Check ORACLE_HOME and NLS settings.")) + (t + (error 'sql-database-error + :message + (format nil "OCI unknown error, code=~A" result))))) + +;;; Handle the messy case of return code=+oci-error+, querying the +;;; system for subcodes and reporting them as appropriate. ERRHP and +;;; NULLS-OK are as in the OERR function. + +(defun handle-oci-error (&key database nulls-ok) + (cond + (database + (with-slots (errhp) database + (let ((errcode (uffi:allocate-foreign-object 'sb4)) + (errbuf (uffi:allocate-foreign-string #.+errbuf-len+))) + ;; ensure errbuf empty string + (setf (uffi:deref-array errbuf '(:array :unsigned-char) 0) + (uffi:ensure-char-storable (code-char 0))) + (setf (uffi:deref-pointer errcode 'sb4) 0) + + (uffi:with-cstring (sqlstate nil) + (oci-error-get (deref-vp errhp) 1 + sqlstate + errcode + (uffi:char-array-to-pointer errbuf) + +errbuf-len+ +oci-htype-error+)) + (let ((subcode (uffi:deref-pointer errcode 'sb4)) + (errstr (uffi:convert-from-foreign-string + errbuf + :encoding (when database (encoding database))))) + (uffi:free-foreign-object errcode) + (uffi:free-foreign-object errbuf) + (unless (and nulls-ok (= subcode +null-value-returned+)) + (error 'sql-database-error + :database database + :error-id subcode + :message errstr)))))) + (nulls-ok + (error 'sql-database-error + :database database + :message "can't handle NULLS-OK without ERRHP")) + (t + (error 'sql-database-error + :database database + :message "OCI Error (and no ERRHP available to find subcode)")))) + +;;; Require an OCI success code. +;;; +;;; (The ordinary OCI error reporting mechanisms uses a fair amount of +;;; machinery (environments and other handles). In order to get to +;;; where we can use these mechanisms, we have to be able to allocate +;;; the machinery. The functions for allocating the machinery can +;;; return errors (e.g. out of memory) but shouldn't. Wrapping this function +;;; around function calls to such have-to-succeed functions enforces +;;; this condition.) + +(defun osucc (code) + (declare (type fixnum code)) + (unless (= code +oci-success+) + (error 'sql-database-error + :message (format nil "unexpected OCI failure, code=~S" code)))) + + +;;; Enabling this can be handy for low-level debugging. +#+nil +(progn + (trace #-oci7 oci-env-create oci-initialize oci-handle-alloc oci-logon + oci-error-get oci-stmt-prepare oci-stmt-execute + oci-param-get oci-logon oci-attr-get oci-define-by-pos oci-stmt-fetch) + (setf debug::*debug-print-length* nil)) + + +;; Return the INDEXth string of the OCI array, represented as Lisp +;; SIMPLE-STRING. SIZE is the size of the fixed-width fields used by +;; Oracle to store strings within the array. + +(uffi:def-type string-pointer (* :unsigned-char)) + +(defun deref-oci-string (arrayptr string-index size encoding) + (declare (type string-pointer arrayptr)) + (declare (type (mod #.+n-buf-rows+) string-index)) + (declare (type (and unsigned-byte fixnum) size)) + (let ((str (uffi:convert-from-foreign-string + (uffi:make-pointer + (+ (uffi:pointer-address arrayptr) (* string-index size)) + :unsigned-char) + :encoding encoding))) + (if (string-equal str "NULL") nil str))) + +;; the OCI library, part Z: no-longer used logic to convert from +;; Oracle's binary date representation to Common Lisp's native date +;; representation + +#+nil +(defvar +oci-date-bytes+ 7) + +;;; Return the INDEXth date in the OCI array, represented as +;;; a Common Lisp "universal time" (i.e. seconds since 1900). + +#+nil +(defun deref-oci-date (arrayptr index) + (oci-date->universal-time (uffi:pointer-address + (uffi:deref-array arrayptr + '(:array :unsigned-char) + (* index +oci-date-bytes+))))) +#+nil +(defun oci-date->universal-time (oci-date) + (declare (type (alien (* :unsigned-char)) oci-date)) + (flet (;; a character from OCI-DATE, interpreted as an unsigned byte + (ub (i) + (declare (type (mod #.+oci-date-bytes+) i)) + (mod (uffi:deref-array oci-date string-array i) 256))) + (let* ((century (* (- (ub 0) 100) 100)) + (year (+ century (- (ub 1) 100))) + (month (ub 2)) + (day (ub 3)) + (hour (1- (ub 4))) + (minute (1- (ub 5))) + (second (1- (ub 6)))) + (encode-universal-time second minute hour day month year)))) + + +(defmethod database-list-tables ((database oracle-database) &key owner) + (let ((query + (cond ((null owner) + "select table_name from user_tables") + ((eq owner :all) + "select table_name from all_tables") + (t + (format nil + "select user_tables.table_name from user_tables,all_tables where user_tables.table_name=all_tables.table_name and all_tables.owner='~:@(~A~)'" + owner))))) + (mapcar #'car (database-query query database nil nil)))) + + +(defmethod database-list-views ((database oracle-database) &key owner) + (let ((query + (cond ((null owner) + "select view_name from user_views") + ((eq owner :all) + "select view_name from all_views") + (t + (format nil + "select user_views.view_name from user_views,all_views where user_views.view_name=all_views.view_name and all_views.owner='~:@(~A~)'" + owner))))) + (mapcar #'car + (database-query query database nil nil)))) + +(defmethod database-list-indexes ((database oracle-database) + &key (owner nil)) + (let ((query + (cond ((null owner) + "select index_name from user_indexes") + ((eq owner :all) + "select index_name from all_indexes") + (t (format nil + "select user_indexes.index_name from user_indexes,all_indexes where user_indexes.index_name=all_indexes.index_name and all_indexes.owner='~:@(~A~)'" + owner))))) + (mapcar #'car (database-query query database nil nil)))) + +(defmethod database-list-table-indexes (table (database oracle-database) + &key (owner nil)) + (let ((query + (cond ((null owner) + (format nil "select index_name from user_indexes where table_name='~A'" + table)) + ((eq owner :all) + (format nil "select index_name from all_indexes where table_name='~A'" + table)) + (t + (format nil + "select user_indexes.index_name from user_indexes,all_indexes where user_indexes.table_name='~A' and user_indexes.index_name=all_indexes.index_name and all_indexes.owner='~:@(~A~)'" + table owner))))) + (mapcar #'car (database-query query database nil nil)))) + + +(defmethod database-list-attributes (table (database oracle-database) &key owner) + (let ((query + (cond ((null owner) + (format nil "select column_name from user_tab_columns where table_name='~A'" + table)) + ((eq owner :all) + (format nil "select column_name from all_tab_columns where table_name='~A'" + table)) + (t + (format nil + "select user_tab_columns.column_name from user_tab_columns,all_tables where user_tab_columns.table_name='~A' and all_tables.table_name=user_tab_columns.table_name and all_tables.owner='~:@(~A~)'" + table owner))))) + (mapcar #'car (database-query query database nil nil)))) + +(defmethod database-attribute-type (attribute (table string) + (database oracle-database) + &key (owner nil)) + (let ((query + (cond ((null owner) + (format nil + "select data_type,data_length,data_scale,nullable from user_tab_columns where table_name='~A' and column_name='~A'" + table attribute)) + ((eq owner :all) + (format nil + "select data_type,data_length,data_scale,nullable from all_tab_columns where table_name='~A' and column_name='~A'" + table attribute)) + (t + (format nil + "select data_type,data_length,data_scale,nullable from user_tab_columns,all_tables where user_tab_columns.table_name='~A' and column_name='~A' and all_tables.table_name=user_tab_columns.table_name and all_tables.owner='~:@(~A~)'" + table attribute owner))))) + (destructuring-bind (type length scale nullable) (car (database-query query database :auto nil)) + (values (ensure-keyword type) length scale + (if (char-equal #\Y (schar nullable 0)) 1 0))))) + +;; Return one row of the table referred to by QC, represented as a +;; list; or if there are no more rows, signal an error if EOF-ERRORP, +;; or return EOF-VALUE otherwise. + +;; KLUDGE: This CASE statement is a strong sign that the code would be +;; cleaner if CD were made into an abstract class, we made variant +;; classes for CD-for-column-of-strings, CD-for-column-of-floats, +;; etc., and defined virtual functions to handle operations like +;; get-an-element-from-column. (For a small special purpose module +;; like this, would arguably be overkill, so I'm not going to do it +;; now, but if this code ends up getting more complicated in +;; maintenance, it would become a really good idea.) + +;; Arguably this would be a good place to signal END-OF-FILE, but +;; since the ANSI spec specifically says that END-OF-FILE means a +;; STREAM which has no more data, and QC is not a STREAM, we signal +;; DBI-ERROR instead. + +(uffi:def-type short-array (* :short)) +(uffi:def-type int-array (* :int)) +(uffi:def-type double-array (* :double)) +(uffi:def-type int-pointer (* :int)) +(uffi:def-type double-pointer (* :double)) + +;;; the result of a database query: a cursor through a table +(defstruct (oracle-result-set (:print-function print-query-cursor) + (:conc-name qc-) + (:constructor %make-query-cursor)) + (db (error "missing DB") ; db conn. this table is associated with + :type oracle-database + :read-only t) + (stmthp (error "missing STMTHP") ; the statement handle used to create +;; :type alien ; this table. owned by the QUERY-CURSOR + :read-only t) ; object, deallocated on CLOSE-QUERY + (cds) ; (error "missing CDS") ; column descriptors +; :type (simple-array cd 1) + ; :read-only t) + (n-from-oci + 0 ; buffered rows: number of rows recv'd + :type (integer 0 #.+n-buf-rows+)) ; from the database on the last read + (n-to-dbi + 0 ; number of buffered rows returned, i.e. + :type (integer 0 #.+n-buf-rows+)) ; the index, within the buffered rows, + ; of the next row which hasn't already + ; been returned + (total-n-from-oci + 0 ; total number of bytes recv'd from OCI + :type unsigned-byte) ; in all reads + (oci-end-seen-p nil)) ; Have we seen the end of OCI + ; data, i.e. OCI returning + ; less data than we requested? + ; OCI doesn't seem to like us + ; to try to read more data + ; from it after that.. + + +(defun fetch-row (qc &optional (eof-errorp t) eof-value encoding) + (declare (optimize (speed 3))) + (cond ((zerop (qc-n-from-oci qc)) + (if eof-errorp + (error 'sql-database-error :message + (format nil "no more rows available in ~S" qc)) + eof-value)) + ((>= (qc-n-to-dbi qc) + (qc-n-from-oci qc)) + (refill-qc-buffers qc) + (fetch-row qc nil eof-value encoding)) + (t + (let ((cds (qc-cds qc)) + (reversed-result nil) + (irow (qc-n-to-dbi qc))) + (dotimes (icd (length cds)) + (let* ((cd (aref cds icd)) + (b (foreign-resource-buffer (cd-buffer cd))) + (value + (let* ((arb (foreign-resource-buffer (cd-indicators cd))) + (indicator (uffi:deref-array arb '(:array :short) irow))) + (declare (type short-array arb)) + (unless (= indicator -1) + (ecase (cd-oci-data-type cd) + (#.SQLT-STR + (deref-oci-string b irow (cd-sizeof cd) encoding)) + (#.SQLT-FLT + (locally + (declare (type double-array b)) + (uffi:deref-array b '(:array :double) irow))) + (#.SQLT-INT + (ecase (cd-sizeof cd) + (4 + (locally + (declare (type int-array b)) + (uffi:deref-array b '(:array :int) irow))))) + (#.SQLT-DATE + (deref-oci-string b irow (cd-sizeof cd) encoding))))))) + (when (and (eq :string (cd-result-type cd)) + value + (not (stringp value))) + (setq value (write-to-string value))) + (push value reversed-result))) + (incf (qc-n-to-dbi qc)) + (nreverse reversed-result))))) + +(defun refill-qc-buffers (qc) + (with-slots (errhp) (qc-db qc) + (setf (qc-n-to-dbi qc) 0) + (cond ((qc-oci-end-seen-p qc) + (setf (qc-n-from-oci qc) 0)) + (t + (let ((oci-code (%oci-stmt-fetch + (deref-vp (qc-stmthp qc)) + (deref-vp errhp) + +n-buf-rows+ + +oci-fetch-next+ +oci-default+))) + (ecase oci-code + (#.+oci-success+ (values)) + (#.+oci-no-data+ (setf (qc-oci-end-seen-p qc) t) + (values)) + (#.+oci-error+ (handle-oci-error :database (qc-db qc) + :nulls-ok t)))) + (uffi:with-foreign-object (rowcount 'ub4) + (oci-attr-get (deref-vp (qc-stmthp qc)) + +oci-htype-stmt+ + rowcount + +unsigned-int-null-pointer+ + +oci-attr-row-count+ + (deref-vp errhp)) + (setf (qc-n-from-oci qc) + (- (uffi:deref-pointer rowcount 'ub4) + (qc-total-n-from-oci qc))) + (when (< (qc-n-from-oci qc) +n-buf-rows+) + (setf (qc-oci-end-seen-p qc) t)) + (setf (qc-total-n-from-oci qc) + (uffi:deref-pointer rowcount 'ub4))))) + (values))) + +;; the guts of the SQL function +;; +;; (like the SQL function, but with the QUERY argument hardwired to T, so +;; that the return value is always a cursor instead of a list) + +;; Is this a SELECT statement? SELECT statements are handled +;; specially by OCIStmtExecute(). (Non-SELECT statements absolutely +;; require a nonzero iteration count, while the ordinary choice for a +;; SELECT statement is a zero iteration count. + +;; SELECT statements are the only statements which return tables. We +;; don't free STMTHP in this case, but instead give it to the new +;; QUERY-CURSOR, and the new QUERY-CURSOR becomes responsible for +;; freeing the STMTHP when it is no longer needed. + +(defun sql-stmt-exec (sql-stmt-string db result-types field-names) + (with-slots (envhp svchp errhp) db + (uffi:with-foreign-strings ((c-stmt-string sql-stmt-string)) + (let ((stmthp (uffi:allocate-foreign-object :pointer-void)) + select-p) + + (uffi:with-foreign-object (stmttype :unsigned-short) + (unwind-protect + (progn + (oci-handle-alloc (deref-vp envhp) + stmthp + +oci-htype-stmt+ 0 +null-void-pointer-pointer+) + (oci-stmt-prepare (deref-vp stmthp) + (deref-vp errhp) + c-stmt-string + (uffi:foreign-string-length c-stmt-string) + +oci-ntv-syntax+ +oci-default+ :database db) + (oci-attr-get (deref-vp stmthp) + +oci-htype-stmt+ + stmttype + +unsigned-int-null-pointer+ + +oci-attr-stmt-type+ + (deref-vp errhp) + :database db) + + (setq select-p (= (uffi:deref-pointer stmttype :unsigned-short) 1)) + (let ((iters (if select-p 0 1))) + + (oci-stmt-execute (deref-vp svchp) + (deref-vp stmthp) + (deref-vp errhp) + iters 0 +null-void-pointer+ +null-void-pointer+ +oci-default+ + :database db))) + ;; free resources unless a query + (unless select-p + (oci-handle-free (deref-vp stmthp) +oci-htype-stmt+) + (uffi:free-foreign-object stmthp)))) + + (cond + (select-p + (make-query-cursor db stmthp result-types field-names)) + (t + nil)))))) + + +;; Return a QUERY-CURSOR representing the table returned from the OCI +;; operation done through STMTHP. TYPES is the argument of the same +;; name from the external SQL function, controlling type conversion +;; of the returned arguments. + +(defun make-query-cursor (db stmthp result-types field-names) + (let ((qc (%make-query-cursor :db db + :stmthp stmthp + :cds (make-query-cursor-cds db stmthp + result-types + field-names)))) + (refill-qc-buffers qc) + qc)) + + +;; the hairy part of MAKE-QUERY-CURSOR: Ask OCI for information +;; about table columns, translate the information into a Lisp +;; vector of column descriptors, and return it. + +;; Allegro defines several flavors of type conversion, but this +;; implementation only supports the :AUTO flavor. + +;; A note of explanation: OCI's internal number format uses 21 +;; bytes (42 decimal digits). 2 separate (?) one-byte fields, +;; scale and precision, are used to deduce the nature of these +;; 21 bytes. See pp. 3-10, 3-26, and 6-13 of OCI documentation +;; for more details. + +;; Mac OS X Note: According to table 6-8 in the Oracle 9i OCI +;; documentation, PRECISION may actually be an sb2 instead of a +;; single byte if performing an "implicit describe". Using a +;; signed short instead of an unsigned byte fixes a Mac OS X bug +;; where PRECISION is always zero. -- JJB 20040713 + +;; When calling OCI C code to handle the conversion, we have +;; only two numeric types available to pass the return value: +;; double-float and signed-long. It would be possible to +;; bypass the OCI conversion functions and write Lisp code +;; which reads the 21-byte field directly and decodes +;; it. However this is left as an exercise for the reader. :-) + +;; The following table describes the mapping, based on the implicit +;; assumption that C's "signed long" type is a 32-bit integer. +;; +;; Internal Values SQL Type C Return Type +;; =============== ======== ============= +;; Precision > 0 SCALE = -127 FLOAT --> double-float +;; Precision > 0 && <=9 SCALE = 0 INTEGER --> signed-long +;; Precision = 0 || > 9 SCALE = 0 BIG INTEGER --> double-float +;; Precision > 0 SCALE > 0 DECIMAL --> double-float + +;; (OCI uses 1-based indexing here.) + +;; KLUDGE: This should work for all other data types except those +;; which don't actually fit in their fixed-width field (BLOBs and the +;; like). As Winton says, we (Cadabra) don't need to worry much about +;; those, since we can't reason with them, so we don't use them. But +;; for a more general application it'd be good to have a more +;; selective and rigorously correct test here for whether we can +;; actually handle the given DEREF-DTYPE value. -- WHN 20000106 + +;; Note: The OCI documentation doesn't seem to say whether the COLNAME +;; value returned here is a newly-allocated copy which we're +;; responsible for freeing, or a pointer into some system copy which +;; will be freed when the system itself is shut down. But judging +;; from the way that the result is used in the cdemodsa.c example +;; program, it looks like the latter: we should make our own copy of +;; the value, but not try to free it. + +;; WORKAROUND: OCI seems to return ub2 values for the +;; +oci-attr-data-size+ attribute even though its documentation claims +;; that it returns a ub4, and even though the associated "sizep" value +;; is 4, not 2. In order to make the code here work reliably, without +;; having to patch it later if OCI is ever fixed to match its +;; documentation, we pre-zero COLSIZE before making the call into OCI. + +;; To exercise the weird OCI behavior (thereby blowing up the code +;; below, beware!) try setting this value into COLSIZE, calling OCI, +;; then looking at the value in COLSIZE. (setf colsize #x12345678) +;; debugging only + +;; Mac OS X Note: This workaround fails on a bigendian platform so +;; I've changed the data type of COLNAME to :unsigned-short as per +;; the Oracle 9i OCI documentation. -- JJB 20040713 + +(uffi:def-type byte-pointer (* :byte)) +(uffi:def-type void-pointer-pointer (* :void-pointer)) + +(defun make-query-cursor-cds (database stmthp result-types field-names) + (declare (optimize (safety 3) #+nil (speed 3)) + (type oracle-database database) + (type pointer-pointer-void stmthp)) + (with-slots (errhp) database + (uffi:with-foreign-objects ((dtype-foreign :unsigned-short) + (parmdp :pointer-void) + (precision :short) + (scale :byte) + (colname '(* :unsigned-char)) + (colnamelen 'ub4) + (colsize 'ub2) + (defnp ':pointer-void)) + (let ((buffer nil) + (sizeof nil)) + (do ((icolumn 0 (1+ icolumn)) + (cds-as-reversed-list nil)) + ((not (eql (oci-param-get (deref-vp stmthp) + +oci-htype-stmt+ + (deref-vp errhp) + parmdp + (1+ icolumn) :database database) + +oci-success+)) + (coerce (reverse cds-as-reversed-list) 'simple-vector)) + ;; Decode type of ICOLUMNth column into a type we're prepared to + ;; handle in Lisp. + (oci-attr-get (deref-vp parmdp) + +oci-dtype-param+ + dtype-foreign + +unsigned-int-null-pointer+ + +oci-attr-data-type+ + (deref-vp errhp)) + (let ((dtype (uffi:deref-pointer dtype-foreign :unsigned-short))) + (declare (fixnum dtype)) + (case dtype + (#.SQLT-DATE + (setf buffer (acquire-foreign-resource :unsigned-char + (* 32 +n-buf-rows+))) + (setf sizeof 32 dtype #.SQLT-STR)) + (#.SQLT-NUMBER + (oci-attr-get (deref-vp parmdp) + +oci-dtype-param+ + precision + +unsigned-int-null-pointer+ + +oci-attr-precision+ + (deref-vp errhp)) + (oci-attr-get (deref-vp parmdp) + +oci-dtype-param+ + scale + +unsigned-int-null-pointer+ + +oci-attr-scale+ + (deref-vp errhp)) + (let ((*scale (uffi:deref-pointer scale :byte)) + (*precision (uffi:deref-pointer precision :short))) + + ;;(format t "scale=~d, precision=~d~%" *scale *precision) + (cond + ((or (and (minusp *scale) (zerop *precision)) + (and (zerop *scale) (plusp *precision))) + (setf buffer (acquire-foreign-resource :int +n-buf-rows+) + sizeof 4 ;; sizeof(int) + dtype #.SQLT-INT)) + (t + (setf buffer (acquire-foreign-resource :double +n-buf-rows+) + sizeof 8 ;; sizeof(double) + dtype #.SQLT-FLT))))) + ;; Default to SQL-STR + (t + (setf (uffi:deref-pointer colsize :unsigned-short) 0) + (setf dtype #.SQLT-STR) + (oci-attr-get (deref-vp parmdp) + +oci-dtype-param+ + colsize + +unsigned-int-null-pointer+ + +oci-attr-data-size+ + (deref-vp errhp)) + (let ((colsize-including-null (1+ (uffi:deref-pointer colsize :unsigned-short)))) + (setf buffer (acquire-foreign-resource + :unsigned-char (* +n-buf-rows+ colsize-including-null))) + (setf sizeof colsize-including-null)))) + (let ((retcodes (acquire-foreign-resource :unsigned-short +n-buf-rows+)) + (indicators (acquire-foreign-resource :short +n-buf-rows+)) + (colname-string "")) + (when field-names + (oci-attr-get (deref-vp parmdp) + +oci-dtype-param+ + colname + colnamelen + +oci-attr-name+ + (deref-vp errhp)) + (setq colname-string (uffi:convert-from-foreign-string + (uffi:deref-pointer colname '(* :unsigned-char)) + :length (uffi:deref-pointer colnamelen 'ub4) + :encoding (encoding database)))) + (push (make-cd :name colname-string + :sizeof sizeof + :buffer buffer + :oci-data-type dtype + :retcodes retcodes + :indicators indicators + :result-type (cond + ((consp result-types) + (nth icolumn result-types)) + ((null result-types) + :string) + (t + result-types))) + cds-as-reversed-list) + (oci-define-by-pos (deref-vp stmthp) + defnp + (deref-vp errhp) + (1+ icolumn) ; OCI 1-based indexing again + (foreign-resource-buffer buffer) + sizeof + dtype + (foreign-resource-buffer indicators) + +unsigned-short-null-pointer+ + (foreign-resource-buffer retcodes) + +oci-default+)))))))) + +;; Release the resources associated with a QUERY-CURSOR. + +(defun close-query (qc) + (oci-handle-free (deref-vp (qc-stmthp qc)) +oci-htype-stmt+) + (uffi:free-foreign-object (qc-stmthp qc)) + (let ((cds (qc-cds qc))) + (dotimes (i (length cds)) + (release-cd-resources (aref cds i)))) + (values)) + + +;; Release the resources associated with a column description. + +(defun release-cd-resources (cd) + (free-foreign-resource (cd-buffer cd)) + (free-foreign-resource (cd-retcodes cd)) + (free-foreign-resource (cd-indicators cd)) + (values)) + + +(defmethod database-name-from-spec (connection-spec (database-type (eql :oracle))) + (check-connection-spec connection-spec database-type (dsn user password)) + (destructuring-bind (dsn user password) connection-spec + (declare (ignore password)) + (concatenate 'string dsn "/" user))) + + +(defmethod database-connect (connection-spec (database-type (eql :oracle))) + (check-connection-spec connection-spec database-type (dsn user password)) + (destructuring-bind (data-source-name user password) + connection-spec + (let ((envhp (uffi:allocate-foreign-object :pointer-void)) + (errhp (uffi:allocate-foreign-object :pointer-void)) + (svchp (uffi:allocate-foreign-object :pointer-void)) + (srvhp (uffi:allocate-foreign-object :pointer-void))) + ;; Requests to allocate environments and handles should never + ;; fail in normal operation, and they're done too early to + ;; handle errors very gracefully (since they're part of the + ;; error-handling mechanism themselves) so we just assert they + ;; work. + + (setf (deref-vp envhp) +null-void-pointer+) + + #-oci7 + (oci-env-create envhp +oci-default+ +null-void-pointer+ + +null-void-pointer+ +null-void-pointer+ + +null-void-pointer+ 0 +null-void-pointer-pointer+) + + #+oci7 + (progn + (oci-initialize +oci-object+ +null-void-pointer+ +null-void-pointer+ + +null-void-pointer+ +null-void-pointer-pointer+) + (ignore-errors (oci-handle-alloc +null-void-pointer+ envhp + +oci-htype-env+ 0 + +null-void-pointer-pointer+)) ;no testing return + (oci-env-init envhp +oci-default+ 0 +null-void-pointer-pointer+)) + + (oci-handle-alloc (deref-vp envhp) errhp + +oci-htype-error+ 0 +null-void-pointer-pointer+) + (oci-handle-alloc (deref-vp envhp) srvhp + +oci-htype-server+ 0 +null-void-pointer-pointer+) + + (let ((db (make-instance 'oracle-database + :name (database-name-from-spec connection-spec + database-type) + :connection-spec connection-spec + :envhp envhp + :errhp errhp + :database-type :oracle + :svchp svchp + :dsn data-source-name + :user user))) + (uffi:with-foreign-strings ((c-user user) + (c-password password) + (c-data-source-name data-source-name)) + (oci-logon (deref-vp envhp) + (deref-vp errhp) + svchp + c-user (length user) + c-password (length password) + c-data-source-name (length data-source-name) + :database db)) + ;; :date-format-length (1+ (length date-format))))) + (setf (slot-value db 'clsql-sys::state) :open) + (database-execute-command + (format nil "ALTER SESSION SET NLS_DATE_FORMAT='~A'" (date-format db)) db) + (let ((server-version + (caar (database-query + "SELECT BANNER FROM V$VERSION WHERE BANNER LIKE '%Oracle%'" db nil nil)))) + (setf (slot-value db 'server-version) server-version + (slot-value db 'major-server-version) (major-client-version-from-string + server-version))) + db)))) + + +(defun major-client-version-from-string (str) + (cond + ((search " 10g " str) + 10) + ((search "Oracle9i " str) + 9) + ((search "Oracle8" str) + 8))) + +(defun major-server-version-from-string (str) + (when (> (length str) 2) + (cond + ((string= "10." (subseq str 0 3)) + 10) + ((string= "9." (subseq str 0 2)) + 9) + ((string= "8." (subseq str 0 2)) + 8)))) + + +;; Close a database connection. + +(defmethod database-disconnect ((database oracle-database)) + (osucc (oci-logoff (deref-vp (svchp database)) + (deref-vp (errhp database)))) + (osucc (oci-handle-free (deref-vp (envhp database)) +oci-htype-env+)) + ;; Note: It's neither required nor allowed to explicitly deallocate the + ;; ERRHP handle here, since it's owned by the ENVHP deallocated above, + ;; and was therefore automatically deallocated at the same time. + t) + +;;; Do the database operation described in SQL-STMT-STRING on database +;;; DB and, if the command is a SELECT, return a representation of the +;;; resulting table. The representation of the table is controlled by the +;;; QUERY argument: +;;; * If QUERY is NIL, the table is returned as a list of rows, with +;;; each row represented by a list. +;;; * If QUERY is non-NIL, the result is returned as a QUERY-CURSOR +;;; suitable for FETCH-ROW and CLOSE-QUERY +;;; The TYPES argument controls the type conversion method used +;;; to construct the table. The Allegro version supports several possible +;;; values for this argument, but we only support :AUTO. + +(defmethod database-query (query-expression (database oracle-database) result-types field-names) + (let ((cursor (sql-stmt-exec query-expression database result-types field-names))) + ;; (declare (type (or query-cursor null) cursor)) + (if (null cursor) ; No table was returned. + (values) + (do ((reversed-result nil)) + (nil) + (let* ((eof-value :eof) + (row (fetch-row cursor nil eof-value (encoding database)))) + (when (eq row eof-value) + (close-query cursor) + (if field-names + (return (values (nreverse reversed-result) + (loop for cd across (qc-cds cursor) + collect (cd-name cd)))) + (return (nreverse reversed-result)))) + (push row reversed-result)))))) + + +(defmethod database-create-sequence (sequence-name (database oracle-database)) + (execute-command + (concatenate 'string "CREATE SEQUENCE " (sql-escape sequence-name)) + :database database)) + +(defmethod database-drop-sequence (sequence-name (database oracle-database)) + (execute-command + (concatenate 'string "DROP SEQUENCE " (sql-escape sequence-name)) + :database database)) + +(defmethod database-sequence-next (sequence-name (database oracle-database)) + (caar (database-query + (concatenate 'string "SELECT " + (sql-escape sequence-name) + ".NEXTVAL FROM dual") + database :auto nil))) + +(defmethod database-sequence-last (sequence-name (database oracle-database)) + (caar (database-query + (concatenate 'string "SELECT " + (sql-escape sequence-name) + ".CURRVAL FROM dual") + database :auto nil))) + +(defmethod database-set-sequence-position (name position (database oracle-database)) + (without-interrupts + (let* ((next (database-sequence-next name database)) + (incr (- position next))) + (unless (zerop incr) + (database-execute-command + (format nil "ALTER SEQUENCE ~A INCREMENT BY ~D" name incr) + database)) + (database-sequence-next name database) + (database-execute-command + (format nil "ALTER SEQUENCE ~A INCREMENT BY 1" name) + database)))) + +(defmethod database-list-sequences ((database oracle-database) &key owner) + (let ((query + (cond ((null owner) + "select sequence_name from user_sequences") + ((eq owner :all) + "select sequence_name from all_sequences") + (t + (format nil + "select user_sequences.sequence_name from user_sequences,all_sequences where user_sequences.sequence_name=all_sequences.sequence_name and all_sequences.sequence_owner='~:@(~A~)'" + owner))))) + (mapcar #'car (database-query query database nil nil)))) + +(defmethod database-execute-command (sql-expression (database oracle-database)) + (database-query sql-expression database nil nil) + (when (database-autocommit database) + (oracle-commit database)) + t) + + +(defstruct (cd (:constructor make-cd) + (:print-function print-cd)) + "a column descriptor: metadata about the data in a table" + + ;; name of this column + (name (error "missing NAME") :type simple-string :read-only t) + ;; the size in bytes of a single element + (sizeof (error "missing SIZE") :type fixnum :read-only t) + ;; an array of +N-BUF-ROWS+ elements in C representation + (buffer (error "Missing BUFFER") + :type foreign-resource + :read-only t) + ;; an array of +N-BUF-ROWS+ OCI return codes in C representation. + ;; (There must be one return code for every element of every + ;; row in order to be able to represent nullness.) + (retcodes (error "Missing RETCODES") + :type foreign-resource + :read-only t) + (indicators (error "Missing INDICATORS") + :type foreign-resource + :read-only t) + ;; the OCI code for the data type of a single element + (oci-data-type (error "missing OCI-DATA-TYPE") + :type fixnum + :read-only t) + (result-type (error "missing RESULT-TYPE") + :read-only t)) + + +(defun print-cd (cd stream depth) + (declare (ignore depth)) + (print-unreadable-object (cd stream :type t) + (format stream + ":NAME ~S :OCI-DATA-TYPE ~S :OCI-DATA-SIZE ~S" + (cd-name cd) + (cd-oci-data-type cd) + (cd-sizeof cd)))) + +(defun print-query-cursor (qc stream depth) + (declare (ignore depth)) + (print-unreadable-object (qc stream :type t :identity t) + (prin1 (qc-db qc) stream))) + + +(defmethod database-query-result-set ((query-expression string) + (database oracle-database) + &key full-set result-types) + (let ((cursor (sql-stmt-exec query-expression database result-types nil))) + (if full-set + (values cursor (length (qc-cds cursor)) nil) + (values cursor (length (qc-cds cursor)))))) + + +(defmethod database-dump-result-set (result-set (database oracle-database)) + (close-query result-set)) + +(defmethod database-store-next-row (result-set (database oracle-database) list) + (let* ((eof-value :eof) + (row (fetch-row result-set nil eof-value (encoding database)))) + (unless (eq eof-value row) + (loop for i from 0 below (length row) + do (setf (nth i list) (nth i row))) + list))) + +(defmethod database-start-transaction ((database oracle-database)) + (call-next-method) + ;; Not needed with simple transaction + #+ignore + (with-slots (svchp errhp) database + (oci-trans-start (deref-vp svchp) + (deref-vp errhp) + 60 + +oci-trans-new+)) + t) + + +(defun oracle-commit (database) + (with-slots (svchp errhp) database + (osucc (oci-trans-commit (deref-vp svchp) + (deref-vp errhp) + 0)))) + +(defmethod database-commit-transaction ((database oracle-database)) + (call-next-method) + (oracle-commit database) + t) + +(defmethod database-abort-transaction ((database oracle-database)) + (call-next-method) + (osucc (oci-trans-rollback (deref-vp (svchp database)) + (deref-vp (errhp database)) + 0)) + t) + +;; Specifications + +(defmethod db-type-has-bigint? ((type (eql :oracle))) + nil) + +(defmethod db-type-has-fancy-math? ((db-type (eql :oracle))) + t) + +(defmethod db-type-has-boolean-where? ((db-type (eql :oracle))) + nil) + +(when (clsql-sys:database-type-library-loaded :oracle) + (clsql-sys:initialize-database-type :database-type :oracle)) diff --git a/db-postgresql-socket/Makefile b/db-postgresql-socket/Makefile new file mode 100644 index 0000000..31dc910 --- /dev/null +++ b/db-postgresql-socket/Makefile @@ -0,0 +1,6 @@ +SUBDIRS := + +include ../Makefile.common + +.PHONY: distclean +distclean: clean diff --git a/db-postgresql-socket/postgresql-socket-api.lisp b/db-postgresql-socket/postgresql-socket-api.lisp new file mode 100644 index 0000000..40dc86a --- /dev/null +++ b/db-postgresql-socket/postgresql-socket-api.lisp @@ -0,0 +1,973 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: postgresql-socket-api.lisp +;;;; Purpose: Low-level PostgreSQL interface using sockets +;;;; Authors: Kevin M. Rosenberg based on original code by Pierre R. Mai +;;;; Created: Feb 2002 +;;;; +;;;; This file, part of CLSQL, is Copyright (c) 2002-2010 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 #:postgresql-socket) + +;; KMR: 2011-06-12 +;; FIXME: The file has code specific to sb-unicode and CCL +;; to assume UTF8 encoded strings. +;; Best fix would be to use the user-specified encoding that is now +;; stored in the database object and use the UFFI 2.x encoding functions +;; to convert strings to/from octet vectors. This allows encoding +;; other than UTF8 and also works on all CL implementations that +;; support wide character strings + +(uffi:def-enum pgsql-ftype + ((:bytea 17) + (:int2 21) + (:int4 23) + (:int8 20) + (:float4 700) + (:float8 701))) + +(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-sys:database-type-load-foreign ((database-type (eql :postgresql-socket))) + t) + + +;;; Message I/O stuff + +(defmacro define-message-constants (description &rest clauses) + (assert (evenp (length clauses))) + (loop with seen-characters = nil + for (name char) on clauses by #'cddr + for char-code = (char-code char) + for doc-string = (format nil "~A (~:C): ~A" description char name) + if (member char seen-characters) + do (error "Duplicate message type ~@C for group ~A" char description) + else + collect + `(defconstant ,name ,char-code ,doc-string) + into result-clauses + and do (push char seen-characters) + finally + (return `(progn ,@result-clauses)))) + +(eval-when (:compile-toplevel :load-toplevel :execute) +(define-message-constants "Backend Message Constants" + +ascii-row-message+ #\D + +authentication-message+ #\R + +backend-key-message+ #\K + +binary-row-message+ #\B + +completed-response-message+ #\C + +copy-in-response-message+ #\G + +copy-out-response-message+ #\H + +cursor-response-message+ #\P + +empty-query-response-message+ #\I + +error-response-message+ #\E + +function-response-message+ #\V + +notice-response-message+ #\N + +notification-response-message+ #\A + +ready-for-query-message+ #\Z + +row-description-message+ #\T)) + +#+scl +(declaim (inline read-byte write-byte)) + +(defun send-socket-value-int32 (socket value) + (declare (type stream socket) + (type (unsigned-byte 32) value)) + (write-byte (ldb (byte 8 24) value) socket) + (write-byte (ldb (byte 8 16) value) socket) + (write-byte (ldb (byte 8 8) value) socket) + (write-byte (ldb (byte 8 0) value) socket) + nil) + +(defun send-socket-value-int16 (socket value) + (declare (type stream socket) + (type (unsigned-byte 16) value)) + (write-byte (ldb (byte 8 8) value) socket) + (write-byte (ldb (byte 8 0) value) socket) + nil) + +(defun send-socket-value-int8 (socket value) + (declare (type stream socket) + (type (unsigned-byte 8) value)) + (write-byte (ldb (byte 8 0) value) socket) + nil) + +(defun send-socket-value-char-code (socket value) + (declare (type stream socket) + (type character value)) + (write-byte (ldb (byte 8 0) (char-code value)) socket) + nil) + +(defun send-socket-value-string (socket value) + (declare (type stream socket) + (type string value)) + #-(or sb-unicode ccl) + (loop for char across value + for code = (char-code char) + do (write-byte code socket) + finally (write-byte 0 socket)) + #+ccl + (write-sequence (ccl:encode-string-to-octets + value :external-format :utf-8) socket) + #+ccl + (write-byte 0 socket) + #+sb-unicode + (write-sequence (sb-ext:string-to-octets value :null-terminate t) + socket) + nil) + +(defun send-socket-value-limstring (socket value limit) + (declare (type stream socket) + (type string value) + (type fixnum limit)) + (let ((length (length value))) + (dotimes (i (min length limit)) + (let ((code (char-code (char value i)))) + (write-byte code socket))) + (dotimes (i (- limit length)) + (write-byte 0 socket))) + nil) + + +(defun read-socket-value-int32 (socket) + (declare (type stream socket)) + (declare (optimize (speed 3))) + (let ((result 0)) + (declare (type (unsigned-byte 32) result)) + (setf (ldb (byte 8 24) result) (read-byte socket)) + (setf (ldb (byte 8 16) result) (read-byte socket)) + (setf (ldb (byte 8 8) result) (read-byte socket)) + (setf (ldb (byte 8 0) result) (read-byte socket)) + result)) + +(defun read-socket-value-int16 (socket) + (declare (type stream socket)) + (let ((result 0)) + (declare (type (unsigned-byte 16) result)) + (setf (ldb (byte 8 8) result) (read-byte socket)) + (setf (ldb (byte 8 0) result) (read-byte socket)) + result)) + +(defun read-socket-value-int8 (socket) + (declare (type stream socket)) + (read-byte socket)) + + +(defun read-socket-value-string (socket) + (declare (type stream socket)) + #-(or sb-unicode ccl) + (with-output-to-string (out) + (loop for code = (read-byte socket) + until (zerop code) + do (write-char (code-char code) out))) + #+ccl + (let ((bytes (make-array 64 + :element-type '(unsigned-byte 8) + :adjustable t + :fill-pointer 0))) + (loop for code = (read-byte socket) + until (zerop code) + do (vector-push-extend code bytes)) + (ccl:decode-string-from-octets bytes :external-format :utf-8)) + #+sb-unicode + (let ((bytes (make-array 64 + :element-type '(unsigned-byte 8) + :adjustable t + :fill-pointer 0))) + (loop for code = (read-byte socket) + until (zerop code) + do (vector-push-extend code bytes)) + (sb-ext:octets-to-string bytes))) + +(defmacro define-message-sender (name (&rest args) &rest clauses) + (let ((socket-var (gensym)) + (body nil)) + (dolist (clause clauses) + (let* ((type (first clause)) + (fn (intern (concatenate 'string (symbol-name '#:send-socket-value-) + (symbol-name type))))) + (push `(,fn ,socket-var ,@(rest clause)) body))) + `(defun ,name (,socket-var ,@args) + ,@(nreverse body)))) + +(define-message-sender send-startup-message + (database user &optional (command-line "") (backend-tty "")) + (int32 296) ; Length + (int32 #x00020000) ; Version 2.0 + (limstring database 64) + (limstring user 32) + (limstring command-line 64) + (limstring "" 64) ; Unused + (limstring backend-tty 64)) + +(define-message-sender send-terminate-message () + (char-code #\X)) + +(define-message-sender send-unencrypted-password-message (password) + (int32 (+ 5 (length password))) + (string password)) + +(define-message-sender send-query-message (query) + (char-code #\Q) + (string query)) + +(define-message-sender send-encrypted-password-message (crypted-password) + (int32 (+ 5 (length crypted-password))) + (string crypted-password)) + +(define-message-sender send-cancel-request (pid key) + (int32 16) ; Length + (int32 80877102) ; Magic + (int32 pid) + (int32 key)) + +(defun read-bytes (socket length) + "Read a byte array of the given length from a stream." + (declare (type stream socket) + (type fixnum length) + (optimize (speed 3) (safety 0))) + (let ((result (make-array length :element-type '(unsigned-byte 8)))) + (read-sequence result socket) + result)) + +(defun read-socket-sequence (stream length &optional (allow-wide t)) + (declare (stream stream) + (optimize (speed 3) (safety 0))) + #-(or sb-unicode ccl) + (let ((result (make-string length))) + (dotimes (i length result) + (declare (fixnum i)) + (setf (char result i) (code-char (read-byte stream))))) + #+ccl + (let ((bytes (make-array length :element-type '(unsigned-byte 8)))) + (declare (type (simple-array (unsigned-byte 8) (*)) bytes)) + (read-sequence bytes stream) + (if allow-wide + (ccl:decode-string-from-octets bytes :external-format :utf-8) + (map 'string #'code-char bytes))) + #+sb-unicode + (let ((bytes (make-array length :element-type '(unsigned-byte 8)))) + (declare (type (simple-array (unsigned-byte 8) (*)) bytes)) + (read-sequence bytes stream) + (if allow-wide + (sb-ext:octets-to-string bytes) + (map 'string #'code-char bytes)))) + +;;; Support for encrypted password transmission + +#-scl +(eval-when (:compile-toplevel :load-toplevel :execute) + (defvar *crypt-library-loaded* nil) + + (unless *crypt-library-loaded* + (uffi:load-foreign-library + (uffi:find-foreign-library "libcrypt" + '(#+(or 64bit x86-64) "/usr/lib64/" + "/usr/lib/" "/usr/local/lib/" "/lib/")) + :supporting-libraries '("c")) + (setq *crypt-library-loaded* t))) + +(in-package :postgresql-socket) + +(uffi:def-function ("crypt" crypt) + ((key :cstring) + (salt :cstring)) + :returning :cstring) + +(defun crypt-password (password salt) + "Encrypt a password for transmission to a PostgreSQL server." + (uffi:with-cstring (password-cstring password) + (uffi:with-cstring (salt-cstring salt) + (uffi:convert-from-cstring + (crypt password-cstring salt-cstring))))) + + +;;;; Condition hierarchy + +(define-condition postgresql-condition (condition) + ((connection :initarg :connection :reader postgresql-condition-connection) + (message :initarg :message :reader postgresql-condition-message)) + (:report + (lambda (c stream) + (format stream "~@<~A occurred on connection ~A. ~:@_Reason: ~A~:@>" + (type-of c) + (postgresql-condition-connection c) + (postgresql-condition-message c))))) + +(define-condition postgresql-error (error postgresql-condition) + ()) + +(define-condition postgresql-fatal-error (postgresql-error) + ()) + +(define-condition postgresql-login-error (postgresql-fatal-error) + ()) + +(define-condition postgresql-warning (warning postgresql-condition) + ()) + +(define-condition postgresql-notification (postgresql-condition) + () + (:report + (lambda (c stream) + (format stream "~@<Asynchronous notification on connection ~A: ~:@_~A~:@>" + (postgresql-condition-connection c) + (postgresql-condition-message c))))) + +;;; Structures + +(defstruct postgresql-connection + host + port + database + user + password + options + tty + socket + pid + key) + +(defstruct postgresql-cursor + connection + name + fields) + +;;; Socket stuff + +(defconstant +postgresql-server-default-port+ 5432 + "Default port of PostgreSQL server.") + +(defvar *postgresql-server-socket-timeout* 60 + "Timeout in seconds for reads from the PostgreSQL server.") + +#+(or cmu scl) +(defun open-postgresql-socket (host port) + (etypecase host + (pathname + ;; Directory to unix-domain socket + (ext:connect-to-unix-socket + (namestring + (make-pathname :name ".s.PGSQL" :type (princ-to-string port) + :defaults host)))) + (string + (ext:connect-to-inet-socket host port)))) + +#+sbcl +(defun open-postgresql-socket (host port) + (etypecase host + (pathname + ;; Directory to unix-domain socket + (let ((sock (make-instance 'sb-bsd-sockets:local-socket + :type :stream))) + (sb-bsd-sockets:socket-connect + sock + (namestring + (make-pathname :name ".s.PGSQL" :type (princ-to-string port) + :defaults host))) + sock)) + (string + (let ((sock (make-instance 'sb-bsd-sockets:inet-socket + :type :stream + :protocol :tcp))) + (sb-bsd-sockets:socket-connect + sock + (sb-bsd-sockets:host-ent-address + (sb-bsd-sockets:get-host-by-name host)) + port) + sock)))) + +#+(or cmu scl) +(defun open-postgresql-socket-stream (host port) + (system:make-fd-stream + (open-postgresql-socket host port) + :input t :output t :element-type '(unsigned-byte 8) + :buffering :none + :timeout *postgresql-server-socket-timeout*)) + + +#+sbcl +(defun open-postgresql-socket-stream (host port) + (sb-bsd-sockets:socket-make-stream + (open-postgresql-socket host port) :input t :output t + :element-type '(unsigned-byte 8))) + + +#+allegro +(defun open-postgresql-socket-stream (host port) + (etypecase host + (pathname + (let ((path (namestring + (make-pathname :name ".s.PGSQL" :type (princ-to-string port) + :defaults host)))) + (socket:make-socket :type :stream :address-family :file + :connect :active + :remote-filename path :local-filename path))) + (string + (socket:with-pending-connect + (mp:with-timeout (*postgresql-server-socket-timeout* (error "connect failed")) + (socket:make-socket :type :stream :address-family :internet + :remote-port port :remote-host host + :connect :active :nodelay t)))))) + +#+openmcl +(defun open-postgresql-socket-stream (host port) + (etypecase host + (pathname + (let ((path (namestring + (make-pathname :name ".s.PGSQL" :type (princ-to-string port) + :defaults host)))) + (ccl:make-socket :type :stream :address-family :file + :connect :active + :remote-filename path :local-filename path))) + (string + (ccl:make-socket :type :stream :address-family :internet + :remote-port port :remote-host host + :connect :active :nodelay t)))) + +#+lispworks +(defun open-postgresql-socket-stream (host port) + (etypecase host + (pathname + (error "File sockets not supported on Lispworks.")) + (string + (comm:open-tcp-stream host port :direction :io :element-type '(unsigned-byte 8) + :read-timeout *postgresql-server-socket-timeout*)) + )) + + +#+clisp +(defun open-postgresql-socket-stream (host port) + (etypecase host + (pathname + (error "Not supported")) + (string + (socket:socket-connect + port host + :element-type '(unsigned-byte 8) + :timeout *postgresql-server-socket-timeout*)))) + + +;;; Interface Functions + +(defun open-postgresql-connection (&key (host (cmucl-compat:required-argument)) + (port +postgresql-server-default-port+) + (database (cmucl-compat:required-argument)) + (user (cmucl-compat:required-argument)) + options tty password) + "Open a connection to a PostgreSQL server with the given parameters. +Note that host, database and user arguments must be supplied. + +If host is a pathname, it is assumed to name a directory containing +the local unix-domain sockets of the server, with port selecting which +of those sockets to open. If host is a string, it is assumed to be +the name of the host running the PostgreSQL server. In that case a +TCP connection to the given port on that host is opened in order to +communicate with the server. In either case the port argument +defaults to `+postgresql-server-default-port+'. + +Password is the clear-text password to be passed in the authentication +phase to the server. Depending on the server set-up, it is either +passed in the clear, or encrypted via crypt and a server-supplied +salt. In that case the alien function specified by `*crypt-library*' +and `*crypt-function-name*' is used for encryption. + +Note that all the arguments (including the clear-text password +argument) are stored in the `postgresql-connection' structure, in +order to facilitate automatic reconnection in case of communication +troubles." + (reopen-postgresql-connection + (make-postgresql-connection :host host :port port + :options (or options "") :tty (or tty "") + :database database :user user + :password (or password "")))) + +(defun byte-sequence-to-hex-string (sequence) + (string-downcase (format nil "~{~2,'0X~}" (coerce sequence 'list)))) + +(defun encrypt-password-md5 (password user salt) + (let ((pass1 (byte-sequence-to-hex-string + (md5::md5sum-string (concatenate 'string password user))))) + (byte-sequence-to-hex-string + (md5:md5sum-sequence (concatenate '(vector (unsigned-byte 8)) + (map '(vector (unsigned-byte 8)) #'char-code pass1) + salt))))) + +(defun reopen-postgresql-connection (connection) + "Reopen the given PostgreSQL connection. Closes any existing +connection, if it is still open." + (when (postgresql-connection-open-p connection) + (close-postgresql-connection connection)) + (let ((socket (open-postgresql-socket-stream + (postgresql-connection-host connection) + (postgresql-connection-port connection)))) + (unwind-protect + (progn + (setf (postgresql-connection-socket connection) socket) + (send-startup-message socket + (postgresql-connection-database connection) + (postgresql-connection-user connection) + (postgresql-connection-options connection) + (postgresql-connection-tty connection)) + (force-output socket) + (loop + (case (read-socket-value-int8 socket) + (#.+authentication-message+ + (case (read-socket-value-int32 socket) + (0 (return)) + ((1 2) + (error 'postgresql-login-error + :connection connection + :message + "Postmaster expects unsupported Kerberos authentication.")) + (3 + (send-unencrypted-password-message + socket + (postgresql-connection-password connection)) + (force-output socket)) + (4 + (let ((salt (read-socket-sequence socket 2 nil))) + (send-encrypted-password-message + socket + (crypt-password + (postgresql-connection-password connection) salt))) + (force-output socket)) + (5 + (let ((salt (read-bytes socket 4))) + (let ((pwd (encrypt-password-md5 + (postgresql-connection-password connection) + (postgresql-connection-user connection) + salt))) + (send-encrypted-password-message + socket + (concatenate 'string "md5" pwd)))) + (force-output socket)) + (t + (error 'postgresql-login-error + :connection connection + :message + "Postmaster expects unknown authentication method.")))) + (#.+error-response-message+ + (let ((message (read-socket-value-string socket))) + (error 'postgresql-login-error + :connection connection :message message))) + (t + (error 'postgresql-login-error + :connection connection + :message + "Received garbled message from Postmaster")))) + ;; Start backend communication + (force-output socket) + (loop + (case (read-socket-value-int8 socket) + (#.+backend-key-message+ + (setf (postgresql-connection-pid connection) + (read-socket-value-int32 socket) + (postgresql-connection-key connection) + (read-socket-value-int32 socket))) + (#.+ready-for-query-message+ + (setq socket nil) + (return connection)) + (#.+error-response-message+ + (let ((message (read-socket-value-string socket))) + (error 'postgresql-login-error + :connection connection + :message message))) + (#.+notice-response-message+ + (let ((message (read-socket-value-string socket))) + (warn 'postgresql-warning :connection connection + :message message))) + (t + (error 'postgresql-login-error + :connection connection + :message + "Received garbled message from Postmaster"))))) + (when socket + (close socket))))) + +(defun close-postgresql-connection (connection &optional abort) + (unless abort + (ignore-errors + (send-terminate-message (postgresql-connection-socket connection)))) + (close (postgresql-connection-socket connection))) + +(defun postgresql-connection-open-p (connection) + (let ((socket (postgresql-connection-socket connection))) + (and socket (streamp socket) (open-stream-p socket)))) + +(defun ensure-open-postgresql-connection (connection) + (unless (postgresql-connection-open-p connection) + (reopen-postgresql-connection connection))) + +(defun process-async-messages (connection) + (assert (postgresql-connection-open-p connection)) + ;; Process any asnychronous messages + (loop with socket = (postgresql-connection-socket connection) + while (listen socket) + do + (case (read-socket-value-int8 socket) + (#.+ready-for-query-message+) + (#.+notice-response-message+ + (let ((message (read-socket-value-string socket))) + (warn 'postgresql-warning :connection connection + :message message))) + (#.+notification-response-message+ + (let ((pid (read-socket-value-int32 socket)) + (message (read-socket-value-string socket))) + (when (= pid (postgresql-connection-pid connection)) + (signal 'postgresql-notification :connection connection + :message message)))) + (t + (close-postgresql-connection connection) + (error 'postgresql-fatal-error :connection connection + :message "Received garbled message from backend"))))) + +(defun start-query-execution (connection query) + (ensure-open-postgresql-connection connection) + (process-async-messages connection) + (send-query-message (postgresql-connection-socket connection) query) + (force-output (postgresql-connection-socket connection))) + +(defun wait-for-query-results (connection) + (assert (postgresql-connection-open-p connection)) + (let ((socket (postgresql-connection-socket connection)) + (cursor-name nil) + (error nil)) + (loop + (case (read-socket-value-int8 socket) + (#.+completed-response-message+ + (return (values :completed (read-socket-value-string socket)))) + (#.+cursor-response-message+ + (setq cursor-name (read-socket-value-string socket))) + (#.+row-description-message+ + (let* ((count (read-socket-value-int16 socket)) + (fields + (loop repeat count + collect + (list + (read-socket-value-string socket) + (read-socket-value-int32 socket) + (read-socket-value-int16 socket) + (read-socket-value-int32 socket))))) + (return + (values :cursor + (make-postgresql-cursor :connection connection + :name cursor-name + :fields fields))))) + (#.+copy-in-response-message+ + (return :copy-in)) + (#.+copy-out-response-message+ + (return :copy-out)) + (#.+ready-for-query-message+ + (when error + (error error)) + (return nil)) + (#.+error-response-message+ + (let ((message (read-socket-value-string socket))) + (setq error + (make-condition 'postgresql-error + :connection connection :message message)))) + (#.+notice-response-message+ + (let ((message (read-socket-value-string socket))) + (unless (eq :ignore clsql-sys:*backend-warning-behavior*) + (warn 'postgresql-warning + :connection connection :message message)))) + (#.+notification-response-message+ + (let ((pid (read-socket-value-int32 socket)) + (message (read-socket-value-string socket))) + (when (= pid (postgresql-connection-pid connection)) + (signal 'postgresql-notification :connection connection + :message message)))) + (t + (close-postgresql-connection connection) + (error 'postgresql-fatal-error :connection connection + :message "Received garbled message from backend")))))) + +(defun read-null-bit-vector (socket count) + (let ((result (make-array count :element-type 'bit))) + (dotimes (offset (ceiling count 8)) + (loop with byte = (read-byte socket) + for index from (* offset 8) below (min count (* (1+ offset) 8)) + for weight downfrom 7 + do (setf (aref result index) (ldb (byte 1 weight) byte)))) + result)) + + +(defun read-field (socket type) + (let ((length (- (read-socket-value-int32 socket) 4))) + (case type + ((:int32 :int64) + (read-integer-from-socket socket length)) + (:double + (read-double-from-socket socket length)) + (t + (read-socket-sequence socket length))))) + +(uffi:def-constant +char-code-zero+ (char-code #\0)) +(uffi:def-constant +char-code-minus+ (char-code #\-)) +(uffi:def-constant +char-code-plus+ (char-code #\+)) +(uffi:def-constant +char-code-period+ (char-code #\.)) +(uffi:def-constant +char-code-lower-e+ (char-code #\e)) +(uffi:def-constant +char-code-upper-e+ (char-code #\E)) + +(defun read-integer-from-socket (socket length) + (declare (fixnum length)) + (if (zerop length) + nil + (let ((val 0) + (first-char (read-byte socket)) + (minusp nil)) + (declare (fixnum first-char)) + (decf length) ;; read first char + (cond + ((= first-char +char-code-minus+) + (setq minusp t)) + ((= first-char +char-code-plus+) + ) ;; nothing to do + (t + (setq val (- first-char +char-code-zero+)))) + + (dotimes (i length) + (declare (fixnum i)) + (setq val (+ + (* 10 val) + (- (read-byte socket) +char-code-zero+)))) + (if minusp + (- val) + val)))) + +(defmacro ascii-digit (int) + (let ((offset (gensym))) + `(let ((,offset (- ,int +char-code-zero+))) + (declare (fixnum ,int ,offset)) + (if (and (>= ,offset 0) + (< ,offset 10)) + ,offset + nil)))) + +(defun read-double-from-socket (socket length) + (declare (fixnum length)) + (let ((before-decimal 0) + (after-decimal 0) + (decimal-count 0) + (exponent 0) + (decimalp nil) + (minusp nil) + (result nil) + (char (read-byte socket))) + (declare (fixnum char exponent decimal-count)) + (decf length) ;; already read first character + (cond + ((= char +char-code-minus+) + (setq minusp t)) + ((= char +char-code-plus+) + ) + ((= char +char-code-period+) + (setq decimalp t)) + (t + (setq before-decimal (ascii-digit char)) + (unless before-decimal + (error "Unexpected value")))) + + (block loop + (dotimes (i length) + (setq char (read-byte socket)) + ;; (format t "~&len:~D, i:~D, char:~D, minusp:~A, decimalp:~A" length i char minusp decimalp) + (let ((weight (ascii-digit char))) + (cond + ((and weight (not decimalp)) ;; before decimal point + (setq before-decimal (+ weight (* 10 before-decimal)))) + ((and weight decimalp) ;; after decimal point + (setq after-decimal (+ weight (* 10 after-decimal))) + (incf decimal-count)) + ((and (= char +char-code-period+)) + (setq decimalp t)) + ((or (= char +char-code-lower-e+) ;; E is for exponent + (= char +char-code-upper-e+)) + (setq exponent (read-integer-from-socket socket (- length i 1))) + (setq exponent (or exponent 0)) + (return-from loop)) + (t + (break "Unexpected value")) + ) + ))) + (setq result (* (+ (coerce before-decimal 'double-float) + (* after-decimal + (expt 10 (- decimal-count)))) + (expt 10 exponent))) + (if minusp + (- result) + result))) + + +#+ignore +(defun read-double-from-socket (socket length) + (let ((result (make-string length))) + (read-socket-sequence result socket) + (let ((*read-default-float-format* 'double-float)) + (read-from-string result)))) + +(defun read-cursor-row (cursor types) + (let* ((connection (postgresql-cursor-connection cursor)) + (socket (postgresql-connection-socket connection)) + (fields (postgresql-cursor-fields cursor))) + (assert (postgresql-connection-open-p connection)) + (loop + (let ((code (read-socket-value-int8 socket))) + (case code + (#.+ascii-row-message+ + (return + (loop with count = (length fields) + with null-vector = (read-null-bit-vector socket count) + repeat count + for null-bit across null-vector + for i from 0 + for null-p = (zerop null-bit) + if null-p + collect nil + else + collect + (read-field socket (nth i types))))) + (#.+binary-row-message+ + (error "NYI")) + (#.+completed-response-message+ + (return (values nil (read-socket-value-string socket)))) + (#.+error-response-message+ + (let ((message (read-socket-value-string socket))) + (error 'postgresql-error + :connection connection :message message))) + (#.+notice-response-message+ + (let ((message (read-socket-value-string socket))) + (warn 'postgresql-warning + :connection connection :message message))) + (#.+notification-response-message+ + (let ((pid (read-socket-value-int32 socket)) + (message (read-socket-value-string socket))) + (when (= pid (postgresql-connection-pid connection)) + (signal 'postgresql-notification :connection connection + :message message)))) + (t + (close-postgresql-connection connection) + (error 'postgresql-fatal-error :connection connection + :message "Received garbled message from backend"))))))) + +(defun map-into-indexed (result-seq func seq) + (dotimes (i (length seq)) + (declare (fixnum i)) + (setf (elt result-seq i) + (funcall func (elt seq i) i))) + result-seq) + +(defun copy-cursor-row (cursor sequence types) + (let* ((connection (postgresql-cursor-connection cursor)) + (socket (postgresql-connection-socket connection)) + (fields (postgresql-cursor-fields cursor))) + (assert (= (length fields) (length sequence))) + (loop + (let ((code (read-socket-value-int8 socket))) + (case code + (#.+ascii-row-message+ + (return + #+ignore + (let* ((count (length sequence)) + (null-vector (read-null-bit-vector socket count))) + (dotimes (i count) + (declare (fixnum i)) + (if (zerop (elt null-vector i)) + (setf (elt sequence i) nil) + (let ((value (read-field socket (nth i types)))) + (setf (elt sequence i) value))))) + (map-into-indexed + sequence + #'(lambda (null-bit i) + (if (zerop null-bit) + nil + (read-field socket (nth i types)))) + (read-null-bit-vector socket (length sequence))))) + (#.+binary-row-message+ + (error "NYI")) + (#.+completed-response-message+ + (return (values nil (read-socket-value-string socket)))) + (#.+error-response-message+ + (let ((message (read-socket-value-string socket))) + (error 'postgresql-error + :connection connection :message message))) + (#.+notice-response-message+ + (let ((message (read-socket-value-string socket))) + (warn 'postgresql-warning + :connection connection :message message))) + (#.+notification-response-message+ + (let ((pid (read-socket-value-int32 socket)) + (message (read-socket-value-string socket))) + (when (= pid (postgresql-connection-pid connection)) + (signal 'postgresql-notification :connection connection + :message message)))) + (t + (close-postgresql-connection connection) + (error 'postgresql-fatal-error :connection connection + :message "Received garbled message from backend"))))))) + +(defun skip-cursor-row (cursor) + (let* ((connection (postgresql-cursor-connection cursor)) + (socket (postgresql-connection-socket connection)) + (fields (postgresql-cursor-fields cursor))) + (loop + (let ((code (read-socket-value-int8 socket))) + (case code + (#.+ascii-row-message+ + (loop for null-bit across + (read-null-bit-vector socket (length fields)) + do + (unless (zerop null-bit) + (let* ((length (read-socket-value-int32 socket))) + (loop repeat (- length 4) do (read-byte socket))))) + (return t)) + (#.+binary-row-message+ + (error "NYI")) + (#.+completed-response-message+ + (return (values nil (read-socket-value-string socket)))) + (#.+error-response-message+ + (let ((message (read-socket-value-string socket))) + (error 'postgresql-error + :connection connection :message message))) + (#.+notice-response-message+ + (let ((message (read-socket-value-string socket))) + (warn 'postgresql-warning + :connection connection :message message))) + (#.+notification-response-message+ + (let ((pid (read-socket-value-int32 socket)) + (message (read-socket-value-string socket))) + (when (= pid (postgresql-connection-pid connection)) + (signal 'postgresql-notification :connection connection + :message message)))) + (t + (close-postgresql-connection connection) + (error 'postgresql-fatal-error :connection connection + :message "Received garbled message from backend"))))))) + +(defun run-query (connection query &optional (result-types nil)) + (start-query-execution connection query) + (multiple-value-bind (status cursor) + (wait-for-query-results connection) + (assert (eq status :cursor)) + (loop for row = (read-cursor-row cursor result-types) + while row + collect row + finally + (wait-for-query-results connection)))) + +#+scl +(declaim (ext:maybe-inline read-byte write-byte)) diff --git a/db-postgresql-socket/postgresql-socket-package.lisp b/db-postgresql-socket/postgresql-socket-package.lisp new file mode 100644 index 0000000..fbedb51 --- /dev/null +++ b/db-postgresql-socket/postgresql-socket-package.lisp @@ -0,0 +1,58 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: postgresql-socket-package.lisp +;;;; Purpose: Package definition for PostgreSQL interface using sockets +;;;; Programmers: Kevin M. Rosenberg +;;;; Date Started: Feb 2002 +;;;; +;;;; 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. +;;;; ************************************************************************* + +(in-package #:cl-user) + +#+lispworks (require "comm") + +(defpackage #:postgresql-socket + (:use #:cl #:md5) + (:export #:pgsql-ftype + #:pgsql-ftype#bytea + #:pgsql-ftype#int2 + #:pgsql-ftype#int4 + #:pgsql-ftype#int8 + #:pgsql-ftype#float4 + #:pgsql-ftype#float8 + + #:+crypt-library+ + #:postgresql-condition + #:postgresql-condition-connection + #:postgresql-condition-message + #:postgresql-error + #:postgresql-fatal-error + #:postgresql-login-error + #:postgresql-warning + #:postgresql-notification + #:postgresql-connection + #:postgresql-connection-p + #:postgresql-cursor + #:postgresql-cursor-p + #:postgresql-cursor-connection + #:postgresql-cursor-name + #:postgresql-cursor-fields + #:+postgresql-server-default-port+ + #:open-postgresql-connection + #:reopen-postgresql-connection + #:close-postgresql-connection + #:postgresql-connection-open-p + #:ensure-open-postgresql-connection + #:start-query-execution + #:wait-for-query-results + #:read-cursor-row + #:copy-cursor-row + #:skip-cursor-row + )) diff --git a/db-postgresql-socket/postgresql-socket-sql.lisp b/db-postgresql-socket/postgresql-socket-sql.lisp new file mode 100644 index 0000000..352198a --- /dev/null +++ b/db-postgresql-socket/postgresql-socket-sql.lisp @@ -0,0 +1,346 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: postgresql-socket-sql.sql +;;;; Purpose: High-level PostgreSQL interface using socket +;;;; Authors: Kevin M. Rosenberg based on original code by Pierre R. Mai +;;;; Created: Feb 2002 +;;;; +;;;; This file, part of CLSQL, is Copyright (c) 2002-2010 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) + +(defpackage :clsql-postgresql-socket + (:use #:common-lisp #:clsql-sys #:postgresql-socket) + (:export #:postgresql-socket-database) + (:documentation "This is the CLSQL socket interface to PostgreSQL.")) + +(in-package #:clsql-postgresql-socket) + +;; interface foreign library loading routines + + +(clsql-sys:database-type-load-foreign :postgresql-socket) + + +;; Field type conversion + +(defun make-type-list-for-auto (cursor) + (let* ((fields (postgresql-cursor-fields cursor)) + (num-fields (length fields)) + (new-types '())) + (dotimes (i num-fields) + (declare (fixnum i)) + (push (canonical-field-type fields i) new-types)) + (nreverse new-types))) + +(defun canonical-field-type (fields index) + "Extracts canonical field type from fields list" + (let ((oid (cadr (nth index fields)))) + (case oid + ((#.pgsql-ftype#bytea + #.pgsql-ftype#int2 + #.pgsql-ftype#int4) + :int32) + (#.pgsql-ftype#int8 + :int64) + ((#.pgsql-ftype#float4 + #.pgsql-ftype#float8) + :double) + (otherwise + t)))) + +(defun canonicalize-types (types cursor) + (if (null types) + nil + (let ((auto-list (make-type-list-for-auto cursor))) + (cond + ((listp types) + (canonicalize-type-list types auto-list)) + ((eq types :auto) + auto-list) + (t + nil))))) + +(defun canonicalize-type-list (types auto-list) + "Ensure a field type list meets expectations. Essentially if we get a + generic term for a type that our auto typer pulls a better type for, + use it instead" + (let ((length-types (length types))) + (loop for i from 0 below (length auto-list) + for auto = (nth i auto-list) + collect + (if (or (>= i length-types) + (member (nth i types) (list T :int :double))) + auto + (nth i types))))) + + +(defun convert-to-clsql-warning (database condition) + (ecase *backend-warning-behavior* + (:warn + (warn 'sql-database-warning :database database + :message (postgresql-condition-message condition))) + (:error + (error 'sql-database-error :database database + :message (format nil "Warning upgraded to error: ~A" + (postgresql-condition-message condition)))) + ((:ignore nil) + ;; do nothing + ))) + +(defun convert-to-clsql-error (database expression condition) + (error 'sql-database-data-error + :database database + :expression expression + :error-id (type-of condition) + :message (postgresql-condition-message condition))) + +(defmacro with-postgresql-handlers + ((database &optional expression) + &body body) + (let ((database-var (gensym)) + (expression-var (gensym))) + `(let ((,database-var ,database) + (,expression-var ,expression)) + (handler-bind ((postgresql-warning + (lambda (c) + (convert-to-clsql-warning ,database-var c))) + (postgresql-error + (lambda (c) + (convert-to-clsql-error + ,database-var ,expression-var c)))) + ,@body)))) + +(defmethod database-initialize-database-type ((database-type + (eql :postgresql-socket))) + t) + +(defclass postgresql-socket-database (generic-postgresql-database) + ((connection :accessor database-connection :initarg :connection + :type postgresql-connection))) + +(defmethod database-type ((database postgresql-socket-database)) + :postgresql-socket) + +(defmethod database-name-from-spec (connection-spec + (database-type (eql :postgresql-socket))) + (check-connection-spec connection-spec database-type + (host db user password &optional port options tty)) + (destructuring-bind (host db user password &optional port options tty) + connection-spec + (declare (ignore password options tty)) + (concatenate 'string + (etypecase host + (null + "localhost") + (pathname (namestring host)) + (string host)) + (when port + (concatenate 'string + ":" + (etypecase port + (integer (write-to-string port)) + (string port)))) + "/" db "/" user))) + +(defmethod database-connect (connection-spec + (database-type (eql :postgresql-socket))) + (check-connection-spec connection-spec database-type + (host db user password &optional port options tty)) + (destructuring-bind (host db user password &optional + (port +postgresql-server-default-port+) + (options "") (tty "")) + connection-spec + (handler-case + (handler-bind ((postgresql-warning + (lambda (c) + (warn 'sql-warning + :format-control "~A" + :format-arguments + (list (princ-to-string c)))))) + (open-postgresql-connection :host host :port port + :options options :tty tty + :database db :user user + :password password)) + (postgresql-error (c) + ;; Connect failed + (error 'sql-connection-error + :database-type database-type + :connection-spec connection-spec + :error-id (type-of c) + :message (postgresql-condition-message c))) + (:no-error (connection) + ;; Success, make instance + (make-instance 'postgresql-socket-database + :name (database-name-from-spec connection-spec + database-type) + :database-type :postgresql-socket + :connection-spec connection-spec + :connection connection))))) + +(defmethod database-disconnect ((database postgresql-socket-database)) + (close-postgresql-connection (database-connection database)) + t) + +(defmethod database-query (expression (database postgresql-socket-database) result-types field-names) + (let ((connection (database-connection database))) + (with-postgresql-handlers (database expression) + (start-query-execution connection expression) + (multiple-value-bind (status cursor) + (wait-for-query-results connection) + (unless (eq status :cursor) + (close-postgresql-connection connection) + (error 'sql-database-data-error + :database database + :expression expression + :error-id "missing-result" + :message "Didn't receive result cursor for query.")) + (setq result-types (canonicalize-types result-types cursor)) + (values + (loop for row = (read-cursor-row cursor result-types) + while row + collect row + finally + (unless (null (wait-for-query-results connection)) + (close-postgresql-connection connection) + (error 'sql-database-data-error + :database database + :expression expression + :error-id "multiple-results" + :message "Received multiple results for query."))) + (when field-names + (mapcar #'car (postgresql-cursor-fields cursor)))))))) + +(defmethod database-execute-command + (expression (database postgresql-socket-database)) + (let ((connection (database-connection database))) + (with-postgresql-handlers (database expression) + (start-query-execution connection expression) + (multiple-value-bind (status result) + (wait-for-query-results connection) + (when (eq status :cursor) + (loop + (multiple-value-bind (row stuff) + (skip-cursor-row result) + (unless row + (setq status :completed result stuff) + (return))))) + (cond + ((null status) + t) + ((eq status :completed) + (unless (null (wait-for-query-results connection)) + (close-postgresql-connection connection) + (error 'sql-database-data-error + :database database + :expression expression + :error-id "multiple-results" + :message "Received multiple results for command.")) + result) + (t + (close-postgresql-connection connection) + (error 'sql-database-data-error + :database database + :expression expression + :errno "missing-result" + :message "Didn't receive completion for command."))))))) + +(defstruct postgresql-socket-result-set + (done nil) + (cursor nil) + (types nil)) + +(defmethod database-query-result-set ((expression string) + (database postgresql-socket-database) + &key full-set result-types) + (declare (ignore full-set)) + (let ((connection (database-connection database))) + (with-postgresql-handlers (database expression) + (start-query-execution connection expression) + (multiple-value-bind (status cursor) + (wait-for-query-results connection) + (unless (eq status :cursor) + (close-postgresql-connection connection) + (error 'sql-database-data-error + :database database + :expression expression + :error-id "missing-result" + :message "Didn't receive result cursor for query.")) + (values (make-postgresql-socket-result-set + :done nil + :cursor cursor + :types (canonicalize-types result-types cursor)) + (length (postgresql-cursor-fields cursor))))))) + +(defmethod database-dump-result-set (result-set + (database postgresql-socket-database)) + (if (postgresql-socket-result-set-done result-set) + t + (with-postgresql-handlers (database) + (loop while (skip-cursor-row + (postgresql-socket-result-set-cursor result-set)) + finally (setf (postgresql-socket-result-set-done result-set) t))))) + +(defmethod database-store-next-row (result-set + (database postgresql-socket-database) + list) + (let ((cursor (postgresql-socket-result-set-cursor result-set))) + (with-postgresql-handlers (database) + (if (copy-cursor-row cursor + list + (postgresql-socket-result-set-types + result-set)) + t + (prog1 nil + (setf (postgresql-socket-result-set-done result-set) t) + (wait-for-query-results (database-connection database))))))) + +(defmethod database-create (connection-spec (type (eql :postgresql-socket))) + (destructuring-bind (host name user password &optional port options tty) connection-spec + (let ((database (database-connect (list host "postgres" user password) + type))) + (setf (slot-value database 'clsql-sys::state) :open) + (unwind-protect + (database-execute-command (format nil "create database ~A" name) database) + (database-disconnect database))))) + +(defmethod database-destroy (connection-spec (type (eql :postgresql-socket))) + (destructuring-bind (host name user password &optional port optional tty) connection-spec + (let ((database (database-connect (list host "postgres" user password) + type))) + (setf (slot-value database 'clsql-sys::state) :open) + (unwind-protect + (database-execute-command (format nil "drop database ~A" name) database) + (database-disconnect database))))) + + +(defmethod database-probe (connection-spec (type (eql :postgresql-socket))) + (when (find (second connection-spec) (database-list connection-spec type) + :test #'string-equal) + t)) + + +;; Database capabilities + +(defmethod db-backend-has-create/destroy-db? ((db-type (eql :postgresql-socket))) + nil) + +(defmethod db-type-has-fancy-math? ((db-type (eql :postgresql-socket))) + t) + +(defmethod db-type-default-case ((db-type (eql :postgresql-socket))) + :lower) + +(defmethod database-underlying-type ((database postgresql-socket-database)) + :postgresql) + +(when (clsql-sys:database-type-library-loaded :postgresql-socket) + (clsql-sys:initialize-database-type :database-type :postgresql-socket)) diff --git a/db-postgresql-socket3/api.lisp b/db-postgresql-socket3/api.lisp new file mode 100644 index 0000000..ad6ca18 --- /dev/null +++ b/db-postgresql-socket3/api.lisp @@ -0,0 +1,64 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: postgresql-socket-api.lisp +;;;; Purpose: Low-level PostgreSQL interface using sockets +;;;; Authors: Kevin M. Rosenberg based on original code by Pierre R. Mai +;;;; Created: 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 #:postgresql-socket3) + +(defmethod clsql-sys:database-type-load-foreign ((database-type (eql :postgresql-socket3))) + t) + +(defmethod clsql-sys:database-type-library-loaded ((database-type + (eql :postgresql-socket3))) + "T if foreign library was able to be loaded successfully. Always true for +socket interface" + t) + +(defparameter +postgresql-server-default-port+ 5432 + "Default port of PostgreSQL server.") + +;;;; Condition hierarchy + +(define-condition postgresql-condition (condition) + ((connection :initarg :connection :reader postgresql-condition-connection) + (message :initarg :message :reader postgresql-condition-message)) + (:report + (lambda (c stream) + (format stream "~@<~A occurred on connection ~A. ~:@_Reason: ~A~:@>" + (type-of c) + (postgresql-condition-connection c) + (postgresql-condition-message c))))) + +(define-condition postgresql-error (error postgresql-condition) + ()) + +(define-condition postgresql-fatal-error (postgresql-error) + ()) + +(define-condition postgresql-login-error (postgresql-fatal-error) + ()) + +(define-condition postgresql-warning (warning postgresql-condition) + ()) + +(define-condition postgresql-notification (postgresql-condition) + () + (:report + (lambda (c stream) + (format stream "~@<Asynchronous notification on connection ~A: ~:@_~A~:@>" + (postgresql-condition-connection c) + (postgresql-condition-message c)))))
\ No newline at end of file diff --git a/db-postgresql-socket3/package.lisp b/db-postgresql-socket3/package.lisp new file mode 100644 index 0000000..3d13e4c --- /dev/null +++ b/db-postgresql-socket3/package.lisp @@ -0,0 +1,35 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: postgresql-socket-package.lisp +;;;; Purpose: Package definition for PostgreSQL interface using sockets +;;;; Programmers: 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. +;;;; ************************************************************************* + +(in-package #:cl-user) + +#+lispworks (require "comm") + +(defpackage #:postgresql-socket3 + (:use #:cl md5 #:cl-postgres) + (:shadow #:postgresql-warning #:postgresql-notification) + (:export #:+postgresql-server-default-port+ + #:postgresql-condition + #:postgresql-error + #:postgresql-fatal-error + #:postgresql-login-error + #:postgresql-warning + #:postgresql-notification + #:postgresql-condition-message + #:postgresql-condition-connection)) + diff --git a/db-postgresql-socket3/sql.lisp b/db-postgresql-socket3/sql.lisp new file mode 100644 index 0000000..3172e6d --- /dev/null +++ b/db-postgresql-socket3/sql.lisp @@ -0,0 +1,328 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: postgresql-socket-sql.sql +;;;; Purpose: High-level PostgreSQL interface using socket +;;;; Authors: Kevin M. Rosenberg based on original code by Pierre R. Mai +;;;; Created: Feb 2002 +;;;; +;;;; $Id$ +;;;; +;;;; This file, part of CLSQL, is Copyright (c) 2002-2007 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) + +(defpackage :clsql-postgresql-socket3 + (:use #:common-lisp #:clsql-sys #:postgresql-socket3) + (:export #:postgresql-socket3-database) + (:documentation "This is the CLSQL socket interface (protocol version 3) to PostgreSQL.")) + +(in-package #:clsql-postgresql-socket3) + +(defvar *sqlreader* (cl-postgres:copy-sql-readtable)) +(let ((dt-fn (lambda (useconds-since-2000) + (let ((sec (truncate + (/ useconds-since-2000 + 1000000))) + (usec (mod useconds-since-2000 + 1000000))) + (clsql:make-time :year 2000 :second sec :usec usec))))) + (cl-postgres:set-sql-datetime-readers + :table *sqlreader* + :date (lambda (days-since-2000) + (clsql:make-date :year 2000 :day (+ 1 days-since-2000))) + :timestamp dt-fn + :timestamp-with-timezone dt-fn)) + + + +;; interface foreign library loading routines + +(clsql-sys:database-type-load-foreign :postgresql-socket3) + + +(defmethod database-initialize-database-type ((database-type + (eql :postgresql-socket3))) + t) + + +;; Field type conversion +(defun convert-to-clsql-warning (database condition) + (ecase *backend-warning-behavior* + (:warn + (warn 'sql-database-warning :database database + :message (cl-postgres:database-error-message condition))) + (:error + (error 'sql-database-error :database database + :message (format nil "Warning upgraded to error: ~A" + (cl-postgres:database-error-message condition)))) + ((:ignore nil) + ;; do nothing + ))) + +(defun convert-to-clsql-error (database expression condition) + (error 'sql-database-data-error + :database database + :expression expression + :error-id (type-of condition) + :message (cl-postgres:database-error-message condition))) + +(defmacro with-postgresql-handlers + ((database &optional expression) + &body body) + (let ((database-var (gensym)) + (expression-var (gensym))) + `(let ((,database-var ,database) + (,expression-var ,expression)) + (handler-bind ((postgresql-warning + (lambda (c) + (convert-to-clsql-warning ,database-var c))) + (cl-postgres:database-error + (lambda (c) + (convert-to-clsql-error + ,database-var ,expression-var c)))) + ,@body)))) + + + +(defclass postgresql-socket3-database (generic-postgresql-database) + ((connection :accessor database-connection :initarg :connection + :type cl-postgres:database-connection))) + +(defmethod database-type ((database postgresql-socket3-database)) + :postgresql-socket3) + +(defmethod database-name-from-spec (connection-spec (database-type (eql :postgresql-socket3))) + (check-connection-spec connection-spec database-type + (host db user password &optional port options tty)) + (destructuring-bind (host db user password &optional port options tty) + connection-spec + (declare (ignore password options tty)) + (concatenate 'string + (etypecase host + (null + "localhost") + (keyword "unix") + (pathname (namestring host)) + (string host)) + (when port + (concatenate 'string + ":" + (etypecase port + (integer (write-to-string port)) + (string port)))) + "/" db "/" user))) + +(defmethod database-connect (connection-spec + (database-type (eql :postgresql-socket3))) + (check-connection-spec connection-spec database-type + (host db user password &optional port options tty)) + (destructuring-bind (host db user password &optional + (port +postgresql-server-default-port+) + (options "") (tty "")) + connection-spec + (declare (ignore options tty)) + (handler-case + (handler-bind ((warning + (lambda (c) + (warn 'sql-warning + :format-control "~A" + :format-arguments + (list (princ-to-string c)))))) + (cl-postgres:open-database db user password host port)) + (cl-postgres:database-error (c) + ;; Connect failed + (error 'sql-connection-error + :database-type database-type + :connection-spec connection-spec + :error-id (type-of c) + :message (cl-postgres:database-error-message c))) + (:no-error (connection) + ;; Success, make instance + (make-instance 'postgresql-socket3-database + :name (database-name-from-spec connection-spec database-type) + :database-type :postgresql-socket3 + :connection-spec connection-spec + :connection connection))))) + +(defmethod database-disconnect ((database postgresql-socket3-database)) + (cl-postgres:close-database (database-connection database)) + t) + +(defvar *include-field-names* nil) + + +;; THE FOLLOWING MACRO EXPANDS TO THE FUNCTION BELOW IT, +;; BUT TO GET null CONVENTIONS CORRECT I NEEDED TO TWEAK THE EXPANSION +;; +;; (cl-postgres:def-row-reader clsql-default-row-reader (fields) +;; (values (loop :while (cl-postgres:next-row) +;; :collect (loop :for field :across fields +;; :collect (cl-postgres:next-field field))) +;; (when *include-field-names* +;; (loop :for field :across fields +;; :collect (cl-postgres:field-name field))))) + + + +(defun clsql-default-row-reader (stream fields) + (declare (type stream stream) + (type (simple-array cl-postgres::field-description) fields)) + (flet ((cl-postgres:next-row () + (cl-postgres::look-for-row stream)) + (cl-postgres:next-field (cl-postgres::field) + (declare (type cl-postgres::field-description cl-postgres::field)) + (let ((cl-postgres::size (cl-postgres::read-int4 stream))) + (declare (type (signed-byte 32) cl-postgres::size)) + (if (eq cl-postgres::size -1) + nil + (funcall (cl-postgres::field-interpreter cl-postgres::field) + stream cl-postgres::size))))) + (let ((results (loop :while (cl-postgres:next-row) + :collect (loop :for field :across fields + :collect (cl-postgres:next-field field)))) + (col-names (when *include-field-names* + (loop :for field :across fields + :collect (cl-postgres:field-name field))))) + ;;multiple return values were not working here + (list results col-names)))) + +(defmethod database-query ((expression string) (database postgresql-socket3-database) result-types field-names) + (let ((connection (database-connection database)) + (cl-postgres:*sql-readtable* *sqlreader*)) + (with-postgresql-handlers (database expression) + (let ((*include-field-names* field-names)) + (apply #'values (cl-postgres:exec-query connection expression #'clsql-default-row-reader))) + ))) + +(defmethod query ((obj command-object) &key (database *default-database*) + (result-types :auto) (flatp nil) (field-names t)) + (clsql-sys::record-sql-command + (format nil "~&~A~&{Params: ~{~A~^, ~}}" + (expression obj) + (parameters obj)) + database) + (multiple-value-bind (rows names) + (database-query obj database result-types field-names) + (let ((result (if (and flatp (= 1 (length (car rows)))) + (mapcar #'car rows) + rows))) + (clsql-sys::record-sql-result result database) + (if field-names + (values result names) + result)))) + +(defmethod database-query ((obj command-object) (database postgresql-socket3-database) result-types field-names) + (let ((connection (database-connection database)) + (cl-postgres:*sql-readtable* *sqlreader*)) + (with-postgresql-handlers (database obj) + (let ((*include-field-names* field-names)) + (unless (has-been-prepared obj) + (cl-postgres:prepare-query connection (prepared-name obj) (expression obj)) + (setf (has-been-prepared obj) T)) + (apply #'values (cl-postgres:exec-prepared + connection + (prepared-name obj) + (parameters obj) + #'clsql-default-row-reader)))))) + +(defmethod database-execute-command + ((expression string) (database postgresql-socket3-database)) + (let ((connection (database-connection database))) + (with-postgresql-handlers (database expression) + ;; return row count? + (second (multiple-value-list (cl-postgres:exec-query connection expression)))))) + +(defmethod execute-command ((obj command-object) + &key (database *default-database*)) + (clsql-sys::record-sql-command (expression obj) database) + (let ((res (database-execute-command obj database))) + (clsql-sys::record-sql-result res database) + ;; return row count? + res)) + +(defmethod database-execute-command + ((obj command-object) (database postgresql-socket3-database)) + (let ((connection (database-connection database))) + (with-postgresql-handlers (database obj) + (unless (has-been-prepared obj) + (cl-postgres:prepare-query connection (prepared-name obj) (expression obj)) + (setf (has-been-prepared obj) T)) + (second (multiple-value-list (cl-postgres:exec-prepared connection (prepared-name obj) (parameters obj))))))) + +;;;; Cursoring interface + + +(defmethod database-query-result-set ((expression string) + (database postgresql-socket3-database) + &key full-set result-types) + (declare (ignore result-types)) + (declare (ignore full-set)) + (error "Cursoring interface is not supported for postgresql-socket3-database try cl-postgres:exec-query with a custom row-reader")) + +(defmethod database-dump-result-set (result-set + (database postgresql-socket3-database)) + (error "Cursoring interface is not supported for postgresql-socket3-database try cl-postgres:exec-query with a custom row-reader") + T) + +(defmethod database-store-next-row (result-set + (database postgresql-socket3-database) + list) + (error "Cursoring interface is not supported for postgresql-socket3-database try cl-postgres:exec-query with a custom row-reader")) + + +;;;;;;;;;;;;;;;;;;;;;;;;;; + + +(defmethod database-create (connection-spec (type (eql :postgresql-socket3))) + (destructuring-bind (host name user password &optional port options tty) connection-spec + (declare (ignore port options tty)) + (let ((database (database-connect (list host "postgres" user password) + type))) + (setf (slot-value database 'clsql-sys::state) :open) + (unwind-protect + (database-execute-command (format nil "create database ~A" name) database) + (database-disconnect database))))) + +(defmethod database-destroy (connection-spec (type (eql :postgresql-socket3))) + (destructuring-bind (host name user password &optional port options tty) connection-spec + (declare (ignore port options tty)) + (let ((database (database-connect (list host "postgres" user password) + type))) + (setf (slot-value database 'clsql-sys::state) :open) + (unwind-protect + (database-execute-command (format nil "drop database ~A" name) database) + (database-disconnect database))))) + + +(defmethod database-probe (connection-spec (type (eql :postgresql-socket3))) + (when (find (second connection-spec) (database-list connection-spec type) + :test #'string-equal) + t)) + + +;; Database capabilities + +(defmethod db-backend-has-create/destroy-db? ((db-type (eql :postgresql-socket3))) + nil) + +(defmethod db-type-has-fancy-math? ((db-type (eql :postgresql-socket3))) + t) + +(defmethod db-type-default-case ((db-type (eql :postgresql-socket3))) + :lower) + +(defmethod database-underlying-type ((database postgresql-socket3-database)) + :postgresql) + +(when (clsql-sys:database-type-library-loaded :postgresql-socket3) + (clsql-sys:initialize-database-type :database-type :postgresql-socket3)) + + diff --git a/db-postgresql/Makefile b/db-postgresql/Makefile new file mode 100644 index 0000000..31dc910 --- /dev/null +++ b/db-postgresql/Makefile @@ -0,0 +1,6 @@ +SUBDIRS := + +include ../Makefile.common + +.PHONY: distclean +distclean: clean diff --git a/db-postgresql/postgresql-api.lisp b/db-postgresql/postgresql-api.lisp new file mode 100644 index 0000000..c0b8a00 --- /dev/null +++ b/db-postgresql/postgresql-api.lisp @@ -0,0 +1,302 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: postgresql.cl +;;;; Purpose: Low-level PostgreSQL interface using UFFI +;;;; Programmers: Kevin M. Rosenberg based on +;;;; Original code by Pierre R. Mai +;;;; Date Started: Feb 2002 +;;;; +;;;; This file, part of CLSQL, is Copyright (c) 2002 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 #:pgsql) + + +;;;; This file implements as little of the FFI bindings to the +;;;; PostgreSQL client libraries as we could get away with. +;;;; Especially all the PostgreSQL-specific goodies aren't there, and +;;;; we just use void pointers where we can get away with it, which +;;;; thanks to the design of the PostgreSQL client libraries is pretty +;;;; much everywhere, in contrast to the MySQL client libraries for +;;;; example. + +;;;; Type definitions + +;;; Basic Types + +(uffi:def-foreign-type pgsql-oid :unsigned-int) + +(uffi:def-enum pgsql-conn-status-type + (:connection-ok + :connection-bad)) + +(uffi:def-enum pgsql-exec-status-type + (:empty-query + :command-ok + :tuples-ok + :copy-out + :copy-in + :bad-response + :nonfatal-error + :fatal-error)) + +(uffi:def-foreign-type pgsql-conn :pointer-void) +(uffi:def-foreign-type pgsql-result :pointer-void) + +(uffi:def-type pgsql-conn-ptr :pointer-void) + +(uffi:def-enum pgsql-ftype + ((:bytea 17) + (:int2 21) + (:int4 23) + (:int8 20) + (:float4 700) + (:float8 701))) + +;;(declaim (inline PQsetdbLogin)) ;; causes compile error in LW 4.2.0 +(uffi:def-function ("PQsetdbLogin" PQsetdbLogin) + ((pghost :cstring) + (pgport :cstring) + (pgoptions :cstring) + (pgtty :cstring) + (dbName :cstring) + (login :cstring) + (pwd :cstring)) + :module "postgresql" + :returning pgsql-conn) + +(declaim (inline PQfinish)) +(uffi:def-function ("PQfinish" PQfinish) + ((conn pgsql-conn)) + :module "postgresql" + :returning :void) + +(declaim (inline PQstatus)) +(uffi:def-function ("PQstatus" PQstatus) + ((conn pgsql-conn)) + :module "postgresql" + :returning pgsql-conn-status-type) + +(declaim (inline PQerrorMessage)) +(uffi:def-function ("PQerrorMessage" PQerrorMessage) + ((conn pgsql-conn)) + :module "postgresql" + :returning :cstring) + +(declaim (inline PQexec)) +(uffi:def-function ("PQexec" PQexec) + ((conn pgsql-conn) + (query :cstring)) + :module "postgresql" + :returning pgsql-result) + +(declaim (inline PQresultStatus)) +(uffi:def-function ("PQresultStatus" PQresultStatus) + ((res pgsql-result)) + :module "postgresql" + :returning pgsql-exec-status-type) + +; From postgres_ext.h + +; #define PG_DIAG_SEVERITY 'S' +; #define PG_DIAG_SQLSTATE 'C' +; #define PG_DIAG_MESSAGE_PRIMARY 'M' +; #define PG_DIAG_MESSAGE_DETAIL 'D' +; #define PG_DIAG_MESSAGE_HINT 'H' +; #define PG_DIAG_STATEMENT_POSITION 'P' +; #define PG_DIAG_INTERNAL_POSITION 'p' +; #define PG_DIAG_INTERNAL_QUERY 'q' +; #define PG_DIAG_CONTEXT 'W' +; #define PG_DIAG_SOURCE_FILE 'F' +; #define PG_DIAG_SOURCE_LINE 'L' +; #define PG_DIAG_SOURCE_FUNCTION 'R' +(defconstant +PG-DIAG-SEVERITY+ (char-code #\S)) +(defconstant +PG-DIAG-SQLSTATE+ (char-code #\C)) +(defconstant +PG-DIAG-MESSAGE-PRIMARY+ (char-code #\M)) +(defconstant +PG-DIAG-MESSAGE-DETAIL+ (char-code #\D)) +(defconstant +PG-DIAG-MESSAGE-HINT+ (char-code #\H)) +(defconstant +PG-DIAG-STATEMENT-POSITION+ (char-code #\P)) +(defconstant +PG-DIAG-INTERNAL-POSITION+ (char-code #\p)) +(defconstant +PG-DIAG-INTERNAL-QUERY+ (char-code #\q)) +(defconstant +PG-DIAG-CONTEXT+ (char-code #\W)) +(defconstant +PG-DIAG-SOURCE-FILE+ (char-code #\F)) +(defconstant +PG-DIAG-SOURCE-LINE+ (char-code #\L)) +(defconstant +PG-DIAG-SOURCE-FUNCTION+ (char-code #\R)) + +; PQresultErrorField can return diagnostic information about an error +(declaim (inline PQresultErrorField)) +(uffi:def-function ("PQresultErrorField" PQresultErrorField) + ((res pgsql-result) + (field-code :int)) + :module "postgresql" + :returning :cstring) + +(declaim (inline PQresultErrorMessage)) +(uffi:def-function ("PQresultErrorMessage" PQresultErrorMessage) + ((res pgsql-result)) + :module "postgresql" + :returning :cstring) + +(declaim (inline PQntuples)) +(uffi:def-function ("PQntuples" PQntuples) + ((res pgsql-result)) + :module "postgresql" + :returning :int) + +(declaim (inline PQnfields)) +(uffi:def-function ("PQnfields" PQnfields) + ((res pgsql-result)) + :module "postgresql" + :returning :int) + +(declaim (inline PQfname)) +(uffi:def-function ("PQfname" PQfname) + ((res pgsql-result) + (field-num :int)) + :module "postgresql" + :returning :cstring) + +(declaim (inline PQfnumber)) +(uffi:def-function ("PQfnumber" PQfnumber) + ((res pgsql-result) + (field-name :cstring)) + :module "postgresql" + :returning :int) + +(declaim (inline PQftype)) +(uffi:def-function ("PQftype" PQftype) + ((res pgsql-result) + (field-num :int)) + :module "postgresql" + :returning pgsql-oid) + +(declaim (inline PQfsize)) +(uffi:def-function ("PQfsize" PQfsize) + ((res pgsql-result) + (field-num :int)) + :module "postgresql" + :returning :short) + +(declaim (inline PQcmdStatus)) +(uffi:def-function ("PQcmdStatus" PQcmdStatus) + ((res pgsql-result)) + :module "postgresql" + :returning :cstring) + +(declaim (inline PQoidStatus)) +(uffi:def-function ("PQoidStatus" PQoidStatus) + ((res pgsql-result)) + :module "postgresql" + :returning :cstring) + +(declaim (inline PQcmdTuples)) +(uffi:def-function ("PQcmdTuples" PQcmdTuples) + ((res pgsql-result)) + :module "postgresql" + :returning :cstring) + +(declaim (inline PQgetvalue)) +(uffi:def-function ("PQgetvalue" PQgetvalue) + ((res pgsql-result) + (tup-num :int) + (field-num :int)) + :module "postgresql" + :returning (* :unsigned-char)) + +(declaim (inline PQgetlength)) +(uffi:def-function ("PQgetlength" PQgetlength) + ((res pgsql-result) + (tup-num :int) + (field-num :int)) + :module "postgresql" + :returning :int) + +(declaim (inline PQgetisnull)) +(uffi:def-function ("PQgetisnull" PQgetisnull) + ((res pgsql-result) + (tup-num :int) + (field-num :int)) + :module "postgresql" + :returning :int) + +(declaim (inline PQclear)) +(uffi:def-function ("PQclear" PQclear) + ((res pgsql-result)) + :module "postgresql" + :returning :void) + +(declaim (inline PQisBusy)) +(uffi:def-function ("PQisBusy" PQisBusy) + ((conn pgsql-conn)) + :module "postgresql" + :returning :int) + + +;;; Large objects support (MB) + +(defconstant +INV_ARCHIVE+ 65536) ; fe-lobj.c +(defconstant +INV_WRITE+ 131072) +(defconstant +INV_READ+ 262144) + +(declaim (inline lo-creat)) +(uffi:def-function ("lo_creat" lo-create) + ((conn pgsql-conn) + (mode :int)) + :module "postgresql" + :returning pgsql-oid) + +(declaim (inline lo-open)) +(uffi:def-function ("lo_open" lo-open) + ((conn pgsql-conn) + (oid pgsql-oid) + (mode :int)) + :module "postgresql" + :returning :int) + +(declaim (inline lo-write)) +(uffi:def-function ("lo_write" lo-write) + ((conn pgsql-conn) + (fd :int) + (data :cstring) + (size :int)) + :module "postgresql" + :returning :int) + +(declaim (inline lo-read)) +(uffi:def-function ("lo_read" lo-read) + ((conn pgsql-conn) + (fd :int) + (data (* :unsigned-char)) + (size :int)) + :module "postgresql" + :returning :int) + +(declaim (inline lo-lseek)) +(uffi:def-function ("lo_lseek" lo-lseek) + ((conn pgsql-conn) + (fd :int) + (offset :int) + (whence :int)) + :module "postgresql" + :returning :int) + +(declaim (inline lo-close)) +(uffi:def-function ("lo_close" lo-close) + ((conn pgsql-conn) + (fd :int)) + :module "postgresql" + :returning :int) + +(declaim (inline lo-unlink)) +(uffi:def-function ("lo_unlink" lo-unlink) + ((conn pgsql-conn) + (oid pgsql-oid)) + :module "postgresql" + :returning :int) diff --git a/db-postgresql/postgresql-loader.lisp b/db-postgresql/postgresql-loader.lisp new file mode 100644 index 0000000..42f6904 --- /dev/null +++ b/db-postgresql/postgresql-loader.lisp @@ -0,0 +1,40 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: postgresql-loader.sql +;;;; Purpose: PostgreSQL library loader using UFFI +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Feb 2002 +;;;; +;;;; 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. +;;;; ************************************************************************* + +(in-package #:pgsql) + + +(defvar *postgresql-supporting-libraries* '("crypt" "c") + "Used only by CMU. List of library flags needed to be passed to ld to +load the PostgresSQL client library succesfully. If this differs at your site, +set to the right path before compiling or loading the system.") + +(defvar *postgresql-library-loaded* nil + "T if foreign library was able to be loaded successfully") + +(defmethod clsql-sys:database-type-library-loaded ((database-type + (eql :postgresql))) + *postgresql-library-loaded*) + +(defmethod clsql-sys:database-type-load-foreign ((database-type + (eql :postgresql))) + (clsql-uffi:find-and-load-foreign-library "libpq" + :module "postgresql" + :supporting-libraries *postgresql-supporting-libraries*) + (setq *postgresql-library-loaded* t)) + +(clsql-sys:database-type-load-foreign :postgresql) + diff --git a/db-postgresql/postgresql-package.lisp b/db-postgresql/postgresql-package.lisp new file mode 100644 index 0000000..aac6608 --- /dev/null +++ b/db-postgresql/postgresql-package.lisp @@ -0,0 +1,87 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: postgresql-package.cl +;;;; Purpose: Package definition for low-level PostgreSQL interface +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Feb 2002 +;;;; +;;;; 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. +;;;; ************************************************************************* + +(in-package #:cl-user) + +(defpackage #:pgsql + #-(and :lispworks (not :lispworks4)) + (:nicknames #:postgresql) + (:use #:cl #:clsql-uffi) + (:export + #:pgsql-oid + #:pgsql-conn-status-type + #:pgsql-conn-status-type#connection-ok + #:pgsql-conn-status-type#connection-bad + #:pgsql-exec-status-type + #:pgsql-exec-status-type#empty-query + #:pgsql-exec-status-type#command-ok + #:pgsql-exec-status-type#tuples-ok + #:pgsql-exec-status-type#copy-out + #:pgsql-exec-status-type#copy-in + #:pgsql-exec-status-type#bad-response + #:pgsql-exec-status-type#nonfatal-error + #:pgsql-exec-status-type#fatal-error + #:pgsql-conn + #:pgsql-result + + #:pgsql-ftype#bytea + #:pgsql-ftype#int2 + #:pgsql-ftype#int4 + #:pgsql-ftype#int8 + #:pgsql-ftype#float4 + #:pgsql-ftype#float8 + + ;; Used by PQresultErrorField to get the sql error code + #:+PG-DIAG-SQLSTATE+ + + + ;; Functions + #:PQsetdbLogin + #:PQlogin + #:PQfinish + #:PQstatus + #:PQerrorMessage + #:PQexec + #:PQresultStatus + #:PQresultErrorField ; used to grab the SQLSTATE code from an error + #:PQresultErrorMessage + #:PQntuples + #:PQnfields + #:PQfname + #:PQfnumber + #:PQftype + #:PQfsize + #:PQcmdStatus + #:PQoidStatus + #:PQcmdTuples + #:PQgetvalue + #:PQgetlength + #:PQgetisnull + #:PQclear + #:PQisBusy + + ;;Large Objects (Marc B) + #:lo-create + #:lo-open + #:lo-write + #:lo-read + #:lo-lseek + #:lo-close + #:lo-unlink + ) + (:documentation "This is the low-level interface to PostgreSQL.")) + + diff --git a/db-postgresql/postgresql-sql.lisp b/db-postgresql/postgresql-sql.lisp new file mode 100644 index 0000000..51d5d0f --- /dev/null +++ b/db-postgresql/postgresql-sql.lisp @@ -0,0 +1,448 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: postgresql-sql.lisp +;;;; Purpose: High-level PostgreSQL interface using UFFI +;;;; Date Started: Feb 2002 +;;;; +;;;; 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 #:clsql-postgresql + (:use #:common-lisp #:clsql-sys #:pgsql #:clsql-uffi) + (:export #:postgresql-database) + (:documentation "This is the CLSQL interface to PostgreSQL.")) + +(in-package #:clsql-postgresql) + +;;; Field conversion functions + +(defun make-type-list-for-auto (num-fields res-ptr) + (let ((new-types '())) + (dotimes (i num-fields) + (declare (fixnum i)) + (let* ((type (PQftype res-ptr i))) + (push + (case type + ((#.pgsql-ftype#bytea + #.pgsql-ftype#int2 + #.pgsql-ftype#int4) + :int32) + (#.pgsql-ftype#int8 + :int64) + ((#.pgsql-ftype#float4 + #.pgsql-ftype#float8) + :double) + (otherwise + t)) + new-types))) + (nreverse new-types))) + +(defun canonicalize-types (types num-fields res-ptr) + (if (null types) + nil + (let ((auto-list (make-type-list-for-auto num-fields res-ptr))) + (cond + ((listp types) + (canonicalize-type-list types auto-list)) + ((eq types :auto) + auto-list) + (t + nil))))) + +(defun tidy-error-message (message &optional encoding) + (unless (stringp message) + (setq message (uffi:convert-from-foreign-string message :encoding encoding))) + (let ((message (string-right-trim '(#\Return #\Newline) message))) + (cond + ((< (length message) (length "ERROR:")) + message) + ((string= message "ERROR:" :end1 6) + (string-left-trim '(#\Space) (subseq message 6))) + (t + message)))) + +(defmethod database-initialize-database-type ((database-type + (eql :postgresql))) + t) + +(uffi:def-type pgsql-conn-def pgsql-conn) +(uffi:def-type pgsql-result-def pgsql-result) + + +(defclass postgresql-database (generic-postgresql-database) + ((conn-ptr :accessor database-conn-ptr :initarg :conn-ptr + :type pgsql-conn-def) + (lock + :accessor database-lock + :initform (make-process-lock "conn")))) + +(defmethod database-type ((database postgresql-database)) + :postgresql) + +(defmethod database-name-from-spec (connection-spec (database-type + (eql :postgresql))) + (check-connection-spec connection-spec database-type + (host db user password &optional port options tty)) + (destructuring-bind (host db user password &optional port options tty) + connection-spec + (declare (ignore password options tty)) + (concatenate 'string + (etypecase host + (null "localhost") + (pathname (namestring host)) + (string host)) + (when port + (concatenate 'string + ":" + (etypecase port + (integer (write-to-string port)) + (string port)))) + "/" db "/" user))) + + +(defmethod database-connect (connection-spec (database-type (eql :postgresql))) + (check-connection-spec connection-spec database-type + (host db user password &optional port options tty)) + (destructuring-bind (host db user password &optional port options tty) + connection-spec + (uffi:with-cstrings ((host-native host) + (user-native user) + (password-native password) + (db-native db) + (port-native port) + (options-native options) + (tty-native tty)) + (let ((connection (PQsetdbLogin host-native port-native + options-native tty-native + db-native user-native + password-native))) + (declare (type pgsql-conn-def connection)) + (when (not (eq (PQstatus connection) + pgsql-conn-status-type#connection-ok)) + (let ((pqstatus (PQstatus connection)) + (pqmessage (tidy-error-message (PQerrorMessage connection)))) + (PQfinish connection) + (error 'sql-connection-error + :database-type database-type + :connection-spec connection-spec + :error-id pqstatus + :message pqmessage))) + (make-instance 'postgresql-database + :name (database-name-from-spec connection-spec + database-type) + :database-type :postgresql + :connection-spec connection-spec + :conn-ptr connection))))) + + +(defmethod database-disconnect ((database postgresql-database)) + (PQfinish (database-conn-ptr database)) + (setf (database-conn-ptr database) nil) + t) + +(defmethod database-query (query-expression (database postgresql-database) result-types field-names) + (let ((conn-ptr (database-conn-ptr database))) + (declare (type pgsql-conn-def conn-ptr)) + (uffi:with-cstring (query-native query-expression) + (let ((result (PQexec conn-ptr query-native))) + (when (uffi:null-pointer-p result) + (error 'sql-database-data-error + :database database + :expression query-expression + :message (tidy-error-message (PQerrorMessage conn-ptr) (encoding database)))) + (unwind-protect + (case (PQresultStatus result) + ;; User gave a command rather than a query + (#.pgsql-exec-status-type#command-ok + nil) + (#.pgsql-exec-status-type#empty-query + nil) + (#.pgsql-exec-status-type#tuples-ok + (let ((num-fields (PQnfields result))) + (when result-types + (setq result-types + (canonicalize-types result-types num-fields + result))) + (let ((res (loop for tuple-index from 0 below (PQntuples result) + collect + (loop for i from 0 below num-fields + collect + (if (zerop (PQgetisnull result tuple-index i)) + (convert-raw-field + (PQgetvalue result tuple-index i) + (nth i result-types) + :encoding (encoding database)) + nil))))) + (if field-names + (values res (result-field-names num-fields result)) + res)))) + (t + (error 'sql-database-data-error + :database database + :expression query-expression + :error-id (PQresultErrorField result +PG-DIAG-SQLSTATE+) + :message (tidy-error-message + (PQresultErrorMessage result) + (encoding database))))) + (PQclear result)))))) + +(defun result-field-names (num-fields result) + "Return list of result field names." + (let ((names '())) + (dotimes (i num-fields (nreverse names)) + (declare (fixnum i)) + (push (uffi:convert-from-cstring (PQfname result i)) names)))) + +(defmethod database-execute-command (sql-expression + (database postgresql-database)) + (let ((conn-ptr (database-conn-ptr database))) + (declare (type pgsql-conn-def conn-ptr)) + (uffi:with-cstring (sql-native sql-expression) + (let ((result (PQexec conn-ptr sql-native))) + (when (uffi:null-pointer-p result) + (error 'sql-database-data-error + :database database + :expression sql-expression + :message (tidy-error-message (PQerrorMessage conn-ptr) + (encoding database)))) + (unwind-protect + (case (PQresultStatus result) + (#.pgsql-exec-status-type#command-ok + t) + ((#.pgsql-exec-status-type#empty-query + #.pgsql-exec-status-type#tuples-ok) + (warn "Strange result...") + t) + (t + (error 'sql-database-data-error + :database database + :expression sql-expression + :error-id (PQresultErrorField result +PG-DIAG-SQLSTATE+) + :message (tidy-error-message + (PQresultErrorMessage result) + (encoding database))))) + (PQclear result)))))) + +(defstruct postgresql-result-set + (res-ptr (uffi:make-null-pointer 'pgsql-result) + :type pgsql-result-def) + (types nil) + (num-tuples 0 :type integer) + (num-fields 0 :type integer) + (tuple-index 0 :type integer)) + +(defmethod database-query-result-set ((query-expression string) + (database postgresql-database) + &key full-set result-types) + (let ((conn-ptr (database-conn-ptr database))) + (declare (type pgsql-conn-def conn-ptr)) + (uffi:with-cstring (query-native query-expression) + (let ((result (PQexec conn-ptr query-native))) + (when (uffi:null-pointer-p result) + (error 'sql-database-data-error + :database database + :expression query-expression + :message (tidy-error-message (PQerrorMessage conn-ptr) + (encoding database)))) + (case (PQresultStatus result) + ((#.pgsql-exec-status-type#empty-query + #.pgsql-exec-status-type#tuples-ok) + (let ((result-set (make-postgresql-result-set + :res-ptr result + :num-fields (PQnfields result) + :num-tuples (PQntuples result) + :types (canonicalize-types + result-types + (PQnfields result) + result)))) + (if full-set + (values result-set + (PQnfields result) + (PQntuples result)) + (values result-set + (PQnfields result))))) + (t + (unwind-protect + (error 'sql-database-data-error + :database database + :expression query-expression + :error-id (PQresultErrorField result +PG-DIAG-SQLSTATE+) + :message (tidy-error-message + (PQresultErrorMessage result) + (encoding database))) + (PQclear result)))))))) + +(defmethod database-dump-result-set (result-set (database postgresql-database)) + (let ((res-ptr (postgresql-result-set-res-ptr result-set))) + (declare (type pgsql-result-def res-ptr)) + (PQclear res-ptr) + t)) + +(defmethod database-store-next-row (result-set (database postgresql-database) + list) + (let ((result (postgresql-result-set-res-ptr result-set)) + (types (postgresql-result-set-types result-set))) + (declare (type pgsql-result-def result)) + (if (>= (postgresql-result-set-tuple-index result-set) + (postgresql-result-set-num-tuples result-set)) + nil + (loop with tuple-index = (postgresql-result-set-tuple-index result-set) + for i from 0 below (postgresql-result-set-num-fields result-set) + for rest on list + do + (setf (car rest) + (if (zerop (PQgetisnull result tuple-index i)) + (convert-raw-field + (PQgetvalue result tuple-index i) + (nth i types) + :encoding (encoding database)) + nil)) + finally + (incf (postgresql-result-set-tuple-index result-set)) + (return list))))) + +;;; Large objects support (Marc B) + +(defmethod database-create-large-object ((database postgresql-database)) + (lo-create (database-conn-ptr database) + (logior pgsql::+INV_WRITE+ pgsql::+INV_READ+))) + + +#+mb-original +(defmethod database-write-large-object (object-id (data string) (database postgresql-database)) + (let ((ptr (database-conn-ptr database)) + (length (length data)) + (result nil) + (fd nil)) + (with-transaction (:database database) + (unwind-protect + (progn + (setf fd (lo-open ptr object-id pgsql::+INV_WRITE+)) + (when (>= fd 0) + (when (= (lo-write ptr fd data length) length) + (setf result t)))) + (progn + (when (and fd (>= fd 0)) + (lo-close ptr fd)) + ))) + result)) + +(defmethod database-write-large-object (object-id (data string) (database postgresql-database)) + (let ((ptr (database-conn-ptr database)) + (length (length data)) + (result nil) + (fd nil)) + (database-execute-command "begin" database) + (unwind-protect + (progn + (setf fd (lo-open ptr object-id pgsql::+INV_WRITE+)) + (when (>= fd 0) + (when (= (lo-write ptr fd data length) length) + (setf result t)))) + (progn + (when (and fd (>= fd 0)) + (lo-close ptr fd)) + (database-execute-command (if result "commit" "rollback") database))) + result)) + +;; (MB) the begin/commit/rollback stuff will be removed when with-transaction wil be implemented +;; (KMR) Can't use with-transaction since that function is in high-level code +(defmethod database-read-large-object (object-id (database postgresql-database)) + (let ((ptr (database-conn-ptr database)) + (buffer nil) + (result nil) + (length 0) + (fd nil)) + (unwind-protect + (progn + (database-execute-command "begin" database) + (setf fd (lo-open ptr object-id pgsql::+INV_READ+)) + (when (>= fd 0) + (setf length (lo-lseek ptr fd 0 2)) + (lo-lseek ptr fd 0 0) + (when (> length 0) + (setf buffer (uffi:allocate-foreign-string + length :unsigned t)) + (when (= (lo-read ptr fd buffer length) length) + (setf result (uffi:convert-from-foreign-string + buffer :length length :null-terminated-p nil + :encoding (encoding database))))))) + (progn + (when buffer (uffi:free-foreign-object buffer)) + (when (and fd (>= fd 0)) (lo-close ptr fd)) + (database-execute-command (if result "commit" "rollback") database))) + result)) + +(defmethod database-delete-large-object (object-id (database postgresql-database)) + (lo-unlink (database-conn-ptr database) object-id)) + + +;;; Object listing + + + +(defmethod database-create (connection-spec (type (eql :postgresql))) + (destructuring-bind (host name user password) connection-spec + (let ((database (database-connect (list host "postgres" user password) + type))) + (setf (slot-value database 'clsql-sys::state) :open) + (unwind-protect + (database-execute-command (format nil "create database ~A" name) database) + (database-disconnect database))))) + +(defmethod database-destroy (connection-spec (type (eql :postgresql))) + (destructuring-bind (host name user password) connection-spec + (let ((database (database-connect (list host "postgres" user password) + type))) + (setf (slot-value database 'clsql-sys::state) :open) + (unwind-protect + (database-execute-command (format nil "drop database ~A" name) database) + (database-disconnect database))))) + + +(defmethod database-probe (connection-spec (type (eql :postgresql))) + (when (find (second connection-spec) (database-list connection-spec type) + :test #'string-equal) + t)) + + +(defun %pg-database-connection (connection-spec) + (check-connection-spec connection-spec :postgresql + (host db user password &optional port options tty)) + (macrolet ((coerce-string (var) + `(unless (typep ,var 'simple-base-string) + (setf ,var (coerce ,var 'simple-base-string))))) + (destructuring-bind (host db user password &optional port options tty) + connection-spec + (coerce-string db) + (coerce-string user) + (let ((connection (PQsetdbLogin host port options tty db user password))) + (declare (type pgsql::pgsql-conn-ptr connection)) + (unless (eq (PQstatus connection) + pgsql-conn-status-type#connection-ok) + ;; Connect failed + (error 'sql-connection-error + :database-type :postgresql + :connection-spec connection-spec + :error-id (PQstatus connection) + :message (PQerrorMessage connection))) + connection)))) + +(defmethod database-reconnect ((database postgresql-database)) + (let ((lock (database-lock database))) + (with-process-lock (lock "Reconnecting") + (with-slots (connection-spec conn-ptr) + database + (setf conn-ptr (%pg-database-connection connection-spec)) + database)))) + +;;; Database capabilities + +(when (clsql-sys:database-type-library-loaded :postgresql) + (clsql-sys:initialize-database-type :database-type :postgresql)) diff --git a/db-sqlite/Makefile b/db-sqlite/Makefile new file mode 100644 index 0000000..7fb8277 --- /dev/null +++ b/db-sqlite/Makefile @@ -0,0 +1,23 @@ +#!/usr/bin/make +########################################################################## +# FILE IDENTIFICATION +# +# Name: Makefile +# Purpose: Makefile for CLSQL SQLITE interface +# Programer: Kevin M. Rosenberg +# Date Started: Mar 2002 +# +# 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. +########################################################################## + +SUBDIRS= + +include ../Makefile.common + +.PHONY: distclean +distclean: clean + diff --git a/db-sqlite/sqlite-api.lisp b/db-sqlite/sqlite-api.lisp new file mode 100644 index 0000000..b25653f --- /dev/null +++ b/db-sqlite/sqlite-api.lisp @@ -0,0 +1,322 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: sqlite-api-uffi.lisp +;;;; Purpose: Low-level SQLite interface using UFFI +;;;; Authors: Aurelio Bignoli and Kevin Rosenberg +;;;; Created: Nov 2003 +;;;; +;;;; This file, part of CLSQL, is Copyright (c) 2003 by Aurelio Bignoli +;;;; and Copyright (c) 2003-2004 by Kevin 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 #:sqlite + (:use #:common-lisp #:uffi) + (:export + ;;; Conditions + #:sqlite-error + #:sqlite-error-code + #:sqlite-error-message + + ;;; Core API. + #:sqlite-open + #:sqlite-close + + ;;; New API. + #:sqlite-compile + #:sqlite-step + #:sqlite-finalize + + ;;; Extended API. + #:sqlite-get-table + #:sqlite-free-table + #:sqlite-version ; Defined as constant. + #:sqlite-encoding ; Defined as constant. + #:sqlite-last-insert-rowid + + ;;; Utility functions. + #:make-null-row + #:make-null-vm + #:null-row-p + #:sqlite-aref + #:sqlite-raw-aref + #:sqlite-free-row + + ;;; Types. + #:sqlite-row + #:sqlite-row-pointer + #:sqlite-row-pointer-type + #:sqlite-vm-pointer)) + +(in-package #:sqlite) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; +;;;; Return values for sqlite_exec() and sqlite_step() +;;;; +(defconstant SQLITE-OK 0 "Successful result") +(defconstant SQLITE-ERROR 1 "SQL error or missing database") +(defconstant SQLITE-ROW 100 "sqlite_step() has another row ready") +(defconstant SQLITE-DONE 101 "sqlite_step() has finished executing") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; +;;;; Conditions. +;;;; +(define-condition sqlite-error () + ((message :initarg :message :reader sqlite-error-message :initform "") + (code :initarg :code :reader sqlite-error-code)) + (:report (lambda (condition stream) + (let ((code (sqlite-error-code condition))) + (format stream "SQLite error [~A]: ~A" + code (sqlite-error-message condition)))))) + +(defun signal-sqlite-error (code &optional message) + (let ((condition + (make-condition 'sqlite-error + :code code + :message (if message + message + (uffi:convert-from-cstring + (sqlite-error-string code)))))) + (unless (signal condition) + (invoke-debugger condition)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; +;;;; Foreign types definitions. +;;;; +(def-foreign-type errmsg (* :unsigned-char)) +(def-foreign-type sqlite-db :pointer-void) +(def-foreign-type sqlite-vm :pointer-void) +(def-foreign-type string-pointer (* (* :unsigned-char))) +(def-foreign-type sqlite-row-pointer (* (* :unsigned-char))) + +(defvar +null-errmsg-pointer+ (make-null-pointer 'errmsg)) +(defvar +null-string-pointer-pointer+ (make-null-pointer 'string-pointer)) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Lisp types used in declarations. +;;;; +(def-type sqlite-db-type sqlite-db) +(def-type sqlite-row string-pointer) +(def-type sqlite-row-pointer-type (* string-pointer)) +(def-type sqlite-vm-pointer (* sqlite-vm)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; +;;;; Library functions. +;;;; +(defmacro def-sqlite-function (name args &key (returning :void)) + `(def-function ,name ,args + :module "sqlite" + :returning ,returning)) + +(def-sqlite-function + "sqlite_error_string" + ((error-code :int)) + :returning :cstring) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; +;;;; Core API. +;;;; +(declaim (inline %open)) +(def-sqlite-function + ("sqlite_open" %open) + ((dbname :cstring) + (mode :int) + (error-message (* errmsg))) + :returning sqlite-db) + +(declaim (inline sqlite-close)) +(def-sqlite-function + "sqlite_close" + ((db sqlite-db))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; +;;;; New API. +;;;; +(declaim (inline %compile)) +(def-sqlite-function + ("sqlite_compile" %compile) + ((db sqlite-db) + (sql :cstring) + (sql-tail (* (* :unsigned-char))) + (vm (* sqlite-vm)) + (error-message (* errmsg))) + :returning :int) + +(declaim (inline %step)) +(def-sqlite-function + ("sqlite_step" %step) + ((vm sqlite-vm) + (cols-n (* :int)) + (cols (* (* (* :unsigned-char)))) + (col-names (* (* (* :unsigned-char))))) + :returning :int) + +(declaim (inline %finalize)) +(def-sqlite-function + ("sqlite_finalize" %finalize) + ((vm sqlite-vm) + (error-message (* errmsg))) + :returning :int) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; +;;;; Extended API. +;;;; +(declaim (inline sqlite-last-insert-rowid)) +(def-sqlite-function + "sqlite_last_insert_rowid" + ((db sqlite-db)) + :returning :int) + +(declaim (inline %get-table)) +(def-sqlite-function + ("sqlite_get_table" %get-table) + ((db sqlite-db) + (sql :cstring) + (result (* (* (* :unsigned-char)))) + (rows-n (* :int)) + (cols-n (* :int)) + (error-message (* errmsg))) + :returning :int) + +(declaim (inline %free-table)) +(def-sqlite-function + ("sqlite_free_table" %free-table) + ((rows :pointer-void))) + +(declaim (inline sqlite-libversion)) +(def-sqlite-function + "sqlite_libversion" + () + :returning :cstring) + +(declaim (inline sqlite-libencoding)) +(def-sqlite-function + "sqlite_libencoding" + () + :returning :cstring) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; +;;;; Wrapper functions. +;;;; +(defparameter sqlite-version (sqlite-libversion)) +(defparameter sqlite-encoding (sqlite-libencoding)) + +(defun sqlite-open (db-name &optional (mode 0)) + (with-cstring (db-name-native db-name) + (let ((db (%open db-name-native mode +null-errmsg-pointer+))) + (if (null-pointer-p db) + (signal-sqlite-error SQLITE-ERROR + (format nil "unable to open ~A" db-name)) + db)))) + +(defun sqlite-compile (db sql) + (with-cstring (sql-native sql) + (let ((vm (allocate-foreign-object 'sqlite-vm))) + (with-foreign-object (sql-tail '(* :unsigned-char)) + (let ((result (%compile db sql-native sql-tail vm +null-errmsg-pointer+))) + (if (= result SQLITE-OK) + vm + (progn + (free-foreign-object vm) + (signal-sqlite-error result)))))))) + +(defun sqlite-step (vm) + (declare (type sqlite-vm-pointer vm)) + (with-foreign-object (cols-n :int) + (let ((cols (allocate-foreign-object '(* (* :unsigned-char)))) + (col-names (allocate-foreign-object '(* (* :unsigned-char))))) + (declare (type sqlite-row-pointer-type cols col-names)) + (let ((result (%step (deref-pointer vm 'sqlite-vm) + cols-n cols col-names))) + (cond + ((= result SQLITE-ROW) + (let ((n (deref-pointer cols-n :int))) + (values n cols col-names))) + ((= result SQLITE-DONE) + (free-foreign-object cols) + (free-foreign-object col-names) + (values 0 +null-string-pointer-pointer+ +null-string-pointer-pointer+)) + (t + (free-foreign-object cols) + (free-foreign-object col-names) + (signal-sqlite-error result))))))) + +(defun sqlite-finalize (vm) + (declare (type sqlite-vm-pointer vm)) + (let ((result (%finalize (deref-pointer vm 'sqlite-vm) +null-errmsg-pointer+))) + (if (= result SQLITE-OK) + (progn + (free-foreign-object vm) + t) + (signal-sqlite-error result)))) + +(defun sqlite-get-table (db sql) + (declare (type sqlite-db-type db)) + (with-cstring (sql-native sql) + (let ((rows (allocate-foreign-object '(* (* :unsigned-char))))) + (declare (type sqlite-row-pointer-type rows)) + (with-foreign-object (rows-n :int) + (with-foreign-object (cols-n :int) + (let ((result (%get-table db sql-native rows rows-n cols-n +null-errmsg-pointer+))) + (if (= result SQLITE-OK) + (let ((cn (deref-pointer cols-n :int)) + (rn (deref-pointer rows-n :int))) + (values rows rn cn)) + (progn + (free-foreign-object rows) + (signal-sqlite-error result))))))))) + +(declaim (inline sqlite-free-table)) +(defun sqlite-free-table (table) + (declare (type sqlite-row-pointer-type table)) + (%free-table (deref-pointer table 'sqlite-row-pointer))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; +;;;; Utility functions. +;;;; +(declaim (inline make-null-row)) +(defun make-null-row () + +null-string-pointer-pointer+) + +(declaim (inline make-null-vm)) +(defun make-null-vm () + (uffi:make-null-pointer 'sqlite-vm)) + +(declaim (inline null-row-p)) +(defun null-row-p (row) + (null-pointer-p row)) + +(declaim (inline sqlite-aref)) +(defun sqlite-aref (a n encoding) + (declare (type sqlite-row-pointer-type a)) + (convert-from-foreign-string + (deref-array (deref-pointer a 'sqlite-row-pointer) '(:array (* :unsigned-char)) n) + :encoding encoding)) + +(declaim (inline sqlite-raw-aref)) +(defun sqlite-raw-aref (a n) + (declare (type sqlite-row-pointer-type a)) + (deref-array (deref-pointer a 'sqlite-row-pointer) '(:array (* :unsigned-char)) n)) + +(declaim (inline sqlite-free-row)) +(defun sqlite-free-row (row) + (declare (type sqlite-row-pointer-type row)) + (free-foreign-object row)) diff --git a/db-sqlite/sqlite-loader.lisp b/db-sqlite/sqlite-loader.lisp new file mode 100644 index 0000000..ac77faf --- /dev/null +++ b/db-sqlite/sqlite-loader.lisp @@ -0,0 +1,40 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: sqlite-loader.lisp +;;;; Purpose: SQLite library loader using UFFI +;;;; Programmer: Aurelio Bignoli +;;;; Date Started: Nov 2003 +;;;; +;;;; This file, part of CLSQL, is Copyright (c) 2003 by Aurelio Bignoli +;;;; +;;;; 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-sqlite) + +(defvar *sqlite-supporting-libraries* '("c") + "Used only by CMU. List of library flags needed to be passed to ld +to load the SQLite library succesfully. If this differs at your site, +set to the right path before compiling or loading the system.") + +(defvar *sqlite-library-loaded* nil + "T if foreign library was able to be loaded successfully") + +(defmethod database-type-library-loaded ((database-type (eql :sqlite))) + "T if foreign library was able to be loaded successfully. " + *sqlite-library-loaded*) + +(defmethod database-type-load-foreign ((database-type (eql :sqlite))) + (clsql-uffi:find-and-load-foreign-library '("libsqlite" "sqlite") + :module "sqlite" + :supporting-libraries *sqlite-supporting-libraries*) + (setq *sqlite-library-loaded* t)) + +(clsql-sys:database-type-load-foreign :sqlite) + + + diff --git a/db-sqlite/sqlite-package.lisp b/db-sqlite/sqlite-package.lisp new file mode 100644 index 0000000..a3282ea --- /dev/null +++ b/db-sqlite/sqlite-package.lisp @@ -0,0 +1,21 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: sqlite-package.lisp +;;;; Purpose: Package definition for low-level SQLite interface +;;;; Programmer: Aurelio Bignoli +;;;; Date Started: Aug 2003 +;;;; +;;;; This file, part of CLSQL, is Copyright (c) 2003 by Aurelio Bignoli +;;;; +;;;; 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 #:clsql-sqlite + (:use #:common-lisp #:clsql-sys) + (:export #:sqlite-database)) diff --git a/db-sqlite/sqlite-sql.lisp b/db-sqlite/sqlite-sql.lisp new file mode 100644 index 0000000..ef622dd --- /dev/null +++ b/db-sqlite/sqlite-sql.lisp @@ -0,0 +1,332 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: sqlite-sql.lisp +;;;; Purpose: High-level SQLite interface +;;;; Authors: Aurelio Bignoli, Kevin Rosenberg, Marcus Pearce +;;;; Created: Aug 2003 +;;;; +;;;; This file, part of CLSQL, is Copyright (c) 2003 by Aurelio Bignoli and +;;;; Copyright (c) 2003-2010 by Kevin Rosenberg and Marcus Pearce. +;;;; +;;;; 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-sqlite) + +(defclass sqlite-database (database) + ((sqlite-db :initarg :sqlite-db :accessor sqlite-db))) + +(defmethod database-type ((database sqlite-database)) + :sqlite) + +(defmethod database-initialize-database-type ((database-type (eql :sqlite))) + t) + +(defun check-sqlite-connection-spec (connection-spec) + (check-connection-spec connection-spec :sqlite (name))) + +(defmethod database-name-from-spec (connection-spec + (database-type (eql :sqlite))) + (check-sqlite-connection-spec connection-spec) + (first connection-spec)) + +(defmethod database-connect (connection-spec (database-type (eql :sqlite))) + (check-sqlite-connection-spec connection-spec) + (handler-case + (make-instance 'sqlite-database + :name (database-name-from-spec connection-spec :sqlite) + :database-type :sqlite + :connection-spec connection-spec + :sqlite-db (sqlite:sqlite-open (first connection-spec))) + (sqlite:sqlite-error (err) + (error 'sql-connection-error + :database-type database-type + :connection-spec connection-spec + :error-id (sqlite:sqlite-error-code err) + :message (sqlite:sqlite-error-message err))))) + +(defmethod database-disconnect ((database sqlite-database)) + (sqlite:sqlite-close (sqlite-db database)) + (setf (sqlite-db database) nil) + t) + +(defmethod database-execute-command (sql-expression (database sqlite-database)) + (handler-case + (multiple-value-bind (data row-n col-n) + (sqlite:sqlite-get-table (sqlite-db database) sql-expression) + (sqlite:sqlite-free-table data) + (unless (= row-n 0) + (error 'sql-warning + :format-control + "Result set not empty: ~@(~A~) row~:P, ~@(~A~) column~:P " + :format-arguments (list row-n col-n)))) + (sqlite:sqlite-error (err) + (error 'sql-database-data-error + :database database + :expression sql-expression + :error-id (sqlite:sqlite-error-code err) + :message (sqlite:sqlite-error-message err)))) + t) + +(defstruct sqlite-result-set + (vm (sqlite:make-null-vm) + :type sqlite:sqlite-vm-pointer) + (first-row (sqlite:make-null-row) + :type sqlite:sqlite-row-pointer-type) + (col-names (sqlite:make-null-row) + :type sqlite:sqlite-row-pointer-type) + (result-types nil) + (n-col 0 :type fixnum)) + +(defmethod database-query (query-expression (database sqlite-database) result-types field-names) + (declare (optimize (speed 3) (safety 0) (debug 0) (space 0))) + (handler-case + (let ((vm (sqlite:sqlite-compile (sqlite-db database) + query-expression)) + (rows '()) + (col-names '())) + (unwind-protect + ;; Read the first row to get column number and names. + (multiple-value-bind (n-col new-row sqlite-col-names) + (sqlite:sqlite-step vm) + (declare (type sqlite:sqlite-row-pointer-type new-row)) + (when (> n-col 0) + (when field-names + (setf col-names (loop for i from 0 below n-col + collect (sqlite:sqlite-aref sqlite-col-names i (encoding database))))) + (let ((canonicalized-result-types + (canonicalize-result-types result-types n-col sqlite-col-names database))) + (flet ((extract-row-data (row) + (declare (type sqlite:sqlite-row-pointer-type row)) + (loop for i from 0 below n-col + collect (clsql-uffi:convert-raw-field + (sqlite:sqlite-raw-aref row i) + (nth i canonicalized-result-types) + :encoding (encoding database))))) + (push (extract-row-data new-row) rows) + + ;; Read subsequent rows. + (do () (nil) + (multiple-value-bind (n-col new-row) + (sqlite:sqlite-step vm) + (declare (type sqlite:sqlite-row-pointer-type new-row)) + (if (> n-col 0) + (push (extract-row-data new-row) rows) + (return)))))))) + (sqlite:sqlite-finalize vm)) + (values (nreverse rows) col-names)) + (sqlite:sqlite-error (err) + (error 'sql-database-data-error + :database database + :expression query-expression + :error-id (sqlite:sqlite-error-code err) + :message (sqlite:sqlite-error-message err))))) + +(defmethod database-query-result-set ((query-expression string) + (database sqlite-database) + &key result-types full-set) + (let ((vm nil)) + (handler-case + (progn + (setf vm (sqlite:sqlite-compile (sqlite-db database) + query-expression)) + ;;; To obtain column number/datatypes we have to read the first row. + (multiple-value-bind (n-col cols col-names) + (sqlite:sqlite-step vm) + (declare (type sqlite:sqlite-row-pointer-type cols)) + (let ((result-set (make-sqlite-result-set + :vm vm + :first-row cols + :n-col n-col + :col-names col-names + :result-types + (canonicalize-result-types + result-types + n-col + col-names + database)))) + (if full-set + (values result-set n-col nil) + (values result-set n-col))))) + (sqlite:sqlite-error (err) + (progn + (when vm + ;; The condition was thrown by sqlite-step, vm must be + ;; deallocated. + (ignore-errors + (sqlite:sqlite-finalize vm))) + (error 'sql-database-data-error + :database database + :expression query-expression + :error-id (sqlite:sqlite-error-code err) + :message (sqlite:sqlite-error-message err))11))))) + +(defun canonicalize-result-types (result-types n-col col-names database) + (when result-types + (let ((raw-types (if (eq :auto result-types) + (loop for j from n-col below (* 2 n-col) + collect (ensure-keyword + (sqlite:sqlite-aref col-names j (encoding database)))) + result-types))) + (loop for type in raw-types + collect + (case type + ((:int :integer :tinyint) + :int32) + (:long #+(or x86-64 64bit) :int64 #-(or x86-64 64bit) :int32) + (:bigint + :int64) + ((:float :double) + :double) + ((:numeric) + :number) + (otherwise + :string)))))) + +(defmethod database-dump-result-set (result-set (database sqlite-database)) + (handler-case + (sqlite:sqlite-finalize (sqlite-result-set-vm result-set)) + (sqlite:sqlite-error (err) + (error 'sql-database-error + :message + (format nil "Error finalizing SQLite VM: ~A" + (sqlite:sqlite-error-message err)))))) + +(defmethod database-store-next-row (result-set (database sqlite-database) list) + (let ((n-col (sqlite-result-set-n-col result-set)) + (result-types (sqlite-result-set-result-types result-set))) + (if (= n-col 0) + ;; empty result set + nil + (let ((row (sqlite-result-set-first-row result-set))) + (if (sqlite:null-row-p row) + ;; First row already used. fetch another row from DB. + (handler-case + (multiple-value-bind (n new-row col-names) + (sqlite:sqlite-step (sqlite-result-set-vm result-set)) + (declare (ignore n col-names) + (type sqlite:sqlite-row-pointer-type new-row)) + (if (sqlite:null-row-p new-row) + (return-from database-store-next-row nil) + (setf row new-row))) + (sqlite:sqlite-error (err) + (error 'sql-database-error + :message + (format nil "Error in sqlite-step: ~A" + (sqlite:sqlite-error-message err))))) + + ;; Use the row previously read by database-query-result-set. + (setf (sqlite-result-set-first-row result-set) + (sqlite:make-null-row))) + (loop for i = 0 then (1+ i) + for rest on list + do (setf (car rest) + (clsql-uffi:convert-raw-field + (sqlite:sqlite-raw-aref row i) + (nth i result-types) + :encoding (encoding database)))) + (sqlite:sqlite-free-row row) + t)))) + +;;; Object listing + +(defmethod database-list-tables-and-sequences ((database sqlite-database) &key owner) + (declare (ignore owner)) + ;; Query is copied from .table command of sqlite comamnd line utility. + (mapcar #'car (database-query + "SELECT name FROM sqlite_master WHERE type='table' UNION ALL SELECT name FROM sqlite_temp_master WHERE type='table' ORDER BY name" + database nil nil))) + +(defmethod database-list-tables ((database sqlite-database) &key owner) + (remove-if #'(lambda (s) + (and (>= (length s) 11) + (string-equal (subseq s 0 11) "_CLSQL_SEQ_"))) + (database-list-tables-and-sequences database :owner owner))) + +(defmethod database-list-views ((database sqlite-database) + &key (owner nil)) + (declare (ignore owner)) + (mapcar #'car (database-query + "SELECT name FROM sqlite_master WHERE type='view' UNION ALL SELECT name FROM sqlite_temp_master WHERE type='view' ORDER BY name" + database nil nil))) + +(defmethod database-list-indexes ((database sqlite-database) + &key (owner nil)) + (declare (ignore owner)) + (mapcar #'car (database-query + "SELECT name FROM sqlite_master WHERE type='index' UNION ALL SELECT name FROM sqlite_temp_master WHERE type='index' ORDER BY name" + database nil nil))) + +(defmethod database-list-table-indexes (table (database sqlite-database) + &key (owner nil)) + (declare (ignore owner)) + (let ((*print-circle* nil)) + (mapcar #'car + (database-query + (format + nil + "SELECT name FROM sqlite_master WHERE type='index' AND tbl_name='~A' UNION ALL SELECT name FROM sqlite_temp_master WHERE type='index' AND tbl_name='~A' ORDER BY name" + table table) + database nil nil)))) + +(declaim (inline sqlite-table-info)) +(defun sqlite-table-info (table database) + (database-query (format nil "PRAGMA table_info('~A')" table) + database nil nil)) + +(defmethod database-list-attributes (table (database sqlite-database) + &key (owner nil)) + (declare (ignore owner)) + (mapcar #'(lambda (table-info) (second table-info)) + (sqlite-table-info table database))) + +(defmethod database-attribute-type (attribute table + (database sqlite-database) + &key (owner nil)) + (declare (ignore owner)) + (loop for field-info in (sqlite-table-info table database) + when (string= attribute (second field-info)) + return + (let* ((raw-type (third field-info)) + (start-length (position #\( raw-type)) + (type (if start-length + (subseq raw-type 0 start-length) + raw-type)) + (length (if start-length + (parse-integer (subseq raw-type (1+ start-length)) + :junk-allowed t) + nil))) + (values (when type (ensure-keyword type)) + length + nil + (if (string-equal (fourth field-info) "0") + 1 0))))) + +(defmethod database-create (connection-spec (type (eql :sqlite))) + (declare (ignore connection-spec)) + ;; databases are created automatically by SQLite + t) + +(defmethod database-destroy (connection-spec (type (eql :sqlite))) + (destructuring-bind (name) connection-spec + (if (probe-file name) + (delete-file name) + nil))) + +(defmethod database-probe (connection-spec (type (eql :sqlite))) + (destructuring-bind (name) connection-spec + ;; TODO: Add a test that this file is a real sqlite database + (or (string-equal ":memory:" name) + (and (probe-file name) t)))) + +;;; Database capabilities + +(defmethod db-type-has-boolean-where? ((db-type (eql :sqlite))) + nil) + + + diff --git a/db-sqlite3/sqlite3-api.lisp b/db-sqlite3/sqlite3-api.lisp new file mode 100644 index 0000000..942246e --- /dev/null +++ b/db-sqlite3/sqlite3-api.lisp @@ -0,0 +1,367 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: sqlite3-api.lisp +;;;; Purpose: Low-level SQLite3 interface using UFFI +;;;; Authors: Aurelio Bignoli +;;;; Created: Oct 2004 +;;;; +;;;; This file, part of CLSQL, is Copyright (c) 2004 by Aurelio Bignoli +;;;; +;;;; 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 #:sqlite3 + (:use #:common-lisp #:uffi) + (:export + ;;; Conditions + #:sqlite3-error + #:sqlite3-error-code + #:sqlite3-error-message + + ;;; API functions. + #:sqlite3-open + #:sqlite3-close + + #:sqlite3-prepare + #:sqlite3-step + #:sqlite3-finalize + + #:sqlite3-column-count + #:sqlite3-column-name + #:sqlite3-column-type + #:sqlite3-column-text + #:sqlite3-column-bytes + #:sqlite3-column-blob + + ;;; Types. + #:sqlite3-db + #:sqlite3-db-type + #:sqlite3-stmt-type + #:unsigned-char-ptr-type + #:null-stmt + + ;;; Columnt types. + #:SQLITE-INTEGER + #:SQLITE-FLOAT + #:SQLITE-TEXT + #:SQLITE-BLOB + #:SQLITE-NULL)) + +(in-package #:sqlite3) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; +;;;; Return values for sqlite_exec() and sqlite_step() +;;;; +(defconstant SQLITE-OK 0 "Successful result") +(defconstant SQLITE-ERROR 1 "SQL error or missing database") +(defconstant SQLITE-INTERNAL 2 "An internal logic error in SQLite") +(defconstant SQLITE-PERM 3 "Access permission denied") +(defconstant SQLITE-ABORT 4 "Callback routine requested an abort") +(defconstant SQLITE-BUSY 5 "The database file is locked") +(defconstant SQLITE-LOCKED 6 "A table in the database is locked") +(defconstant SQLITE-NOMEM 7 "A malloc() failed") +(defconstant SQLITE-READONLY 8 "Attempt to write a readonly database") +(defconstant SQLITE-INTERRUPT 9 "Operation terminated by sqlite3_interrupt()") +(defconstant SQLITE-IOERR 10 "Some kind of disk I/O error occurred") +(defconstant SQLITE-CORRUPT 11 "The database disk image is malformed") +(defconstant SQLITE-NOTFOUND 12 "(Internal Only) Table or record not found") +(defconstant SQLITE-FULL 13 "Insertion failed because database is full") +(defconstant SQLITE-CANTOPEN 14 "Unable to open the database file") +(defconstant SQLITE-PROTOCOL 15 "Database lock protocol error") +(defconstant SQLITE-EMPTY 16 "Database is empty") +(defconstant SQLITE-SCHEMA 17 "The database schema changed") +(defconstant SQLITE-TOOBIG 18 "Too much data for one row of a table") +(defconstant SQLITE-CONSTRAINT 19 "Abort due to contraint violation") +(defconstant SQLITE-MISMATCH 20 "Data type mismatch") +(defconstant SQLITE-MISUSE 21 "Library used incorrectly") +(defconstant SQLITE-NOLFS 22 "Uses OS features not supported on host") +(defconstant SQLITE-AUTH 23 "Authorization denied") +(defconstant SQLITE-FORMAT 24 "Auxiliary database format error") +(defconstant SQLITE-RANGE 25 "2nd parameter to sqlite3_bind out of range") +(defconstant SQLITE-NOTADB 26 "File opened that is not a database file") +(defconstant SQLITE-ROW 100 "sqlite3_step() has another row ready") +(defconstant SQLITE-DONE 101 "sqlite3_step() has finished executing") + +(defparameter error-codes + (list + (cons SQLITE-OK "not an error") + (cons SQLITE-ERROR "SQL logic error or missing database") + (cons SQLITE-INTERNAL "internal SQLite implementation flaw") + (cons SQLITE-PERM "access permission denied") + (cons SQLITE-ABORT "callback requested query abort") + (cons SQLITE-BUSY "database is locked") + (cons SQLITE-LOCKED "database table is locked") + (cons SQLITE-NOMEM "out of memory") + (cons SQLITE-READONLY "attempt to write a readonly database") + (cons SQLITE-INTERRUPT "interrupted") + (cons SQLITE-IOERR "disk I/O error") + (cons SQLITE-CORRUPT "database disk image is malformed") + (cons SQLITE-NOTFOUND "table or record not found") + (cons SQLITE-FULL "database is full") + (cons SQLITE-CANTOPEN "unable to open database file") + (cons SQLITE-PROTOCOL "database locking protocol failure") + (cons SQLITE-EMPTY "table contains no data") + (cons SQLITE-SCHEMA "database schema has changed") + (cons SQLITE-TOOBIG "too much data for one table row") + (cons SQLITE-CONSTRAINT "constraint failed") + (cons SQLITE-MISMATCH "datatype mismatch") + (cons SQLITE-MISUSE "library routine called out of sequence") + (cons SQLITE-NOLFS "kernel lacks large file support") + (cons SQLITE-AUTH "authorization denied") + (cons SQLITE-FORMAT "auxiliary database format error") + (cons SQLITE-RANGE "bind index out of range") + (cons SQLITE-NOTADB "file is encrypted or is not a database")) + "Association list of error messages.") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; +;;;; Column types. +;;;; +(defconstant SQLITE-INTEGER 1) +(defconstant SQLITE-FLOAT 2) +(defconstant SQLITE-TEXT 3) +(defconstant SQLITE-BLOB 4) +(defconstant SQLITE-NULL 5) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; +;;;; Foreign types definitions. +;;;; +(def-foreign-type sqlite3-db :pointer-void) +(def-foreign-type sqlite3-stmt :pointer-void) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; +;;;; Lisp types definitions. +;;;; +(def-type sqlite3-db-type sqlite3-db) +(def-type sqlite3-db-ptr-type (* sqlite3-db)) +(def-type sqlite3-stmt-type sqlite3-stmt) +(def-type sqlite3-stmt-ptr-type (* sqlite3-stmt)) +(def-type unsigned-char-ptr-type (* :unsigned-char)) + +(defparameter null-stmt (make-null-pointer :void)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Hash tables for db and statement pointers. +;;; +(defvar *db-pointers* (make-hash-table)) +(defvar *stmt-pointers* (make-hash-table)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; +;;;; Conditions. +;;;; +(define-condition sqlite3-error () + ((message :initarg :message :reader sqlite3-error-message :initform "") + (code :initarg :code :reader sqlite3-error-code)) + (:report (lambda (condition stream) + (format stream "Sqlite3 error [~A]: ~A" + (sqlite3-error-code condition) + (sqlite3-error-message condition))))) + +(defgeneric signal-sqlite3-error (db)) +(defmethod signal-sqlite3-error (db) + (let ((condition + (make-condition 'sqlite3-error + :code (sqlite3-errcode db) + :message (convert-from-cstring (sqlite3-errmsg db))))) + (unless (signal condition) + (invoke-debugger condition)))) + +(defmethod signal-sqlite3-error ((code number)) + (let ((condition + (make-condition 'sqlite3-error + :code code + :message (let ((s (cdr (assoc code error-codes)))) + (if s + s + "unknown error"))))) + (unless (signal condition) + (invoke-debugger condition)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; +;;;; Library functions. +;;;; +(defmacro def-sqlite3-function (name args &key (returning :void)) + `(def-function ,name ,args + :module "sqlite3" + :returning ,returning)) + +(declaim (inline %errcode)) +(def-sqlite3-function + "sqlite3_errcode" + ((db sqlite3-db)) + :returning :int) + +(declaim (inline %errmsg)) +(def-sqlite3-function + "sqlite3_errmsg" + ((db sqlite3-db)) + :returning :cstring) + +(declaim (inline %open)) +(def-sqlite3-function + ("sqlite3_open" %open) + ((dbname :cstring) + (db (* sqlite3-db))) + :returning :int) + +(declaim (inline %close)) +(def-sqlite3-function + ("sqlite3_close" %close) + ((db sqlite3-db)) + :returning :int) + +(declaim (inline %prepare)) +(def-sqlite3-function + ("sqlite3_prepare" %prepare) + ((db sqlite3-db) + (sql :cstring) + (len :int) + (stmt (* sqlite3-stmt)) + (sql-tail (* (* :unsigned-char)))) + :returning :int) + +(declaim (inline %step)) +(def-sqlite3-function + ("sqlite3_step" %step) + ((stmt sqlite3-stmt)) + :returning :int) + +(declaim (inline %finalize)) +(def-sqlite3-function + ("sqlite3_finalize" %finalize) + ((stmt sqlite3-stmt)) + :returning :int) + +(declaim (inline sqlite3-column-count)) +(def-sqlite3-function + "sqlite3_column_count" + ((stmt sqlite3-stmt)) + :returning :int) + +(declaim (inline %column-name)) +(def-sqlite3-function + ("sqlite3_column_name" %column-name) + ((stmt sqlite3-stmt) + (n-col :int)) + :returning :cstring) + +(declaim (inline sqlite3-column-type)) +(def-sqlite3-function + "sqlite3_column_type" + ((stmt sqlite3-stmt) + (n-col :int)) + :returning :int) + +(declaim (inline sqlite3-column-text)) +(def-sqlite3-function + "sqlite3_column_text" + ((stmt sqlite3-stmt) + (n-col :int)) + :returning (* :unsigned-char)) + +(declaim (inline sqlite3-column-bytes)) +(def-sqlite3-function + "sqlite3_column_bytes" + ((stmt sqlite3-stmt) + (n-col :int)) + :returning :int) + +(declaim (inline sqlite3-column-blob)) +(def-sqlite3-function + "sqlite3_column_blob" + ((stmt sqlite3-stmt) + (n-col :int)) + :returning :pointer-void) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; +;;;; wrapper functions. +;;;; +(defun sqlite3-open (db &optional (mode 0) + &aux (db-name (etypecase db + (pathname (namestring db)) + (string db)))) + (declare (ignore mode) (type string db-name)) + (let ((dbp (allocate-foreign-object 'sqlite3-db))) + (declare (type sqlite3-db-ptr-type dbp)) + (with-cstring (db-name-native db-name) + (let ((result (%open db-name-native dbp))) + (if (/= result 0) + (progn + ;; According to docs, the db must be closed even in case + ;; of error. + (%close (deref-pointer dbp 'sqlite3-db)) + (free-foreign-object dbp) + (signal-sqlite3-error result)) + (let ((db (deref-pointer dbp 'sqlite3-db))) + (declare (type sqlite3-db-type db)) + (setf (gethash db *db-pointers*) dbp) + db)))))) + +(declaim (ftype (function (sqlite3-db-type) t) sqlite3-close)) +(defun sqlite3-close (db) + (declare (type sqlite3-db-type db)) + (let ((result (%close db))) + (if (/= result 0) + (signal-sqlite3-error result) + (progn + (free-foreign-object (gethash db *db-pointers*)) + (remhash db *db-pointers*) + t)))) + +(declaim (ftype (function (sqlite3-db-type string) sqlite3-stmt-type) sqlite3-prepare)) +(defun sqlite3-prepare (db sql) + (declare (type sqlite3-db-type db)) + (with-cstring (sql-native sql) + (let ((stmtp (allocate-foreign-object 'sqlite3-stmt))) + (declare (type sqlite3-stmt-ptr-type stmtp)) + (with-foreign-object (sql-tail '(* :unsigned-char)) + (let ((result (%prepare db sql-native -1 stmtp sql-tail))) + (if (/= result SQLITE-OK) + (progn + (unless (null-pointer-p stmtp) + ;; There is an error, but a statement has been allocated: + ;; finalize it (better safe than sorry). + (%finalize (deref-pointer stmtp 'sqlite3-stmt))) + (free-foreign-object stmtp) + (signal-sqlite3-error db)) + (let ((stmt (deref-pointer stmtp 'sqlite3-stmt))) + (declare (type sqlite3-stmt-type stmt)) + (setf (gethash stmt *stmt-pointers*) stmtp) + stmt))))))) + +(declaim (ftype (function (sqlite3-stmt-type) t) sqlite3-step)) +(defun sqlite3-step (stmt) + (declare (type sqlite3-stmt-type stmt)) + (let ((result (%step stmt))) + (cond ((= result SQLITE-ROW) t) + ((= result SQLITE-DONE) nil) + (t (signal-sqlite3-error result))))) + +(declaim (ftype (function (sqlite3-stmt-type) t) sqlite3-finalize)) +(defun sqlite3-finalize (stmt) + (declare (type sqlite3-stmt-type stmt)) + (let ((result (%finalize stmt))) + (if (/= result SQLITE-OK) + (signal-sqlite3-error result) + (progn + (free-foreign-object (gethash stmt *stmt-pointers*)) + (remhash stmt *stmt-pointers*) + t)))) + +(declaim (inline sqlite3-column-name)) +(defun sqlite3-column-name (stmt n) + (declare (type sqlite3-stmt-type stmt) (type fixnum n)) + (convert-from-cstring (%column-name stmt n))) diff --git a/db-sqlite3/sqlite3-loader.lisp b/db-sqlite3/sqlite3-loader.lisp new file mode 100644 index 0000000..90264ea --- /dev/null +++ b/db-sqlite3/sqlite3-loader.lisp @@ -0,0 +1,37 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: sqlite3-loader.lisp +;;;; Purpose: Sqlite3 library loader using UFFI +;;;; Programmer: Aurelio Bignoli +;;;; Date Started: Oct 2004 +;;;; +;;;; This file, part of CLSQL, is Copyright (c) 2004 by Aurelio Bignoli +;;;; +;;;; 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-sqlite3) + +(defvar *sqlite3-supporting-libraries* '("c") + "Used only by CMU. List of library flags needed to be passed to ld +to load the Sqlite3 library succesfully. If this differs at your site, +set to the right path before compiling or loading the system.") + +(defvar *sqlite3-library-loaded* nil + "T if foreign library was able to be loaded successfully") + +(defmethod database-type-library-loaded ((database-type (eql :sqlite3))) + "T if foreign library was able to be loaded successfully. " + *sqlite3-library-loaded*) + +(defmethod database-type-load-foreign ((database-type (eql :sqlite3))) + (clsql-uffi:find-and-load-foreign-library '("libsqlite3" "sqlite3") + :module "sqlite3" + :supporting-libraries *sqlite3-supporting-libraries*) + (setq *sqlite3-library-loaded* t)) + +(clsql-sys:database-type-load-foreign :sqlite3) diff --git a/db-sqlite3/sqlite3-methods.lisp b/db-sqlite3/sqlite3-methods.lisp new file mode 100644 index 0000000..5ce0ac2 --- /dev/null +++ b/db-sqlite3/sqlite3-methods.lisp @@ -0,0 +1,20 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- + +(in-package #:clsql-sys) + + +(defmethod database-pkey-constraint ((class standard-db-class) + (database clsql-sqlite3:sqlite3-database)) + (let* ((keys (keyslots-for-class class)) + (cons (when (= 1 (length keys)) + (view-class-slot-db-constraints (first keys))))) + ;; This method generates primary key constraints part of the table + ;; definition. For Sqlite autoincrement primary keys to work properly + ;; this part of the table definition must be left out (IFF autoincrement) . + (when (or (null cons) ;; didnt have constraints to check + ;; didnt have auto-increment + (null (intersection + +auto-increment-names+ + (listify cons)))) + (call-next-method)))) + diff --git a/db-sqlite3/sqlite3-package.lisp b/db-sqlite3/sqlite3-package.lisp new file mode 100644 index 0000000..2f54f51 --- /dev/null +++ b/db-sqlite3/sqlite3-package.lisp @@ -0,0 +1,21 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: sqlite-package.lisp +;;;; Purpose: Package definition for low-level SQLite3 interface +;;;; Programmer: Aurelio Bignoli +;;;; Date Started: Oct 2004 +;;;; +;;;; This file, part of CLSQL, is Copyright (c) 2004 by Aurelio Bignoli +;;;; +;;;; 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 #:clsql-sqlite3 + (:use #:common-lisp #:clsql-sys) + (:export #:sqlite3-database)) diff --git a/db-sqlite3/sqlite3-sql.lisp b/db-sqlite3/sqlite3-sql.lisp new file mode 100644 index 0000000..8ce592c --- /dev/null +++ b/db-sqlite3/sqlite3-sql.lisp @@ -0,0 +1,353 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: sqlite-sql.lisp +;;;; Purpose: High-level SQLite3 interface +;;;; Authors: Aurelio Bignoli & Kevin Rosenberg +;;;; Created: Oct 2004 +;;;; +;;;; This file, part of CLSQL, is Copyright (c) 2004-2010 by Aurelio Bignoli & Kevin 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-sqlite3) + +(defclass sqlite3-database (database) + ((sqlite3-db :initarg :sqlite3-db :accessor sqlite3-db))) + +(defmethod database-type ((database sqlite3-database)) + :sqlite3) + +(defmethod database-initialize-database-type ((database-type (eql :sqlite3))) + t) + +(defun check-sqlite3-connection-spec (connection-spec) + (check-connection-spec connection-spec :sqlite3 (name &optional init-foreign-func))) + +(defmethod database-name-from-spec (connection-spec + (database-type (eql :sqlite3))) + (check-sqlite3-connection-spec connection-spec) + (princ-to-string (first connection-spec))) + +(defmethod database-connect (connection-spec (database-type (eql :sqlite3))) + (check-sqlite3-connection-spec connection-spec) + (handler-case + (let ((db (sqlite3:sqlite3-open (first connection-spec))) + (init-foreign-func (second connection-spec))) + (declare (type sqlite3:sqlite3-db-type db)) + (when init-foreign-func + (handler-case + (funcall init-foreign-func db) + (condition (c) + (progn + (sqlite3:sqlite3-close db) + (error c))))) + (make-instance 'sqlite3-database + :name (database-name-from-spec connection-spec :sqlite3) + :database-type :sqlite3 + :connection-spec connection-spec + :sqlite3-db db)) + (sqlite3:sqlite3-error (err) + (error 'sql-connection-error + :database-type database-type + :connection-spec connection-spec + :error-id (sqlite3:sqlite3-error-code err) + :message (sqlite3:sqlite3-error-message err))))) + +(defmethod database-disconnect ((database sqlite3-database)) + (sqlite3:sqlite3-close (sqlite3-db database)) + (setf (sqlite3-db database) nil) + t) + +(defmethod database-execute-command (sql-expression (database sqlite3-database)) + (handler-case + (let ((stmt (sqlite3:sqlite3-prepare (sqlite3-db database) sql-expression))) + (declare (type sqlite3:sqlite3-stmt-type stmt)) + (when stmt + (unwind-protect + (sqlite3:sqlite3-step stmt) + (sqlite3:sqlite3-finalize stmt)))) + (sqlite3:sqlite3-error (err) + (error 'sql-database-data-error + :database database + :expression sql-expression + :error-id (sqlite3:sqlite3-error-code err) + :message (sqlite3:sqlite3-error-message err)))) + t) + +(defstruct sqlite3-result-set + (stmt sqlite3:null-stmt + :type sqlite3:sqlite3-stmt-type) + (n-col 0 :type fixnum) + (col-names '()) + (result-types '())) + +(declaim (ftype (function (sqlite3:sqlite3-stmt-type fixnum t) list) get-result-types)) +(defun get-result-types (stmt n-col result-types) + (declare (type sqlite3:sqlite3-stmt-type stmt) (type fixnum n-col)) + (if (eq :auto result-types) + (loop for n from 0 below n-col + collect (let ((column-type (sqlite3:sqlite3-column-type stmt n))) + (cond + ((= column-type sqlite3:SQLITE-INTEGER) :int64) + ((= column-type sqlite3:SQLITE-FLOAT) :double) + ((= column-type sqlite3:SQLITE-TEXT) :string) + ((= column-type sqlite3:SQLITE-BLOB) :blob) + ((= column-type sqlite3:SQLITE-NULL) :string) + (t :string)))) + (loop for type in result-types + collect (case type + ((:int :integer :tinyint) :int32) + (:long #+(or x86-64 64bit) :int64 #-(or x86-64 64bit) :int32) + (:bigint :int64) + ((:float :double) :double) + ((:numeric) :number) + (otherwise :string))))) + +(defmethod database-query-result-set ((query-expression string) + (database sqlite3-database) + &key result-types full-set) + (let ((stmt sqlite3:null-stmt)) + (declare (type sqlite3:sqlite3-stmt-type stmt)) + (handler-case + (progn + (setf stmt (sqlite3:sqlite3-prepare (sqlite3-db database) + query-expression)) + (let* ((n-col (if (sqlite3:sqlite3-step stmt) + ;; Non empty result set. + (sqlite3:sqlite3-column-count stmt) + ;; Empty result set. + 0)) + (result-set (make-sqlite3-result-set + :stmt stmt + :n-col n-col + :col-names (loop for n from 0 below n-col + collect (sqlite3:sqlite3-column-name stmt n)) + :result-types (when (> n-col 0) + (get-result-types stmt n-col result-types))))) + (if full-set + (values result-set n-col nil) + (values result-set n-col)))) + (sqlite3:sqlite3-error (err) + (progn + (unless (eq stmt sqlite3:null-stmt) + (ignore-errors + (sqlite3:sqlite3-finalize stmt))) + (error 'sql-database-data-error + :database database + :expression query-expression + :error-id (sqlite3:sqlite3-error-code err) + :message (sqlite3:sqlite3-error-message err))))))) + +(defmethod database-dump-result-set (result-set (database sqlite3-database)) + (handler-case + (sqlite3:sqlite3-finalize (sqlite3-result-set-stmt result-set)) + (sqlite3:sqlite3-error (err) + (error 'sql-database-error + :message + (format nil "Error finalizing SQLite3 statement: ~A" + (sqlite3:sqlite3-error-message err)))))) + +(defmethod database-store-next-row (result-set (database sqlite3-database) list) + (let ((n-col (sqlite3-result-set-n-col result-set))) + (if (= n-col 0) + ;; empty result set. + nil + ;; Non-empty set. + (let ((stmt (sqlite3-result-set-stmt result-set))) + (declare (type sqlite3:sqlite3-stmt-type stmt)) + ;; Store row in list. + (loop for i = 0 then (1+ i) + for rest on list + for types = (sqlite3-result-set-result-types result-set) then (rest types) + do (setf (car rest) + (if (eq (first types) :blob) + (clsql-uffi:convert-raw-field + (sqlite3:sqlite3-column-blob stmt i) + (car types) + :length (sqlite3:sqlite3-column-bytes stmt i) + :encoding (encoding database)) + (clsql-uffi:convert-raw-field + (sqlite3:sqlite3-column-text stmt i) + (car types) + :encoding (encoding database))))) + ;; Advance result set cursor. + (handler-case + (unless (sqlite3:sqlite3-step stmt) + (setf (sqlite3-result-set-n-col result-set) 0)) + (sqlite3:sqlite3-error (err) + (error 'sql-database-error + :message (format nil "Error in sqlite3-step: ~A" + (sqlite3:sqlite3-error-message err))))) + t)))) + + +(defmethod database-query (query-expression (database sqlite3-database) result-types field-names) + (declare (optimize (speed 3) (safety 0) (debug 0) (space 0))) + (handler-case + (let ((stmt (sqlite3:sqlite3-prepare (sqlite3-db database) + query-expression)) + (rows '()) + (col-names '())) + (declare (type sqlite3:sqlite3-stmt-type stmt)) + (unwind-protect + (when (sqlite3:sqlite3-step stmt) + (let ((n-col (sqlite3:sqlite3-column-count stmt))) + (flet ((extract-row-data () + (loop for i from 0 below n-col + for types = (get-result-types stmt n-col result-types) then (rest types) + collect (if (eq (first types) :blob) + (clsql-uffi:convert-raw-field + (sqlite3:sqlite3-column-blob stmt i) + (car types) + :length (sqlite3:sqlite3-column-bytes stmt i) + :encoding (encoding database)) + (clsql-uffi:convert-raw-field + (sqlite3:sqlite3-column-text stmt i) + (car types) + :encoding (encoding database)))))) + (when field-names + (setf col-names (loop for n from 0 below n-col + collect (sqlite3:sqlite3-column-name stmt n)))) + (push (extract-row-data) rows) + (do* () (nil) + (if (sqlite3:sqlite3-step stmt) + (push (extract-row-data) rows) + (return)))))) + (sqlite3:sqlite3-finalize stmt)) + (values (nreverse rows) col-names)) + (sqlite3:sqlite3-error (err) + (error 'sql-database-data-error + :database database + :expression query-expression + :error-id (sqlite3:sqlite3-error-code err) + :message (sqlite3:sqlite3-error-message err))))) + +;;; Object listing + +(defmethod database-list-tables-and-sequences ((database sqlite3-database) &key owner) + (declare (ignore owner)) + ;; Query is copied from .table command of sqlite3 command line utility. + (mapcar #'car (database-query + "SELECT name FROM sqlite_master WHERE type='table' UNION ALL SELECT name FROM sqlite_temp_master WHERE type='table' ORDER BY name" + database nil nil))) + +(defmethod database-list-tables ((database sqlite3-database) &key owner) + (remove-if #'(lambda (s) + (and (>= (length s) 11) + (string-equal (subseq s 0 11) "_CLSQL_SEQ_"))) + (database-list-tables-and-sequences database :owner owner))) + +(defmethod database-list-views ((database sqlite3-database) + &key (owner nil)) + (declare (ignore owner)) + (mapcar #'car (database-query + "SELECT name FROM sqlite_master WHERE type='view' UNION ALL SELECT name FROM sqlite_temp_master WHERE type='view' ORDER BY name" + database nil nil))) + +(defmethod database-list-indexes ((database sqlite3-database) + &key (owner nil)) + (declare (ignore owner)) + (mapcar #'car (database-query + "SELECT name FROM sqlite_master WHERE type='index' UNION ALL SELECT name FROM sqlite_temp_master WHERE type='index' ORDER BY name" + database nil nil))) + +(defmethod database-list-table-indexes (table (database sqlite3-database) + &key (owner nil)) + (declare (ignore owner)) + (let ((*print-circle* nil)) + (mapcar #'car + (database-query + (format + nil + "SELECT name FROM sqlite_master WHERE type='index' AND tbl_name='~A' UNION ALL SELECT name FROM sqlite_temp_master WHERE type='index' AND tbl_name='~A' ORDER BY name" + table table) + database nil nil)))) + +(declaim (inline sqlite3-table-info)) +(defun sqlite3-table-info (table database) + (let ((sql (format nil "PRAGMA table_info('~A')" + (clsql-sys::unescaped-database-identifier table)))) + (database-query sql database nil nil))) + +(defmethod database-list-attributes (table (database sqlite3-database) + &key (owner nil)) + (declare (ignore owner)) + (mapcar #'(lambda (table-info) (second table-info)) + (sqlite3-table-info table database))) + +(defmethod database-attribute-type (attribute table + (database sqlite3-database) + &key (owner nil)) + (declare (ignore owner)) + + (loop for field-info in (sqlite3-table-info table database) + when (string= (clsql-sys::unescaped-database-identifier attribute) + (second field-info)) + return + (let* ((raw-type (third field-info)) + (start-length (position #\( raw-type)) + (type (string-trim clsql-sys::+whitespace-chars+ + (if start-length + (subseq raw-type 0 start-length) + raw-type))) + (length (if start-length + (parse-integer (subseq raw-type (1+ start-length)) + :junk-allowed t) + nil))) + (values (when type (ensure-keyword type)) + length + nil + (if (string-equal (fourth field-info) "0") + 1 0))))) + +(defmethod database-last-auto-increment-id ((database sqlite3-database) table column) + (declare (ignore table column)) + (car (query "SELECT LAST_INSERT_ROWID();" + :flatp t :field-names nil + :database database))) + +(defmethod database-create (connection-spec (type (eql :sqlite3))) + (declare (ignore connection-spec)) + ;; databases are created automatically by Sqlite3 + t) + +(defmethod database-destroy (connection-spec (type (eql :sqlite3))) + (destructuring-bind (name) connection-spec + (if (probe-file name) + (delete-file name) + nil))) + +(defmethod database-probe (connection-spec (type (eql :sqlite3))) + (destructuring-bind (name) connection-spec + ;; TODO: Add a test that this file is a real sqlite3 database + (or (string-equal ":memory:" name) + (and (probe-file name) t)))) + +(defmethod database-get-type-specifier ((type (eql 'integer)) + args database + (db-type (eql :sqlite3))) + (declare (ignore database)) + (if args + (format nil "INTEGER(~A)" (car args)) + "INTEGER")) + +(defmethod database-get-type-specifier ((type (eql 'integer)) + args database + (db-type (eql :sqlite3))) + (declare (ignore database)) + (if args + (format nil "INTEGER(~A)" (car args)) + "INTEGER")) + +;;; Database capabilities + +(defmethod db-type-has-boolean-where? ((db-type (eql :sqlite3))) + nil) + +(defmethod db-type-has-auto-increment? ((db-type (eql :sqlite3))) + t) diff --git a/doc/COPYING.GFDL b/doc/COPYING.GFDL new file mode 100644 index 0000000..99ab861 --- /dev/null +++ b/doc/COPYING.GFDL @@ -0,0 +1,330 @@ + GNU Free Documentation License + Version 1.1, March 2000 + + Copyright (C) 2000 Free Software Foundation, Inc. + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + +0. PREAMBLE + +The purpose of this License is to make a manual, textbook, or other +written document "free" in the sense of freedom: to assure everyone +the effective freedom to copy and redistribute it, with or without +modifying it, either commercially or noncommercially. Secondarily, +this License preserves for the author and publisher a way to get +credit for their work, while not being considered responsible for +modifications made by others. + +This License is a kind of "copyleft", which means that derivative +works of the document must themselves be free in the same sense. It +complements the GNU General Public License, which is a copyleft +license designed for free software. + +We have designed this License in order to use it for manuals for free +software, because free software needs free documentation: a free +program should come with manuals providing the same freedoms that the +software does. But this License is not limited to software manuals; +it can be used for any textual work, regardless of subject matter or +whether it is published as a printed book. We recommend this License +principally for works whose purpose is instruction or reference. + + +1. APPLICABILITY AND DEFINITIONS + +This License applies to any manual or other work that contains a +notice placed by the copyright holder saying it can be distributed +under the terms of this License. The "Document", below, refers to any +such manual or work. Any member of the public is a licensee, and is +addressed as "you". + +A "Modified Version" of the Document means any work containing the +Document or a portion of it, either copied verbatim, or with +modifications and/or translated into another language. + +A "Secondary Section" is a named appendix or a front-matter section of +the Document that deals exclusively with the relationship of the +publishers or authors of the Document to the Document's overall subject +(or to related matters) and contains nothing that could fall directly +within that overall subject. (For example, if the Document is in part a +textbook of mathematics, a Secondary Section may not explain any +mathematics.) The relationship could be a matter of historical +connection with the subject or with related matters, or of legal, +commercial, philosophical, ethical or political position regarding +them. + +The "Invariant Sections" are certain Secondary Sections whose titles +are designated, as being those of Invariant Sections, in the notice +that says that the Document is released under this License. + +The "Cover Texts" are certain short passages of text that are listed, +as Front-Cover Texts or Back-Cover Texts, in the notice that says that +the Document is released under this License. + +A "Transparent" copy of the Document means a machine-readable copy, +represented in a format whose specification is available to the +general public, whose contents can be viewed and edited directly and +straightforwardly with generic text editors or (for images composed of +pixels) generic paint programs or (for drawings) some widely available +drawing editor, and that is suitable for input to text formatters or +for automatic translation to a variety of formats suitable for input +to text formatters. A copy made in an otherwise Transparent file +format whose markup has been designed to thwart or discourage +subsequent modification by readers is not Transparent. A copy that is +not "Transparent" is called "Opaque". + +Examples of suitable formats for Transparent copies include plain +ASCII without markup, Texinfo input format, LaTeX input format, SGML +or XML using a publicly available DTD, and standard-conforming simple +HTML designed for human modification. Opaque formats include +PostScript, PDF, proprietary formats that can be read and edited only +by proprietary word processors, SGML or XML for which the DTD and/or +processing tools are not generally available, and the +machine-generated HTML produced by some word processors for output +purposes only. + +The "Title Page" means, for a printed book, the title page itself, +plus such following pages as are needed to hold, legibly, the material +this License requires to appear in the title page. For works in +formats which do not have any title page as such, "Title Page" means +the text near the most prominent appearance of the work's title, +preceding the beginning of the body of the text. + + +2. VERBATIM COPYING + +You may copy and distribute the Document in any medium, either +commercially or noncommercially, provided that this License, the +copyright notices, and the license notice saying this License applies +to the Document are reproduced in all copies, and that you add no other +conditions whatsoever to those of this License. You may not use +technical measures to obstruct or control the reading or further +copying of the copies you make or distribute. However, you may accept +compensation in exchange for copies. If you distribute a large enough +number of copies you must also follow the conditions in section 3. + +You may also lend copies, under the same conditions stated above, and +you may publicly display copies. + + +3. COPYING IN QUANTITY + +If you publish printed copies of the Document numbering more than 100, +and the Document's license notice requires Cover Texts, you must enclose +the copies in covers that carry, clearly and legibly, all these Cover +Texts: Front-Cover Texts on the front cover, and Back-Cover Texts on +the back cover. Both covers must also clearly and legibly identify +you as the publisher of these copies. The front cover must present +the full title with all words of the title equally prominent and +visible. You may add other material on the covers in addition. +Copying with changes limited to the covers, as long as they preserve +the title of the Document and satisfy these conditions, can be treated +as verbatim copying in other respects. + +If the required texts for either cover are too voluminous to fit +legibly, you should put the first ones listed (as many as fit +reasonably) on the actual cover, and continue the rest onto adjacent +pages. + +If you publish or distribute Opaque copies of the Document numbering +more than 100, you must either include a machine-readable Transparent +copy along with each Opaque copy, or state in or with each Opaque copy +a publicly-accessible computer-network location containing a complete +Transparent copy of the Document, free of added material, which the +general network-using public has access to download anonymously at no +charge using public-standard network protocols. If you use the latter +option, you must take reasonably prudent steps, when you begin +distribution of Opaque copies in quantity, to ensure that this +Transparent copy will remain thus accessible at the stated location +until at least one year after the last time you distribute an Opaque +copy (directly or through your agents or retailers) of that edition to +the public. + +It is requested, but not required, that you contact the authors of the +Document well before redistributing any large number of copies, to give +them a chance to provide you with an updated version of the Document. + + +4. MODIFICATIONS + +You may copy and distribute a Modified Version of the Document under +the conditions of sections 2 and 3 above, provided that you release +the Modified Version under precisely this License, with the Modified +Version filling the role of the Document, thus licensing distribution +and modification of the Modified Version to whoever possesses a copy +of it. In addition, you must do these things in the Modified Version: + +A. Use in the Title Page (and on the covers, if any) a title distinct + from that of the Document, and from those of previous versions + (which should, if there were any, be listed in the History section + of the Document). You may use the same title as a previous version + if the original publisher of that version gives permission. +B. List on the Title Page, as authors, one or more persons or entities + responsible for authorship of the modifications in the Modified + Version, together with at least five of the principal authors of the + Document (all of its principal authors, if it has less than five). +C. State on the Title page the name of the publisher of the + Modified Version, as the publisher. +D. Preserve all the copyright notices of the Document. +E. Add an appropriate copyright notice for your modifications + adjacent to the other copyright notices. +F. Include, immediately after the copyright notices, a license notice + giving the public permission to use the Modified Version under the + terms of this License, in the form shown in the Addendum below. +G. Preserve in that license notice the full lists of Invariant Sections + and required Cover Texts given in the Document's license notice. +H. Include an unaltered copy of this License. +I. Preserve the section entitled "History", and its title, and add to + it an item stating at least the title, year, new authors, and + publisher of the Modified Version as given on the Title Page. If + there is no section entitled "History" in the Document, create one + stating the title, year, authors, and publisher of the Document as + given on its Title Page, then add an item describing the Modified + Version as stated in the previous sentence. +J. Preserve the network location, if any, given in the Document for + public access to a Transparent copy of the Document, and likewise + the network locations given in the Document for previous versions + it was based on. These may be placed in the "History" section. + You may omit a network location for a work that was published at + least four years before the Document itself, or if the original + publisher of the version it refers to gives permission. +K. In any section entitled "Acknowledgements" or "Dedications", + preserve the section's title, and preserve in the section all the + substance and tone of each of the contributor acknowledgements + and/or dedications given therein. +L. Preserve all the Invariant Sections of the Document, + unaltered in their text and in their titles. Section numbers + or the equivalent are not considered part of the section titles. +M. Delete any section entitled "Endorsements". Such a section + may not be included in the Modified Version. +N. Do not retitle any existing section as "Endorsements" + or to conflict in title with any Invariant Section. + +If the Modified Version includes new front-matter sections or +appendices that qualify as Secondary Sections and contain no material +copied from the Document, you may at your option designate some or all +of these sections as invariant. To do this, add their titles to the +list of Invariant Sections in the Modified Version's license notice. +These titles must be distinct from any other section titles. + +You may add a section entitled "Endorsements", provided it contains +nothing but endorsements of your Modified Version by various +parties--for example, statements of peer review or that the text has +been approved by an organization as the authoritative definition of a +standard. + +You may add a passage of up to five words as a Front-Cover Text, and a +passage of up to 25 words as a Back-Cover Text, to the end of the list +of Cover Texts in the Modified Version. Only one passage of +Front-Cover Text and one of Back-Cover Text may be added by (or +through arrangements made by) any one entity. If the Document already +includes a cover text for the same cover, previously added by you or +by arrangement made by the same entity you are acting on behalf of, +you may not add another; but you may replace the old one, on explicit +permission from the previous publisher that added the old one. + +The author(s) and publisher(s) of the Document do not by this License +give permission to use their names for publicity for or to assert or +imply endorsement of any Modified Version. + + +5. COMBINING DOCUMENTS + +You may combine the Document with other documents released under this +License, under the terms defined in section 4 above for modified +versions, provided that you include in the combination all of the +Invariant Sections of all of the original documents, unmodified, and +list them all as Invariant Sections of your combined work in its +license notice. + +The combined work need only contain one copy of this License, and +multiple identical Invariant Sections may be replaced with a single +copy. If there are multiple Invariant Sections with the same name but +different contents, make the title of each such section unique by +adding at the end of it, in parentheses, the name of the original +author or publisher of that section if known, or else a unique number. +Make the same adjustment to the section titles in the list of +Invariant Sections in the license notice of the combined work. + +In the combination, you must combine any sections entitled "History" +in the various original documents, forming one section entitled +"History"; likewise combine any sections entitled "Acknowledgements", +and any sections entitled "Dedications". You must delete all sections +entitled "Endorsements." + + +6. COLLECTIONS OF DOCUMENTS + +You may make a collection consisting of the Document and other documents +released under this License, and replace the individual copies of this +License in the various documents with a single copy that is included in +the collection, provided that you follow the rules of this License for +verbatim copying of each of the documents in all other respects. + +You may extract a single document from such a collection, and distribute +it individually under this License, provided you insert a copy of this +License into the extracted document, and follow this License in all +other respects regarding verbatim copying of that document. + + +7. AGGREGATION WITH INDEPENDENT WORKS + +A compilation of the Document or its derivatives with other separate +and independent documents or works, in or on a volume of a storage or +distribution medium, does not as a whole count as a Modified Version +of the Document, provided no compilation copyright is claimed for the +compilation. Such a compilation is called an "aggregate", and this +License does not apply to the other self-contained works thus compiled +with the Document, on account of their being thus compiled, if they +are not themselves derivative works of the Document. + +If the Cover Text requirement of section 3 is applicable to these +copies of the Document, then if the Document is less than one quarter +of the entire aggregate, the Document's Cover Texts may be placed on +covers that surround only the Document within the aggregate. +Otherwise they must appear on covers around the whole aggregate. + + +8. TRANSLATION + +Translation is considered a kind of modification, so you may +distribute translations of the Document under the terms of section 4. +Replacing Invariant Sections with translations requires special +permission from their copyright holders, but you may include +translations of some or all Invariant Sections in addition to the +original versions of these Invariant Sections. You may include a +translation of this License provided that you also include the +original English version of this License. In case of a disagreement +between the translation and the original English version of this +License, the original English version will prevail. + + +9. TERMINATION + +You may not copy, modify, sublicense, or distribute the Document except +as expressly provided for under this License. Any other attempt to +copy, modify, sublicense or distribute the Document is void, and will +automatically terminate your rights under this License. However, +parties who have received copies, or rights, from you under this +License will not have their licenses terminated so long as such +parties remain in full compliance. + + +10. FUTURE REVISIONS OF THIS LICENSE + +The Free Software Foundation may publish new, revised versions +of the GNU Free Documentation License from time to time. Such new +versions will be similar in spirit to the present version, but may +differ in detail to address new problems or concerns. See +http://www.gnu.org/copyleft/. + +Each version of the License is given a distinguishing version number. +If the Document specifies that a particular numbered version of this +License "or any later version" applies to it, you have the option of +following the terms and conditions either of that specified version or +of any later version that has been published (not as a draft) by the +Free Software Foundation. If the Document does not specify a version +number of this License, you may choose any version ever published (not +as a draft) by the Free Software Foundation. + diff --git a/doc/Makefile b/doc/Makefile new file mode 100644 index 0000000..59a524b --- /dev/null +++ b/doc/Makefile @@ -0,0 +1,148 @@ +#!/usr/bin/make +############################################################################### +# FILE IDENTIFICATION +# +# Name: Makefile +# Purpose: Makefile for the clsql documentation +# Programer: Kevin M. Rosenberg +# Date Started: Mar 2002 +# +# This file, part of CLSQL, is Copyright (c) 2002-2010 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. +############################################################################### + +DOCFILE_BASE_DEFAULT:=clsql +DOCFILE_EXT_DEFAULT:=xml + + +# Standard docfile processing + +DEBIAN=$(shell expr "`cat /etc/issue 2> /dev/null`" : '.*Debian.*') +SUSE=$(shell expr "`cat /etc/issue 2> /dev/null`" : '.*SuSE.*') +SUSE91=$(shell expr "`cat /etc/issue 2> /dev/null`" : '.*SuSE Linux 9.1.*') +REDHAT=$(shell expr "`cat /etc/issue 2> /dev/null`" : '.*Red Hat.*') +MANDRAKE=$(shell expr "`cat /etc/issue 2> /dev/null`" : '.*Mandrake.*') +DARWIN=$(shell expr "`uname -a`" : '.*Darwin.*') +UBUNTU=$(shell expr "`cat /etc/issue 2> /dev/null`" : '.*Ubuntu.*') + + +ifneq (${DEBIAN},0) +OS:=debian +else + ifneq (${SUSE91},0) + OS=suse91 + else + ifneq (${SUSE},0) + OS=suse + else + ifneq (${REDHAT},0) + OS=redhat + else + ifneq (${MANDRAKE},0) + OS=mandrake + else + ifneq (${DARWIN},0) + OS=darwin + else + ifneq (${UBUNTU},0) + OS:=debian + endif + endif + endif + endif + endif + endif +endif + +ifndef DOCFILE_BASE +DOCFILE_BASE=${DOCFILE_BASE_DEFAULT} +endif + +ifndef DOCFILE_EXT +DOCFILE_EXT=${DOCFILE_EXT_DEFAULT} +endif + +DOCFILE:=${DOCFILE_BASE}.${DOCFILE_EXT} +FOFILE:=${DOCFILE_BASE}.fo +PDFFILE:=${DOCFILE_BASE}.pdf +PSFILE:=${DOCFILE_BASE}.ps +DVIFILE:=${DOCFILE_BASE}.dvi +TXTFILE:=${DOCFILE_BASE}.txt +HTMLFILE:=${DOCFILE_BASE}.html +TMPFILES:=${DOCFILE_BASE}.aux ${DOCFILE_BASE}.out ${DOCFILE_BASE}.log +DOCFILES:=$(shell echo *.xml *.xsl) + +ifeq ($(XSLTPROC),) + XSLTPROC:=xsltproc +endif + +CATALOG:=`pwd`/catalog-${OS}.xml +CHECK:=XML_CATALOG_FILES="$(CATALOG)" xmllint --noout --xinclude --postvalid $(DOCFILE) || exit 1 + +.PHONY: all +all: html pdf + +.PHONY: dist +dist: html pdf + +.PHONY: doc +doc: html pdf + +.PHONY: check +check: + @echo "Operating system detected: ${OS}" + @$(CHECK) + +.PHONY: html +html: html.tar.gz + +html.tar.gz: $(DOCFILES) Makefile + @rm -rf html + @mkdir html + @XML_CATALOG_FILES="$(CATALOG)" $(XSLTPROC) --stringparam chunker.output.encoding UTF-8 \ + --xinclude --output html/ html_chunk.xsl $(DOCFILE) + @GZIP='-9' tar czf html.tar.gz html + +.PHONY: fo +fo: ${FOFILE} + +${FOFILE}: $(DOCFILES) Makefile + @XML_CATALOG_FILES="$(CATALOG)" xsltproc --xinclude --stringparam fop1.extensions 1 --output $(FOFILE) fo.xsl $(DOCFILE) + +.PHONY: pdf +pdf: ${PDFFILE} + +${PDFFILE}: ${DOCFILES} Makefile + @$(MAKE) fo + @fop $(FOFILE) -pdf $(PDFFILE) > /dev/null + +.PHONY: dvi +dvi: ${DVIFILE} + +.PHONY: ps +ps: ${PSFILE} + +${PSFILE}: ${DOCFILES} Makefile + @$(MAKE) fo + @fop $(FOFILE) -ps $(PSFILE) > /dev/null + + +.PHONY: txt +txt: ${TXTFILE} + +${TXTFILE}: ${FOFILE} + @XML_CATALOG_FILES="$(CATALOG)" xsltproc --xinclude --output ${HTMLFILE} html.xsl $(DOCFILE) + lynx -dump ${HTMLFILE} > ${TXTFILE} + +.PHONY: clean +clean: + @rm -f *~ *.bak *.orig \#*\# .\#* texput.log + @rm -rf html ${PSFILE} ${HTMLFILE} + @rm -f ${TMPFILES} ${FOFILE} + @rm -f ${DVIFILE} ${TXTFILE} + +.PHONY: distclean +distclean: clean diff --git a/doc/README b/doc/README new file mode 100644 index 0000000..5c0c268 --- /dev/null +++ b/doc/README @@ -0,0 +1,24 @@ +Building the documentation: + +You will need the following packages: + * xsltproc + * docbook + * docbook-xml + * docbook-xsl + * docbook-xsl-doc-html + * fop + +These are the debian/ubuntu package names; on other systems there are probably similar. + + +General Build: +> make + +Check the validity of the source +> make check + +Build just the html: +> make html + +Build just the pdf: +> make pdf diff --git a/doc/TODO b/doc/TODO new file mode 100644 index 0000000..b9f9f97 --- /dev/null +++ b/doc/TODO @@ -0,0 +1,31 @@ +DOCUMENTATION TO DO LIST + +1. Variances from CommonSQL (Ideally, this will be extremely minimal) + +2. Underdocumented CommonSQL features: + + - Retrieval immediate + - SQL operators: ||, SUBSTR, MINUS, INTERSECT, UNION, NVL + +3. CLSQL extensions to CommonSQL + + - SQL operators: group-by, limit, not-null, ==, is, having, the, uplike, + view-class, coalesce, except, exists, substring, concat + + - SELECT: additional keyword arguments accepted include :INNER-JOIN and :ON. + +4. Documenting lower level, non-CommonSQL functions (some of this is already + done). + + - connection pools + - database-query-result-set + +5. Notes on any peculiarities of each of the backends (e.g., unsupported + features, notable extensions etc.). + + - MYSQL + - SQLITE + - ODBC + - ORACLE + +6. Incorporate the threading-warnings.txt into the docs. diff --git a/doc/appendix.xml b/doc/appendix.xml new file mode 100644 index 0000000..f06f035 --- /dev/null +++ b/doc/appendix.xml @@ -0,0 +1,884 @@ +<?xml version='1.0' ?> +<!DOCTYPE book PUBLIC "-//OASIS//DTD DocBook XML V4.2//EN" + "http://www.oasis-open.org/docbook/xml/4.2/docbookx.dtd" [ +<!ENTITY % myents SYSTEM "entities.inc"> +%myents; +]> + +<appendix id="appendix"> + <title>Database Back-ends</title> + + <sect1 id="foreignlibs"> + <title>How CLSQL finds and loads foreign libraries</title> + <para> + For some database types CLSQL has to load external foreign + libaries. These are usually searched for in the standard + locations the operating system uses but you can tell &clsql; to + look into other directories as well by using the function + <function>CLSQL:PUSH-LIBRARY-PATH</function> or by directly + manipulating the special variable + <varname>CLSQL:*FOREIGN-LIBRARY-SEARCH-PATHS*</varname>. If, + say, the shared library libpq.so needed for PostgreSQL support + is located in the directory <filename>/opt/foo/</filename> on + your machine you'd use + <screen> + (clsql:push-library-path "/opt/foo/") + </screen> + before loading the CLSQL-POSTGRESQL module. (Note the trailing + slash above!) + + If you want to combine this with fully automatic loading of + libraries via ASDF a technique like the following works: + + <screen> + (defmethod asdf:perform :after ((o asdf:load-op) + (c (eql (asdf:find-system 'clsql)))) + (funcall (find-symbol (symbol-name '#:push-library-path) + (find-package 'clsql)) + #p"/opt/foo/")) + </screen> + </para> + + <para> + Additionally, site-specific initialization can be done using an +initialization file. If the file <filename>/etc/clsql-init.lisp</filename> +exists, this file will be read after the &clsql; ASDF system is loaded. +This file can contain forms to set site-specific paths as well as change +&clsql; default values. + </para> + </sect1> + <sect1 id="postgresql"> + <title>PostgreSQL</title> + <sect2> + <title>Libraries</title> + <para>The PostgreSQL back-end requires the PostgreSQL C + client library (<filename>libpq.so</filename>). The + location of this library is specified via + <symbol>*postgresql-so-load-path*</symbol>, which defaults + to <filename>/usr/lib/libpq.so</filename>. Additional flags + to <application>ld</application> needed for linking are + specified via <symbol>*postgresql-so-libraries*</symbol>, + which defaults to <symbol>("-lcrypt" "-lc")</symbol>.</para> + </sect2> + <sect2> + <title>Initialization</title> + <para>Use + <screen> +(asdf:operate 'asdf:load-op 'clsql-postgresql) + </screen> + to load the PostgreSQL back-end. The database type for the + PostgreSQL back-end is <symbol>:postgresql</symbol>.</para> + </sect2> + <sect2> + <title>Connection Specification</title> + <sect3> + <title>Syntax of connection-spec</title> + <synopsis> + (<replaceable>host</replaceable> <replaceable>db</replaceable> <replaceable>user</replaceable> <replaceable>password</replaceable> &optional <replaceable>port</replaceable> <replaceable>options</replaceable> <replaceable>tty</replaceable>) + </synopsis> + </sect3> + <sect3> + <title>Description of connection-spec</title> + <para> + For every parameter in the connection-spec, + <symbol>nil</symbol> indicates that the PostgreSQL default + environment variables (see PostgreSQL documentation) will + be used, or if those are unset, the compiled-in defaults + of the C client library are used. + </para> + <variablelist> + <varlistentry> + <term><parameter>host</parameter></term> + <listitem> + <para>String representing the hostname or IP address + the PostgreSQL server resides on. Use the empty + string to indicate a connection to localhost via + Unix-Domain sockets instead of TCP/IP.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>db</parameter></term> + <listitem> + <para>String representing the name of the database on + the server to connect to.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>user</parameter></term> + <listitem> + <para>String representing the user name to use for + authentication.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>password</parameter></term> + <listitem> + <para>String representing the unencrypted password to + use for authentication.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>port</parameter></term> + <listitem> + <para>String representing the port to use for + communication with the PostgreSQL server.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>options</parameter></term> + <listitem> + <para>String representing further runtime options for + the PostgreSQL server.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>tty</parameter></term> + <listitem> + <para>String representing the tty or file to use for + debugging messages from the PostgreSQL server.</para> + </listitem> + </varlistentry> + </variablelist> + </sect3> + </sect2> + <sect2><title>Notes</title> + <para>None.</para> + </sect2> + </sect1> + + <sect1 id="postgresql-socket"> + <title>PostgreSQL Socket</title> + <sect2> + <title>Libraries</title> + <para>The PostgreSQL Socket back-end needs + <emphasis>no</emphasis> access to the PostgreSQL C + client library, since it communicates directly with the + PostgreSQL server using the published frontend/backend + protocol, version 2.0. This eases installation and makes it + possible to dump CMU CL images containing CLSQL and this + backend, contrary to backends which require FFI code.</para> + </sect2> + <sect2> + <title>Initialization</title> + <para> + Use + <screen> +(asdf:operate 'asdf:load-op 'clsql-postgresql-socket) + </screen> + to load the PostgreSQL Socket back-end. The database type + for the PostgreSQL Socket back-end is + <symbol>:postgresql-socket</symbol>. + </para> + </sect2> + <sect2> + <title>Connection Specification</title> + <sect3> + <title>Syntax of connection-spec</title> + <synopsis> + (<replaceable>host</replaceable> <replaceable>db</replaceable> <replaceable>user</replaceable> <replaceable>password</replaceable> &optional <replaceable>port</replaceable> <replaceable>options</replaceable> <replaceable>tty</replaceable>) + </synopsis> + </sect3> + <sect3> + <title>Description of connection-spec</title> + <variablelist> + <varlistentry> + <term><parameter>host</parameter></term> + <listitem> + <para>If this is a string, it represents the hostname or + IP address the PostgreSQL server resides on. In + this case communication with the server proceeds via + a TCP connection to the given host and port.</para> + <para> + If this is a pathname, then it is assumed to name the + directory that contains the server's Unix-Domain + sockets. The full name to the socket is then + constructed from this and the port number passed, + and communication will proceed via a connection to + this unix-domain socket.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>db</parameter></term> + <listitem> + <para>String representing the name of the database on + the server to connect to.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>user</parameter></term> + <listitem> + <para>String representing the user name to use for + authentication.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>password</parameter></term> + <listitem> + <para>String representing the unencrypted password to + use for authentication. This can be the empty + string if no password is required for + authentication.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>port</parameter></term> + <listitem> + <para>Integer representing the port to use for + communication with the PostgreSQL server. This + defaults to 5432.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>options</parameter></term> + <listitem> + <para>String representing further runtime options for + the PostgreSQL server.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>tty</parameter></term> + <listitem> + <para>String representing the tty or file to use for + debugging messages from the PostgreSQL server.</para> + </listitem> + </varlistentry> + </variablelist> + </sect3> + </sect2> + <sect2><title>Notes</title> + <para>None.</para> + </sect2> + </sect1> + + <sect1 id="mysql"> + <title>MySQL</title> + <sect2> + <title>Libraries</title> + <para>The &mysql; back-end requires the &mysql; C + client library (<filename>libmysqlclient.so</filename>). + The location of this library is specified + via <symbol>*mysql-so-load-path*</symbol>, which defaults + to <filename>/usr/lib/libmysqlclient.so</filename>. + Additional flags to <application>ld</application> needed for + linking are specified via <symbol>*mysql-so-libraries*</symbol>, + which defaults to <symbol>("-lc")</symbol>. + </para> + </sect2> + <sect2> + <title>Initialization</title> + <para> + Use + <screen> +(asdf:operate 'asdf:load-op 'clsql-mysql) + </screen> + to load the &mysql; back-end. The database type for the MySQL + back-end is <symbol>:mysql</symbol>. + </para> + </sect2> + <sect2> + <title>Connection Specification</title> + <sect3> + <title>Syntax of connection-spec</title> + <synopsis>(<replaceable>host</replaceable> <replaceable>db</replaceable> <replaceable>user</replaceable> <replaceable>password</replaceable> &optional <replaceable>port</replaceable>)</synopsis> + </sect3> + <sect3> + <title>Description of connection-spec</title> + <variablelist> + <varlistentry> + <term><parameter>host</parameter></term> + <listitem> + <para>String representing the hostname or IP address + the &mysql; server resides on, or <symbol>nil</symbol> + to indicate the localhost.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>db</parameter></term> + <listitem> + <para>String representing the name of the database on + the server to connect to.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>user</parameter></term> + <listitem> + <para>String representing the user name to use for + authentication, or <symbol>nil</symbol> to use the + current Unix user ID.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>password</parameter></term> + <listitem> + <para>String representing the unencrypted password to + use for authentication, or <symbol>nil</symbol> if + the authentication record has an empty password + field.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>port</parameter></term> + <listitem> + <para>String representing the port to use for + communication with the MySQL server.</para> + </listitem> + </varlistentry> + </variablelist> + </sect3> + </sect2> + <sect2><title>Notes</title> + <sect3><title>FDDL</title> + <itemizedlist mark='opencircle'> + <listitem> + <para> + <link + linkend="drop-index"><function>drop-index</function></link> + requires a table to be specified with the + <symbol>:on</symbol> keyword parameter. + </para> + </listitem> + <listitem> + <para> + <glossterm linkend="gloss-view">views</glossterm> are not + supported by &mysql;. + </para> + </listitem> + <listitem> + <para> + The <symbol>:transactions</symbol> keyword argument to + <link + linkend="create-table"><function>create-table</function></link> + controls whether or not the created table is an InnoDB + table which supports transactions. + </para> + </listitem> + <listitem> + <para> + The <symbol>:owner</symbol> keyword argument to the FDDL functions + for listing and testing for database objects is ignored. + </para> + </listitem> + </itemizedlist> + </sect3> + <sect3><title>FDML</title> + <itemizedlist mark='opencircle'> + <listitem> + <para> + Prior to version 4.1, &mysql; does not support nested + subqueries in calls to <link + linkend="select"><function>select</function></link>. + </para> + </listitem> + </itemizedlist> + </sect3> + <sect3><title>Symbolic SQL Syntax</title> + <itemizedlist mark='opencircle'> + <listitem> + <para> + &mysql; does not support the <function>||</function> + concatenation operator. Use <function>concat</function> + instead. + </para> + </listitem> + <listitem> + <para> + &mysql; does not support the <function>substr</function> + operator. Use <function>substring</function> instead. + </para> + </listitem> + <listitem> + <para> + &mysql; does not support the + <function>intersect</function> and + <function>except</function> set operations. + </para> + </listitem> + <listitem> + <para> + &mysql; (version 4.0 and later) does not support string + table aliases unless the server is started with + ANSI_QUOTES enabled. + </para> + </listitem> + </itemizedlist> + </sect3> + </sect2> + </sect1> + + <sect1 id="odbc"> + <title>&odbc;</title> + <sect2> + <title>Libraries</title> + <para> + The &odbc; back-end requires access to an &odbc; driver + manager as well as &odbc; drivers for the underlying + database server. &clsql; has been tested with + <application>unixODBC</application> ODBC Driver Manager as + well as Microsoft's ODBC manager. These driver managers + have been tested with the <ulink + url="http://odbc.postgresql.org"> + <citetitle>psqlODBC</citetitle></ulink> driver for + &postgresql; and the <ulink + url="http://www.mysql.com/products/connector/odbc/"> + <citetitle>MyODBC</citetitle></ulink> driver for &mysql;. + </para> + </sect2> + <sect2> + <title>Initialization</title> + <para> + Use + <screen> +(asdf:operate 'asdf:load-op 'clsql-odbc) + </screen> + to load the &odbc; back-end. The database type for the &odbc; + back-end is <symbol>:odbc</symbol>. + </para> + </sect2> + <sect2> + <title>Connection Specification</title> + <sect3> + <title>Syntax of connection-spec</title> + <synopsis>(<replaceable>dsn</replaceable> <replaceable>user</replaceable> <replaceable>password</replaceable> &key <replaceable>connection-string</replaceable>)</synopsis> + </sect3> + <sect3> + <title>Description of connection-spec</title> + <variablelist> + <varlistentry> + <term><parameter>dsn</parameter></term> + <listitem> + <para>String representing the ODBC data source name.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>user</parameter></term> + <listitem> + <para>String representing the user name to use for + authentication.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>password</parameter></term> + <listitem> + <para>String representing the unencrypted password to + use for authentication.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>connection-string</parameter></term> + <listitem> + <para>Raw connection string passed to the underlying + ODBC driver. Allows bypassing creating a DSN on the + server.</para> + </listitem> + </varlistentry> + + </variablelist> + </sect3> + </sect2> + <sect2><title>Notes</title> + <sect3><title>FDDL</title> + <itemizedlist mark='opencircle'> + <listitem> + <para> + The <symbol>:owner</symbol> keyword argument to the FDDL functions + for listing and testing for database objects is ignored. + </para> + </listitem> + </itemizedlist> + </sect3> + </sect2> + <sect2><title>Connect Examples</title> + <screen> + +;; assumes a "mssql" DSN is configured on the lisp host, specifying database server +;; and database name. +> (clsql:connect '("mssql" "database-user" "database-password") + :database-type :odbc) +=> #<CLSQL-ODBC:ODBC-DATABASE mssql/database-user OPEN {100756D123}> + +;; no DSN on the lisp host, specify connection information via :connection-string +> (clsql:connect '("friendly-server-name" "friendly-username" "" + :connection-string "DRIVER={FreeTDS};SERVER=mssql-server;DATABASE=database-name;UID=database-user;PWD=database-password;PORT=1433;TDS_Version=8.0;APP=clsql") + :database-type :odbc) +=> #<CLSQL-ODBC:ODBC-DATABASE friendly-server-name/friendly-username OPEN {100756D123}></screen> + <para> + The <symbol>friendly-server-name</symbol> + and <symbol>friendly-username</symbol> are only used when + printing the connection object to a stream. + </para> + </sect2> + </sect1> + + <sect1 id="aodbc"> + <title>&aodbc;</title> + <sect2> + <title>Libraries</title> <para>The &aodbc; back-end requires + access to the &odbc; interface of &acl; named DBI. This + interface is not available in the trial version of + &acl;</para> + </sect2> + <sect2> + <title>Initialization</title> + <para> + Use + <screen> +(require 'aodbc-v2) +(asdf:operate 'asdf:load-op 'clsql-aodbc) + </screen> + to load the &aodbc; back-end. The database type for the &aodbc; + back-end is <symbol>:aodbc</symbol>. + </para> + </sect2> + <sect2> + <title>Connection Specification</title> + <sect3> + <title>Syntax of connection-spec</title> + <synopsis> + (<replaceable>dsn</replaceable> <replaceable>user</replaceable> <replaceable>password</replaceable>) + </synopsis> + </sect3> + <sect3> + <title>Description of connection-spec</title> + <variablelist> + <varlistentry> + <term><parameter>dsn</parameter></term> + <listitem> + <para>String representing the ODBC data source name.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>user</parameter></term> + <listitem> + <para>String representing the user name to use for + authentication.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>password</parameter></term> + <listitem> + <para>String representing the unencrypted password to + use for authentication.</para> + </listitem> + </varlistentry> + </variablelist> + </sect3> + </sect2> + <sect2><title>Notes</title> + <para> + None. + </para> + </sect2> + </sect1> + + <sect1 id="sqlite"> + <title>&sqlite;</title> + <sect2> + <title>Libraries</title> <para>The &sqlite; back-end requires + the &sqlite; shared library file. Its default file name is + <filename>/usr/lib/libsqlite.so</filename>.</para> + </sect2> + <sect2> + <title>Initialization</title> + <para> + Use + <screen> +(asdf:operate 'asdf:load-op 'clsql-sqlite) + </screen> + to load the &sqlite; back-end. The database type for the &sqlite; + back-end is <symbol>:sqlite</symbol>. + </para> + </sect2> + <sect2> + <title>Connection Specification</title> + <sect3> + <title>Syntax of connection-spec</title> + <synopsis>(<replaceable>filename</replaceable>)</synopsis> + </sect3> + <sect3> + <title>Description of connection-spec</title> + <variablelist> + <varlistentry> + <term><parameter>filename</parameter></term> + <listitem> + <para>String or pathname representing the filename of + the &sqlite; database file.</para> + </listitem> + </varlistentry> + </variablelist> + </sect3> + </sect2> + <sect2><title>Notes</title> + <sect3><title>Connection</title> + <itemizedlist mark='opencircle'> + <listitem> + <para> + Passing <parameter>filename</parameter> a value of + <filename>:memory:</filename> will create a database in + physical memory instead of using a file on disk. + </para> + </listitem> + <listitem> + <para> + Some operations will be many times faster if database + integrity checking is disabled by setting the SYNCHRONOUS + flag to OFF (see the SQLITE manual for details). + </para> + </listitem> + </itemizedlist> + </sect3> + <sect3><title>FDDL</title> + <itemizedlist mark='opencircle'> + <listitem> + <para> + The <symbol>:owner</symbol> keyword argument to the FDDL functions + for listing and testing for database objects is ignored. + </para> + </listitem> + <listitem> + <para> + The <symbol>:column-list</symbol> keyword argument to + <link + linkend="create-view"><function>create-view</function></link> + is not supported by &sqlite;. + </para> + </listitem> + </itemizedlist> + </sect3> + <sect3><title>Symbolic SQL Syntax</title> + <itemizedlist mark='opencircle'> + <listitem> + <para> + &sqlite; does not support the <function>all</function>, + <function>some</function>, <function>any</function> and + <function>exists</function> subquery operations. + </para> + </listitem> + </itemizedlist> + </sect3> + </sect2> + </sect1> + + <sect1 id="sqlite3"> + <title>&sqlite3;</title> + <sect2> + <title>Libraries</title> <para>The &sqlite3; back-end requires + the &sqlite3; shared library file. Its default file name is + <filename>/usr/lib/libsqlite3.so</filename>.</para> + </sect2> + <sect2> + <title>Initialization</title> + <para> + Use + <screen> +(asdf:operate 'asdf:load-op 'clsql-sqlite3) + </screen> + to load the &sqlite3; back-end. The database type for the &sqlite3; + back-end is <symbol>:sqlite3</symbol>. + </para> + </sect2> + <sect2> + <title>Connection Specification</title> + <sect3> + <title>Syntax of connection-spec</title> + <synopsis>(<replaceable>filename</replaceable> &optional <replaceable>init-function</replaceable>)</synopsis> + </sect3> + <sect3> + <title>Description of connection-spec</title> + <variablelist> + <varlistentry> + <term><parameter>filename</parameter></term> + <listitem> + <para>String representing the filename of the &sqlite3; + database file.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>init-function</parameter></term> + <listitem> + <para> + A function designator. + <replaceable>init-function</replaceable> takes a + single argument of type + <type>sqlite3:sqlite3-db</type>, a foreign pointer to + the C descriptor of the newly opened database. + <replaceable>init-function</replaceable> is called by + the back-end immediately after &sqlite3; + <function>sqlite3_open</function> library function, + and can be used to perform optional database + initializations by calling foreign functions in the + &sqlite3; library. + </para> + <para> + An example of an initialization function which + defines a new collating sequence for text columns is + provided in + <filename>./examples/sqlite3/init-func/</filename>. + </para> + </listitem> + </varlistentry> + </variablelist> + </sect3> + </sect2> + <sect2><title>Notes</title> + <sect3><title>Connection</title> + <itemizedlist mark='opencircle'> + <listitem> + <para> + Passing <parameter>filename</parameter> a value of + <filename>:memory:</filename> will create a database in + physical memory instead of using a file on disk. + </para> + </listitem> + <listitem> + <para> + Some operations will be many times faster if database + integrity checking is disabled by setting the SYNCHRONOUS + flag to OFF (see the SQLITE manual for details). + </para> + </listitem> + </itemizedlist> + </sect3> + <sect3><title>FDDL</title> + <itemizedlist mark='opencircle'> + <listitem> + <para> + The <symbol>:owner</symbol> keyword argument to the FDDL functions + for listing and testing for database objects is ignored. + </para> + </listitem> + <listitem> + <para> + The <symbol>:column-list</symbol> keyword argument to + <link + linkend="create-view"><function>create-view</function></link> + is not supported by &sqlite3;. + </para> + </listitem> + </itemizedlist> + </sect3> + <sect3><title>Symbolic SQL Syntax</title> + <itemizedlist mark='opencircle'> + <listitem> + <para> + &sqlite3; does not support the <function>all</function>, + <function>some</function>, <function>any</function> and + <function>exists</function> subquery operations. + </para> + </listitem> + </itemizedlist> + </sect3> + </sect2> + </sect1> + + <sect1 id="oracle"> + <title>Oracle</title> + <sect2> + <title>Libraries</title> + <para>The &oracle; back-end requires the &oracle; OCI client + library. (<filename>libclntsh.so</filename>). The location of + this library is specified relative to the + <symbol>ORACLE_HOME</symbol> value in the operating system + environment. + </para> + </sect2> + <sect2> + <title>Library Versions</title> + <para> + &clsql; has tested sucessfully using the client library from + Oracle 9i and Oracle 10g server installations as well as + Oracle's 10g Instant Client library. For Oracle 8 and earlier + versions, there is vestigial support by pushing the symbol + <symbol>:oci7</symbol> onto <symbol>cl:*features*</symbol> + prior to loading the <filename>clsql-oracle</filename> &asdf; + system. + <screen> + (push :oci7 cl:*features*) + (asdf:operate 'asdf:load-op 'clsql-oracle) + </screen> + </para> + </sect2> + <sect2> + <title>Initialization</title> + <para> + Use + <screen> +(asdf:operate 'asdf:load-op 'clsql-oracle) + </screen> + to load the &oracle; back-end. The database type for the Oracle + back-end is <symbol>:oracle</symbol>. + </para> + </sect2> + <sect2> + <title>Connection Specification</title> + <sect3> + <title>Syntax of connection-spec</title> + <synopsis>(<replaceable>global-name</replaceable> <replaceable>user</replaceable> <replaceable>password</replaceable>)</synopsis> + </sect3> + <sect3> + <title>Description of connection-spec</title> + <variablelist> + <varlistentry> + <term><parameter>global-name</parameter></term> + <listitem> + <para>String representing the global name of the Oracle database. + This is looked up through the tnsnames.ora file.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>user</parameter></term> + <listitem> + <para>String representing the user name to use for + authentication.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>password</parameter></term> + <listitem> + <para>String representing the password to + use for authentication..</para> + </listitem> + </varlistentry> + </variablelist> + </sect3> + </sect2> + <sect2><title>Notes</title> + <sect3><title>Symbolic SQL Syntax</title> + <itemizedlist mark='opencircle'> + <listitem> + <para> + The <function>userenv</function> operator is &oracle; specific. + </para> + </listitem> + <listitem> + <para> + &oracle; does not support the <function>except</function> + operator. Use <function>minus</function> instead. + </para> + </listitem> + <listitem> + <para> + &oracle; does not support the <function>all</function>, + <function>some</function>, <function>any</function> + subquery operations. + </para> + </listitem> + </itemizedlist> + </sect3> + <sect3><title>Transactions</title> + <itemizedlist mark='opencircle'> + <listitem> + <para> + By default, &clsql; starts in transaction AUTOCOMMIT mode + (see <link + linkend="set-autocommit"><function>set-autocommit</function></link>). + To begin a transaction in autocommit mode, <link + linkend="start-transaction"><function>start-transaction</function></link> + has to be called explicitly. + </para> + </listitem> + </itemizedlist> + </sect3> + </sect2> + </sect1> + + </appendix> diff --git a/doc/bookinfo.xml b/doc/bookinfo.xml new file mode 100644 index 0000000..2cb4d55 --- /dev/null +++ b/doc/bookinfo.xml @@ -0,0 +1,64 @@ +<?xml version='1.0' ?> +<!DOCTYPE book PUBLIC "-//OASIS//DTD DocBook XML V4.2//EN" + "http://www.oasis-open.org/docbook/xml/4.2/docbookx.dtd" [ +<!ENTITY % myents SYSTEM "entities.inc"> +%myents; +]> + +<bookinfo> + <title>&clsql; Users' Guide</title> + <authorgroup> + <author> + <firstname>Kevin</firstname> + <othername>M.</othername> + <surname>Rosenberg</surname> + <affiliation><jobtitle>Maintainer of &clsql;</jobtitle></affiliation> + </author> + <author> + <firstname>Marcus</firstname> + <othername>T.</othername> + <surname>Pearce</surname> + <affiliation><jobtitle>Contributor to &clsql;</jobtitle></affiliation> + </author> + <author> + <firstname>Pierre</firstname> + <othername>R.</othername> + <surname>Mai</surname> + <affiliation><jobtitle>Author of Original MaiSQL Code</jobtitle></affiliation> + </author> + <author> + <othername>onShore Development, Inc.</othername> + <affiliation><jobtitle>Author of UncommonSQL Package</jobtitle></affiliation> + </author> + </authorgroup> + <legalnotice> + <itemizedlist> + <listitem> + <para>&clsql; is Copyright © 2002-2010 by Kevin M. Rosenberg, + Copyright © 1999-2001 by Pierre R. Mai, and Copyright + © 1999-2003 onShore Development, Inc.</para> + </listitem> + <listitem> + <para><application>Allegro CL</application>® is a registered + trademark of Franz Inc.</para> + </listitem> + <listitem> + <para><application>Common SQL</application>, + <application>LispWorks</application> are trademarks or + registered trademarks of LispWorks Ltd.</para> + </listitem> + <listitem> + <para><application>Oracle</application>® is a registered + trademark of Oracle Inc.</para> + </listitem> + <listitem> + <para><application>Microsoft Windows</application>® is a + registered trademark of Microsoft Inc.</para> + </listitem> + <listitem> + <para>Other brand or product names are the registered + trademarks or trademarks of their respective holders.</para> + </listitem> + </itemizedlist> + </legalnotice> +</bookinfo> diff --git a/doc/catalog-darwin.xml b/doc/catalog-darwin.xml new file mode 100644 index 0000000..0ed575f --- /dev/null +++ b/doc/catalog-darwin.xml @@ -0,0 +1,43 @@ +<?xml version="1.0" ?> +<!DOCTYPE catalog + PUBLIC "-//OASIS/DTD Entity Resolution XML Catalog V1.0//EN" + "http://www.oasis-open.org/committees/entity/release/1.0/catalog.dtd"> + +<catalog xmlns="urn:oasis:names:tc:entity:xmlns:xml:catalog"> + + <!-- The directory DTD and stylesheet files are installed under --> + <group xml:base="file:///sw/share/xml/" > + + <!-- Resolve DTD URL system ID to local file --> + <rewriteSystem + systemIdStartString="http://www.oasis-open.org/docbook/xml/4.2/" + rewritePrefix="dtd/docbookx/4.2.0/" /> + <!-- Resolve stylesheet URL to local file --> + <rewriteURI + uriStartString="http://docbook.sourceforge.net/release/xsl/current/" + rewritePrefix="xsl/docbook-xsl/" /> + + <!-- Resolve DTD PUBLIC identifiers --> + <nextCatalog catalog="dtd/xml/4.2/catalog.xml" /> + + <!-- To resolve simple DTD SYSTEM identifiers. --> + <!-- Note: this does not work with Java resolver --> + <!-- classes in Saxon or Xalan --> + <system + systemId="docbook.dtd" + uri="dtd/xml/4.2.0/xml/docbookx.dtd" /> + + <!-- To resolve short stylesheet references --> + <uri + name="docbook_html.xsl" + uri="xsl/docbook-xsl/xhtml/docbook.xsl" /> + <uri + name="docbook_chunk.xsl" + uri="xsl/docbook-xsl/xhtml/chunk.xsl" /> + <uri + name="docbook_fo.xsl" + uri="xsl/docbook-xsl/fo/docbook.xsl" /> + + </group> + +</catalog> diff --git a/doc/catalog-debian.xml b/doc/catalog-debian.xml new file mode 100644 index 0000000..b924d99 --- /dev/null +++ b/doc/catalog-debian.xml @@ -0,0 +1,43 @@ +<?xml version="1.0" ?> +<!DOCTYPE catalog + PUBLIC "-//OASIS/DTD Entity Resolution XML Catalog V1.0//EN" + "http://www.oasis-open.org/committees/entity/release/1.0/catalog.dtd"> + +<catalog xmlns="urn:oasis:names:tc:entity:xmlns:xml:catalog"> + + <!-- The directory DTD and stylesheet files are installed under --> + <group xml:base="file:///usr/share/sgml/docbook/" > + + <!-- Resolve DTD URL system ID to local file --> + <rewriteSystem + systemIdStartString="http://www.oasis-open.org/docbook/xml/4.2/" + rewritePrefix="dtd/xml/4.2/" /> + <!-- Resolve stylesheet URL to local file --> + <rewriteURI + uriStartString="http://docbook.sourceforge.net/release/xsl/current/" + rewritePrefix="stylesheet/xsl/nwalsh/" /> + + <!-- Resolve DTD PUBLIC identifiers --> + <nextCatalog catalog="dtd/xml/4.2/catalog.xml" /> + + <!-- To resolve simple DTD SYSTEM identifiers. --> + <!-- Note: this does not work with Java resolver --> + <!-- classes in Saxon or Xalan --> + <system + systemId="docbook.dtd" + uri="dtd/xml/4.2/xml/docbookx.dtd" /> + + <!-- To resolve short stylesheet references --> + <uri + name="docbook_html.xsl" + uri="stylesheet/xsl/nwalsh/xhtml/docbook.xsl" /> + <uri + name="docbook_chunk.xsl" + uri="stylesheet/xsl/nwalsh/xhtml/chunk.xsl" /> + <uri + name="docbook_fo.xsl" + uri="stylesheet/xsl/nwalsh/fo/docbook.xsl" /> + + </group> + +</catalog> diff --git a/doc/catalog-mandrake.xml b/doc/catalog-mandrake.xml new file mode 100644 index 0000000..e797700 --- /dev/null +++ b/doc/catalog-mandrake.xml @@ -0,0 +1,43 @@ +<?xml version="1.0" ?> +<!DOCTYPE catalog + PUBLIC "-//OASIS/DTD Entity Resolution XML Catalog V1.0//EN" + "http://www.oasis-open.org/committees/entity/release/1.0/catalog.dtd"> + +<catalog xmlns="urn:oasis:names:tc:entity:xmlns:xml:catalog"> + + <!-- The directory DTD and stylesheet files are installed under --> + <group xml:base="file:///usr/share/sgml/docbook/" > + + <!-- Resolve DTD URL system ID to local file --> + <rewriteSystem + systemIdStartString="http://www.oasis-open.org/docbook/xml/4.2/" + rewritePrefix="xml-dtd-4.2/" /> + <!-- Resolve stylesheet URL to local file --> + <rewriteURI + uriStartString="http://docbook.sourceforge.net/release/xsl/current/" + rewritePrefix="xsl-stylesheets/" /> + + <!-- Resolve DTD PUBLIC identifiers --> + <nextCatalog catalog="xml-dtd-4.2/catalog.xml" /> + + <!-- To resolve simple DTD SYSTEM identifiers. --> + <!-- Note: this does not work with Java resolver --> + <!-- classes in Saxon or Xalan --> + <system + systemId="docbook.dtd" + uri="xml-dtd-4.2/docbookx.dtd" /> + + <!-- To resolve short stylesheet references --> + <uri + name="docbook_html.xsl" + uri="xsl-stylesheets/xhtml/docbook.xsl" /> + <uri + name="docbook_chunk.xsl" + uri="xsl-stylesheets/xhtml/chunk.xsl" /> + <uri + name="docbook_fo.xsl" + uri="xsl-stylesheets/fo/docbook.xsl" /> + + </group> + +</catalog> diff --git a/doc/catalog-redhat.xml b/doc/catalog-redhat.xml new file mode 100644 index 0000000..3b2d92f --- /dev/null +++ b/doc/catalog-redhat.xml @@ -0,0 +1,43 @@ +<?xml version="1.0" ?> +<!DOCTYPE catalog + PUBLIC "-//OASIS/DTD Entity Resolution XML Catalog V1.0//EN" + "http://www.oasis-open.org/committees/entity/release/1.0/catalog.dtd"> + +<catalog xmlns="urn:oasis:names:tc:entity:xmlns:xml:catalog"> + + <!-- The directory DTD and stylesheet files are installed under --> + <group xml:base="file:///usr/share/sgml/docbook/" > + + <!-- Resolve DTD URL system ID to local file --> + <rewriteSystem + systemIdStartString="http://www.oasis-open.org/docbook/xml/4.2/" + rewritePrefix="xml-dtd-4.2-1.0-17/" /> + <!-- Resolve stylesheet URL to local file --> + <rewriteURI + uriStartString="http://docbook.sourceforge.net/release/xsl/current/" + rewritePrefix="xsl-stylesheets/" /> + + <!-- Resolve DTD PUBLIC identifiers --> + <nextCatalog catalog="xml-dtd-4.2-1.0-17/catalog.xml" /> + + <!-- To resolve simple DTD SYSTEM identifiers. --> + <!-- Note: this does not work with Java resolver --> + <!-- classes in Saxon or Xalan --> + <system + systemId="docbook.dtd" + uri="xml-dtd-4.2-1.0-17/docbookx.dtd" /> + + <!-- To resolve short stylesheet references --> + <uri + name="docbook_html.xsl" + uri="xsl-stylesheets/xhtml/docbook.xsl" /> + <uri + name="docbook_chunk.xsl" + uri="xsl-stylesheets/xhtml/chunk.xsl" /> + <uri + name="docbook_fo.xsl" + uri="xsl-stylesheets/fo/docbook.xsl" /> + + </group> + +</catalog> diff --git a/doc/catalog-suse.xml b/doc/catalog-suse.xml new file mode 100644 index 0000000..9c772d6 --- /dev/null +++ b/doc/catalog-suse.xml @@ -0,0 +1,43 @@ +<?xml version="1.0" ?> +<!DOCTYPE catalog + PUBLIC "-//OASIS/DTD Entity Resolution XML Catalog V1.0//EN" + "http://www.oasis-open.org/committees/entity/release/1.0/catalog.dtd"> + +<catalog xmlns="urn:oasis:names:tc:entity:xmlns:xml:catalog"> + + <!-- The directory DTD and stylesheet files are installed under --> + <group xml:base="file:///usr/share/sgml/" > + + <!-- Resolve DTD URL system ID to local file --> + <rewriteSystem + systemIdStartString="http://www.oasis-open.org/docbook/xml/4.2/" + rewritePrefix="db42xml/" /> + <!-- Resolve stylesheet URL to local file --> + <rewriteURI + uriStartString="http://docbook.sourceforge.net/release/xsl/current/" + rewritePrefix="docbook/docbook-xsl/" /> + + <!-- Resolve DTD PUBLIC identifiers --> + <nextCatalog catalog="db42xml/catalog.xml" /> + + <!-- To resolve simple DTD SYSTEM identifiers. --> + <!-- Note: this does not work with Java resolver --> + <!-- classes in Saxon or Xalan --> + <system + systemId="docbook.dtd" + uri="db42xml/docbookx.dtd" /> + + <!-- To resolve short stylesheet references --> + <uri + name="docbook_html.xsl" + uri="docbook/docbook-xsl/xhtml/docbook.xsl" /> + <uri + name="docbook_chunk.xsl" + uri="docbook/docbook-xsl/xhtml/chunk.xsl" /> + <uri + name="docbook_fo.xsl" + uri="docbook/docbook-xsl/fo/docbook.xsl" /> + + </group> + +</catalog> diff --git a/doc/catalog-suse91.xml b/doc/catalog-suse91.xml new file mode 100644 index 0000000..2affd4c --- /dev/null +++ b/doc/catalog-suse91.xml @@ -0,0 +1,48 @@ +<?xml version="1.0" ?> +<!DOCTYPE catalog + PUBLIC "-//OASIS/DTD Entity Resolution XML Catalog V1.0//EN" + "http://www.oasis-open.org/committees/entity/release/1.0/catalog.dtd"> + +<catalog xmlns="urn:oasis:names:tc:entity:xmlns:xml:catalog"> + + <!-- The directory DTD and stylesheet files are installed under --> + <group xml:base="file:///usr/share/xml/" > + + <!-- Resolve DTD URL system ID to local file --> + <rewriteSystem + systemIdStartString="http://www.oasis-open.org/docbook/xml/4.2/" + rewritePrefix="docbook/schema/dtd/4.2/" /> + <!-- Resolve stylesheet URL to local file --> + <rewriteURI + uriStartString="http://docbook.sourceforge.net/release/xsl/current/" + rewritePrefix="docbook/stylesheet/nwalsh/current/" /> + + <!-- Resolve DTD PUBLIC identifiers --> + <nextCatalog catalog="docbook/schema/dtd/4.2/catalog.xml" /> + + <!-- To resolve simple DTD SYSTEM identifiers. --> + <!-- Note: this does not work with Java resolver --> + <!-- classes in Saxon or Xalan --> + <system + systemId="docbook.dtd" + uri="docbook/schema/dtd/4.2/docbookx.dtd" /> + <uri + name="docbookx.dtd" + uri="docbook/schema/dtd/4.2/docbookx.dtd" /> + <system + systemId="docbookx.dtd" + uri="docbook/schema/dtd/4.2/docbookx.dtd" /> + <!-- To resolve short stylesheet references --> + <uri + name="docbook_html.xsl" + uri="docbook/stylesheet/nwalsh/current/xhtml/docbook.xsl" /> + <uri + name="docbook_chunk.xsl" + uri="docbook/stylesheet/nwalsh/current/xhtml/chunk.xsl" /> + <uri + name="docbook_fo.xsl" + uri="docbook/stylesheet/nwalsh/current/fo/docbook.xsl" /> + + </group> + +</catalog> diff --git a/doc/clsql.pdf b/doc/clsql.pdf Binary files differnew file mode 100644 index 0000000..4922a96 --- /dev/null +++ b/doc/clsql.pdf diff --git a/doc/clsql.xml b/doc/clsql.xml new file mode 100644 index 0000000..5c81a2a --- /dev/null +++ b/doc/clsql.xml @@ -0,0 +1,30 @@ +<?xml version='1.0' ?> +<!DOCTYPE book PUBLIC "-//OASIS//DTD DocBook XML V4.2//EN" + "http://www.oasis-open.org/docbook/xml/4.2/docbookx.dtd" [ +<!ENTITY % myents SYSTEM "entities.inc"> +<!ENTITY % xinclude SYSTEM "xinclude.mod"> +%myents; +%xinclude; +]> + +<book lang="en"> + <xi:include href="bookinfo.xml" xmlns:xi="http://www.w3.org/2001/XInclude" /> + <xi:include href="preface.xml" xmlns:xi="http://www.w3.org/2001/XInclude" /> + <xi:include href="intro.xml" xmlns:xi="http://www.w3.org/2001/XInclude" /> + <xi:include href="csql.xml" xmlns:xi="http://www.w3.org/2001/XInclude" /> + <xi:include href="ref-connect.xml" xmlns:xi="http://www.w3.org/2001/XInclude" /> + <xi:include href="ref-syntax.xml" xmlns:xi="http://www.w3.org/2001/XInclude" /> + <xi:include href="ref-fddl.xml" xmlns:xi="http://www.w3.org/2001/XInclude" /> + <xi:include href="ref-fdml.xml" xmlns:xi="http://www.w3.org/2001/XInclude" /> + <xi:include href="ref-transaction.xml" xmlns:xi="http://www.w3.org/2001/XInclude" /> + <xi:include href="ref-ooddl.xml" xmlns:xi="http://www.w3.org/2001/XInclude" /> + <xi:include href="ref-oodml.xml" xmlns:xi="http://www.w3.org/2001/XInclude" /> + <xi:include href="ref-recording.xml" xmlns:xi="http://www.w3.org/2001/XInclude" /> + <xi:include href="ref-conditions.xml" xmlns:xi="http://www.w3.org/2001/XInclude" /> + <!-- <xi:include href="ref-lob.xml" xmlns:xi="http://www.w3.org/2001/XInclude" /> --> + <!-- <xi:include href="ref-prepared.xml" xmlns:xi="http://www.w3.org/2001/XInclude" /> --> + <!-- <xi:include href="ref-clsql-sys.xml" xmlns:xi="http://www.w3.org/2001/XInclude" /> --> + <xi:include href="global-index.xml" xmlns:xi="http://www.w3.org/2001/XInclude" /> + <xi:include href="appendix.xml" xmlns:xi="http://www.w3.org/2001/XInclude" /> + <xi:include href="glossary.xml" xmlns:xi="http://www.w3.org/2001/XInclude" /> +</book> diff --git a/doc/csql.xml b/doc/csql.xml new file mode 100644 index 0000000..f494441 --- /dev/null +++ b/doc/csql.xml @@ -0,0 +1,749 @@ +<?xml version='1.0' ?> +<!DOCTYPE book PUBLIC "-//OASIS//DTD DocBook XML V4.2//EN" + "http://www.oasis-open.org/docbook/xml/4.2/docbookx.dtd" [ +<!ENTITY % myents SYSTEM "entities.inc"> +%myents; +]> + +<chapter id="csql"> + <title>&commonsql; Tutorial</title> + <subtitle>Based on the &usql; Tutorial</subtitle> + + <sect1 id="csql-intro"> + <title>Introduction</title> + + <para> + The goal of this tutorial is to guide a new developer thru the + process of creating a set of &clsql; classes providing a + Object-Oriented interface to persistent data stored in an &sql; + database. We will assume that the reader is familiar with how + &sql; works, how relations (tables) should be structured, and + has created at least one &sql; application previously. We will + also assume a minor level of experience with Common Lisp. + </para> + + <para> + &clsql; provides two different interfaces to &sql; databases, a + Functional interface, and an Object-Oriented interface. The + Functional interface consists of a special syntax for embedded + &sql; expressions in Lisp, and provides lisp functions for &sql; + operations like <symbol>SELECT</symbol> and + <symbol>UPDATE</symbol>. The object-oriented interface provides + a way for mapping Common Lisp Objects System (CLOS) objects into + databases and includes functions for inserting new objects, + querying objects, and removing objects. Most applications will + use a combination of the two. + </para> + + <para> + &clsql; is based on the CommonSQL package from LispWorks Ltd, so the + documentation that LispWorks makes available online is useful for + &clsql; as well. It is suggested that developers new to &clsql; read + their documentation as well, as any differences between CommonSQL + and &clsql; are minor. LispWorks makes the following documents + available: + </para> + + <itemizedlist> + <listitem> + <para> + <ulink url="http://www.lispworks.com/documentation/lw44/LWUG/html/lwuser-204.htm"> + <citetitle>&lw; User Guide - The &commonsql; + Package + </citetitle> + </ulink> + </para> + </listitem> + + <listitem> + <para> + <ulink url="http://www.lispworks.com/documentation/lw44/LWRM/html/lwref-424.htm"> + <citetitle>&lw; Reference Manual - The SQL + Package</citetitle> + </ulink> + </para> + </listitem> + + <listitem> + <para> + <ulink url="http://www.lispworks.com/documentation/sql-tutorial/index.html"> + <citetitle>&commonsql; Tutorial by Nick Levine</citetitle> + </ulink> + </para> + </listitem> + </itemizedlist> + </sect1> + + <sect1> + <title>Data Modeling with &clsql;</title> + + <para> + Before we can create, query and manipulate &clsql; objects, we + need to define our data model as noted by Philip Greenspun + <footnote> + <para> + <ulink + url="http://philip.greenspun.com/sql/data-modeling.html"> + <citetitle>Philip Greenspun's "SQL For Web Nerds" - Data + Modeling</citetitle> + </ulink> + </para> + </footnote> + </para> + + <para> + When data modeling, you are telling the relational database + management system (RDBMS) the following: + </para> + + <itemizedlist> + <listitem> + <para>What elements of the data you will store.</para> + </listitem> + <listitem> + <para>How large each element can be.</para> + </listitem> + <listitem> + <para>What kind of information each element can contain.</para> + </listitem> + <listitem> + <para>What elements may be left blank.</para> + </listitem> + <listitem> + <para>Which elements are constrained to a fixed range.</para> + </listitem> + <listitem> + <para>Whether and how various tables are to be linked.</para> + </listitem> + </itemizedlist> + + <para> + With &sql; database one would do this by defining a set of + relations, or tables, followed by a set of queries for joining + the tables together in order to construct complex records. + However, with &clsql; we do this by defining a set of CLOS + classes, specifying how they will be turned into tables, and how + they can be joined to one another via relations between their + attributes. The &sql; tables, as well as the queries for + joining them together are created for us automatically, saving + us from dealing with some of the tedium of &sql;. + </para> + + <para> + Let us start with a simple example of two &sql; tables, and the + relations between them. + </para> + +<programlisting> +CREATE TABLE EMPLOYEE ( emplid NOT NULL number(38), + first_name NOT NULL varchar2(30), + last_name NOT NULL varchar2(30), + email varchar2(100), + companyid NOT NULL number(38), + managerid number(38)) + +CREATE TABLE COMPANY ( companyid NOT NULL number(38), + name NOT NULL varchar2(100), + presidentid NOT NULL number(38)) +</programlisting> + +<para> +This is of course the canonical &sql; tutorial example, "The Org Chart". +</para> + +<para> +In &clsql;, we would have two "view classes" (a fancy word for a class +mapped into a database). They would be defined as follows: +</para> + +<programlisting> +(clsql:def-view-class employee () + ((emplid + :db-kind :key + :db-constraints :not-null + :type integer + :initarg :emplid) + (first-name + :accessor first-name + :type (string 30) + :initarg :first-name) + (last-name + :accessor last-name + :type (string 30) + :initarg :last-name) + (email + :accessor employee-email + :type (string 100) + :nulls-ok t + :initarg :email) + (companyid + :type integer + :initarg :companyid) + (managerid + :type integer + :nulls-ok t + :initarg :managerid)) + (:base-table employee)) + +(clsql:def-view-class company () + ((companyid + :db-kind :key + :db-constraints :not-null + :type integer + :initarg :companyid) + (name + :type (string 100) + :initarg :name) + (presidentid + :type integer + :initarg :presidentid)) + (:base-table company)) +</programlisting> + +<para> + The <function>DEF-VIEW-CLASS</function> macro is just like the + normal CLOS <function>DEFCLASS</function> macro, except that it + handles several slot options that <function>DEFCLASS</function> + doesn't. These slot options have to do with the mapping of the slot + into the database. We only use a few of the slot options in the + above example, but there are several others. +</para> + +<itemizedlist> + + <listitem><para> + <symbol>:column</symbol> - The name of the &sql; column this slot is stored in. + Defaults to the slot name. If the slot name is not a valid &sql; + identifier, it is escaped, so foo-bar becomes foo_bar. + </para></listitem> + + <listitem> + <para> + <symbol>:db-kind</symbol> - The kind of database mapping which + is performed for this slot. <symbol>:base</symbol> indicates + the slot maps to an ordinary column of the database view. + <symbol>:key</symbol> indicates that this slot corresponds to + part of the unique keys for this view, <symbol>:join</symbol> + indicates a join slot representing a relation to another view + and :virtual indicates that this slot is an ordinary CLOS slot. + Defaults to <symbol>:base</symbol>. </para></listitem> + + <listitem> + <para> + <symbol>:db-reader</symbol> - If a string, then when reading + values from the database, the string will be used for a format + string, with the only value being the value from the database. + The resulting string will be used as the slot value. If a + function then it will take one argument, the value from the + database, and return the value that should be put into the slot. + </para></listitem> + + <listitem> + <para> + <symbol>:db-writer</symbol> - If a string, then when reading + values from the slot for the database, the string will be used + for a format string, with the only value being the value of the + slot. The resulting string will be used as the column value in + the database. If a function then it will take one argument, the + value of the slot, and return the value that should be put into + the database.</para></listitem> + + <listitem> + <para> + <symbol>:db-type</symbol> - A string which will be used as the + type specifier for this slots column definition in the database. + </para></listitem> + + <listitem> + <para> + <symbol>:void-value</symbol> - The Lisp value to return if the + field is &null;. The default is &nil;.</para></listitem> + + <listitem> + <para> + <symbol>:db-info</symbol> - A join specification. + </para></listitem> +</itemizedlist> + +<para> + In our example each table as a primary key attribute, which is + required to be unique. We indicate that a slot is part of the + primary key (&clsql; supports multi-field primary keys) by specifying + the <symbol>:db-kind</symbol> key slot option. +</para> + +<para> + The &sql; type of a slot when it is mapped into the database is + determined by the <symbol>:type</symbol> slot option. The argument + for the <symbol>:type</symbol> option is a Common Lisp datatype. + The &clsql; framework will determine the appropriate mapping + depending on the database system the table is being created in. If + we really wanted to determine what &sql; type was used for a slot, + we could specify a <symbol>:db-type</symbol> option like + "NUMBER(38)" and we would be guaranteed that the slot would be + stored in the database as a NUMBER(38). This is not recomended + because it could makes your view class unportable across database + systems. +</para> + +<para> + <function>DEF-VIEW-CLASS</function> also supports some class + options, like <symbol>:base-table</symbol>. The + <symbol>:base-table</symbol> option specifies what the table name + for the view class will be when it is mapped into the database. +</para> + +<para> + Another class option is <symbol>:normalizedp</symbol>, which signals + &clsql; to use a normalized schema for the mapping from slots to + &sql; columns. By default &clsql; includes all the slots of a parent + class that map to &sql; columns into the child class. This option + tells &clsql; to normalize the schema, so that a join is done on the + primary keys of the concerned tables to get a complete column set + for the classes. For more information, see <link linkend="def-view-class"> + <function>def-view-class</function></link>. +</para> + </sect1> + +<sect1 id="csql-rel"> +<title>Class Relations</title> + +<para> +In an &sql; only application, the <symbol>EMPLOYEE</symbol> and +<symbol>COMPANY</symbol> tables can be queried to determine things +like, "Who is Vladimir's manager?", "What company does Josef work +for?", and "What employees work for Widgets Inc.". This is done by +joining tables with an &sql; query. +</para> + +<para> +Who works for Widgets Inc.? +</para> + +<programlisting> +SELECT first_name, last_name FROM employee, company + WHERE employee.companyid = company.companyid + AND company.company_name = "Widgets Inc." +</programlisting> + +<para> +Who is Vladimir's manager? +</para> + +<programlisting> +SELECT managerid FROM employee + WHERE employee.first_name = "Vladimir" + AND employee.last_name = "Lenin" +</programlisting> + +<para> +What company does Josef work for? +</para> + +<programlisting> +SELECT company_name FROM company, employee + WHERE employee.first_name = "Josef" + AND employee.last-name = "Stalin" + AND employee.companyid = company.companyid +</programlisting> + +<para> +With &clsql; however we do not need to write out such queries because +our view classes can maintain the relations between employees and +companies, and employees to their managers for us. We can then access +these relations like we would any other attribute of an employee or +company object. In order to do this we define some join slots for our +view classes. +</para> + +<para> +What company does an employee work for? If we add the following slot +definition to the employee class we can then ask for it's +<symbol>COMPANY</symbol> slot and get the appropriate result. +</para> + +<programlisting> + ;; In the employee slot list + (company + :accessor employee-company + :db-kind :join + :db-info (:join-class company + :home-key companyid + :foreign-key companyid + :set nil)) +</programlisting> + +<para> +Who are the employees of a given company? And who is the president of +it? We add the following slot definition to the company view class and +we can then ask for it's <symbol>EMPLOYEES</symbol> slot and get the +right result. +</para> + +<programlisting> + ;; In the company slot list + (employees + :reader company-employees + :db-kind :join + :db-info (:join-class employee + :home-key companyid + :foreign-key companyid + :set t)) + + (president + :reader president + :db-kind :join + :db-info (:join-class employee + :home-key presidentid + :foreign-key emplid + :set nil)) +</programlisting> + +<para> +And lastly, to define the relation between an employee and their +manager: +</para> + +<programlisting> + ;; In the employee slot list + (manager + :accessor employee-manager + :db-kind :join + :db-info (:join-class employee + :home-key managerid + :foreign-key emplid + :set nil)) +</programlisting> + +<para> +&clsql; join slots can represent one-to-one, one-to-many, and +many-to-many relations. Above we only have one-to-one and one-to-many +relations, later we will explain how to model many-to-many relations. +First, let's go over the slot definitions and the available options. +</para> + +<para> +In order for a slot to be a join, we must specify that it's +<symbol>:db-kind</symbol> <symbol>:join</symbol>, as opposed to +<symbol>:base</symbol> or <symbol>:key</symbol>. Once we do that, we +still need to tell &clsql; how to create the join statements for the +relation. This is what the <symbol>:db-info</symbol> option does. It +is a list of keywords and values. The available keywords are: +</para> + +<itemizedlist> + <listitem> + <para> + <symbol>:join-class</symbol> - The view class to which we want + to join. It can be another view class, or the same view class + as our object.</para></listitem> + + <listitem> + <para> + <symbol>:home-key</symbol> - The slot(s) in the immediate object + whose value will be compared to the foreign-key slot(s) in the + join-class in order to join the two tables. It can be a single + slot-name, or it can be a list of slot names.</para></listitem> + + <listitem> + <para> + <symbol>:foreign-key</symbol> - The slot(s) in the join-class + which will be compared to the value(s) of the home-key. + </para></listitem> + + <listitem> + <para> + <symbol>:set</symbol> - A boolean which if false, indicates that + this is a one-to-one relation, only one object will be returned. + If true, than this is a one-to-many relation, a list of objects + will be returned when we ask for this slots value. + </para></listitem> +</itemizedlist> + +<para> +There are other :join-info options available in &clsql;, but we will +save those till we get to the many-to-many relation examples. +</para> + +<simplesect> + <title>Object Oriented Class Relations</title> + + <para> + &clsql; provides an Object Oriented Data Definition Language, which + provides a mapping from &sql; tables to CLOS objects. By default class + inheritance is handled by including all the columns from parent + classes into the child class. This means your database schema becomes + very much denormalized. The class option <symbol>:normalizedp</symbol> + can be used to disable the default behaviour and have &clsql; + normalize the database schemas of inherited classes. + </para> + + <para> + See <link linkend="def-view-class"><function>def-view-class</function></link> + for more information. + </para> +</simplesect> +</sect1> + +<sect1 id="csql-creat"> +<title>Object Creation</title> + +<para> +Now that we have our model laid out, we should create some object. +Let us assume that we have a database connect set up already. We +first need to create our tables in the database: +</para> + +<para> +Note: the file <filename>examples/clsql-tutorial.lisp</filename> contains +view class definitions which you can load into your list at this point +in order to play along at home. +</para> + +<programlisting> +(clsql:create-view-from-class 'employee) +(clsql:create-view-from-class 'company) +</programlisting> + +<para> +Then we will create our objects. We create them just like you would +any other CLOS object: +</para> + +<programlisting> +(defvar company1 (make-instance 'company + :companyid 1 + :presidentid 1 + :name "Widgets Inc.")) + +(defvar employee1 (make-instance 'employee + :emplid 1 + :first-name "Vladimir" + :last-name "Lenin" + :email "lenin@soviet.org" + :companyid 1)) + +(defvar employee2 (make-instance 'employee + :emplid 2 + :first-name "Josef" + :last-name "Stalin" + :email "stalin@soviet.org" + :companyid 1 + :managerid 1)) +</programlisting> + +<para> +In order to insert an objects into the database we use the +<function>UPDATE-RECORDS-FROM-INSTANCE</function> function as follows: +</para> + +<programlisting> +(clsql:update-records-from-instance employee1) +(clsql:update-records-from-instance employee2) +(clsql:update-records-from-instance company1) +</programlisting> + +<para> + After you make any changes to an object, you have to specifically + tell &clsql; to update the &sql; database. The + <function>UPDATE-RECORDS-FROM-INSTANCE</function> method will write + all of the changes you have made to the object into the database. +</para> + +<para> + Since &clsql; objects are just normal CLOS objects, we can manipulate + their slots just like any other object. For instance, let's say + that Lenin changes his email because he was getting too much spam + from the German Socialists. +</para> + +<programlisting> +;; Print Lenin's current email address, change it and save it to the +;; database. Get a new object representing Lenin from the database +;; and print the email + +;; This lets us use the functional &clsql; interface with [] syntax +(clsql:locally-enable-sql-reader-syntax) + +(format t "The email address of ~A ~A is ~A" + (first-name employee1) + (last-name employee1) + (employee-email employee1)) + +(setf (employee-email employee1) "lenin-nospam@soviets.org") + +;; Update the database +(clsql:update-records-from-instance employee1) + +(let ((new-lenin (car (clsql:select 'employee + :where [= [slot-value 'employee 'emplid] 1])))) + (format t "His new email is ~A" + (employee-email new-lenin))) +</programlisting> + +<para> + Everything except for the last <function>LET</function> expression + is already familiar to us by now. To understand the call to + <function>CLSQL:SELECT</function> we need to discuss the + Functional &sql; interface and it's integration with the Object + Oriented interface of &clsql;. +</para> + +</sect1> + +<sect1 id="csql-find"> +<title>Finding Objects</title> + +<para> + Now that we have our objects in the database, how do we get them out + when we need to work with them? &clsql; provides a functional + interface to &sql;, which consists of a special Lisp reader macro + and some functions. The special syntax allows us to embed &sql; in + lisp expressions, and lisp expressions in &sql;, with ease. +</para> + +<para> + Once we have turned on the syntax with the expression: +</para> + +<programlisting> +(clsql:locally-enable-sql-reader-syntax) +</programlisting> + +<para> + We can start entering fragments of &sql; into our lisp reader. We + will get back objects which represent the lisp expressions. These + objects will later be compiled into &sql; expressions that are + optimized for the database backed we are connected to. This means + that we have a database independent &sql; syntax. Here are some + examples: +</para> + +<programlisting> +;; an attribute or table name +[foo] => #<CLSQL-SYS::SQL-IDENT-ATTRIBUTE FOO> + +;; a attribute identifier with table qualifier +[foo bar] => #<CLSQL-SYS::SQL-IDENT-ATTRIBUTE FOO.BAR> + +;; a attribute identifier with table qualifier +[= "Lenin" [first_name]] => + #<CLSQL-SYS::SQL-RELATIONAL-EXP ('Lenin' = FIRST_NAME)> + +[< [emplid] 3] => + #<CLSQL-SYS::SQL-RELATIONAL-EXP (EMPLID < 3)> + +[and [< [emplid] 2] [= [first_name] "Lenin"]] => + #<CLSQL-SYS::SQL-RELATIONAL-EXP ((EMPLID < 2) AND + (FIRST_NAME = 'Lenin'))> + + +;; If we want to reference a slot in an object we can us the +;; SLOT-VALUE sql extension +[= [slot-value 'employee 'emplid] 1] => + #<CLSQL-SYS::SQL-RELATIONAL-EXP (EMPLOYEE.EMPLID = 1)> + +[= [slot-value 'employee 'emplid] + [slot-value 'company 'presidentid]] => + #<CLSQL-SYS::SQL-RELATIONAL-EXP (EMPLOYEE.EMPLID = COMPANY.PRESIDENTID)> +</programlisting> + +<para> + The <function>SLOT-VALUE</function> operator is important because it + let's us query objects in a way that is robust to any changes in the + object->table mapping, like column name changes, or table name + changes. So when you are querying objects, be sure to use the + <function>SLOT-VALUE</function> &sql; extension. +</para> + +<para> + Since we can now formulate &sql; relational expression which can be + used as qualifiers, like we put after the <symbol>WHERE</symbol> + keyword in &sql; statements, we can start querying our objects. + &clsql; provides a function <symbol>SELECT</symbol> which can return + use complete objects from the database which conform to a qualifier, + can be sorted, and various other &sql; operations. +</para> + +<para> + The first argument to <symbol>SELECT</symbol> is a class name. it + also has a set of keyword arguments which are covered in the + documentation. For now we will concern ourselves only with the + :where keyword. Select returns a list of objects, or nil if it + can't find any. It's important to remember that it always returns a + list, so even if you are expecting only one result, you should + remember to extract it from the list you get from + <symbol>SELECT</symbol>. +</para> + +<programlisting> +;; all employees +(clsql:select 'employee) +;; all companies +(clsql:select 'company) + +;; employees named Lenin +(clsql:select 'employee :where [= [slot-value 'employee 'last-name] + "Lenin"]) + +(clsql:select 'company :where [= [slot-value 'company 'name] + "Widgets Inc."]) + +;; Employees of Widget's Inc. +(clsql:select 'employee + :where [and [= [slot-value 'employee 'companyid] + [slot-value 'company 'companyid]] + [= [slot-value 'company 'name] + "Widgets Inc."]]) + +;; Same thing, except that we are using the employee +;; relation in the company view class to do the join for us, +;; saving us the work of writing out the &sql;! +(company-employees company1) + +;; President of Widgets Inc. +(president company1) + +;; Manager of Josef Stalin +(employee-manager employee2) +</programlisting> + +</sect1> + +<sect1 id="csql-del"> +<title>Deleting Objects</title> + +<para> + Now that we know how to create objects in our database, manipulate + them and query them (including using our predefined relations to + save us the trouble writing alot of &sql;) we should learn how to + clean up after ourself. It's quite simple really. The function + <function>DELETE-INSTANCE-RECORDS</function> will remove an object + from the database. However, when we remove an object we are + responsible for making sure that the database is left in a correct + state. +</para> + +<para> + For example, if we remove a company record, we need to either remove + all of it's employees or we need to move them to another company. + Likewise if we remove an employee, we should make sure to update any + other employees who had them as a manager. +</para> + +</sect1> + +<sect1 id="csql-concl"> +<title>Conclusion</title> + +<para> + There are many nooks and crannies to &clsql;, some of which are + covered in the Xanalys documents we refered to earlier, some are + not. The best documentation at this time is still the source code + for &clsql; itself and the inline documentation for its various + functions. +</para> + +</sect1> + +</chapter> diff --git a/doc/entities.inc b/doc/entities.inc new file mode 100644 index 0000000..25ef73e --- /dev/null +++ b/doc/entities.inc @@ -0,0 +1,31 @@ +<!ENTITY asdf "<application>ASDF</application>"> +<!ENTITY clocc "<application><emphasis>CLOCC</emphasis></application>"> +<!ENTITY cclan "<application><emphasis>CCLAN</emphasis></application>"> +<!ENTITY uffi "<application><emphasis>UFFI</emphasis></application>"> +<!ENTITY ffi "<emphasis>FFI</emphasis>"> +<!ENTITY clsql "<application><emphasis>CLSQL</emphasis></application>"> +<!ENTITY maisql "<application><emphasis>MaiSQL</emphasis></application>"> +<!ENTITY sql "<application>SQL</application>"> +<!ENTITY usql "<application>UncommonSQL</application>"> +<!ENTITY commonsql "<application>CommonSQL</application>"> +<!ENTITY mysql "<application>MySQL</application>"> +<!ENTITY postgresql "<application>PostgreSQL</application>"> +<!ENTITY sqlite "<application>SQLite version 2</application>"> +<!ENTITY sqlite3 "<application>SQLite version 3</application>"> +<!ENTITY oracle "<application>Oracle</application>"> +<!ENTITY odbc "<application>ODBC</application>"> +<!ENTITY aodbc "<application>AODBC</application>"> +<!ENTITY cmucl "<application>CMUCL</application>"> +<!ENTITY scl "<application>SCL</application>"> +<!ENTITY md5 "<application>MD5</application>"> +<!ENTITY sbcl "<application>SBCL</application>"> +<!ENTITY openmcl "<application>OpenMCL</application>"> +<!ENTITY lw "<application>Lispworks</application>"> +<!ENTITY acl "<application>AllegroCL</application>"> +<!ENTITY cl "<application>ANSI Common Lisp</application>"> +<!ENTITY t "<constant>T</constant>"> +<!ENTITY nil "<constant>NIL</constant>"> +<!ENTITY null "<constant>NULL</constant>"> +<!ENTITY c "<application>C</application>"> +<!ENTITY unix "<application>UNIX</application>"> +<!ENTITY mswindows "<application>Microsoft Windows</application>"> diff --git a/doc/fo.xsl b/doc/fo.xsl new file mode 100644 index 0000000..5cb69da --- /dev/null +++ b/doc/fo.xsl @@ -0,0 +1,6 @@ +<?xml version='1.0'?> +<xsl:stylesheet xmlns:xsl="http://www.w3.org/1999/XSL/Transform" + version="1.0"> +<xsl:import href="docbook_fo.xsl"/> +<xsl:param name="fop1.extensions" select="1"/> +</xsl:stylesheet> diff --git a/doc/global-index.xml b/doc/global-index.xml new file mode 100644 index 0000000..064cf53 --- /dev/null +++ b/doc/global-index.xml @@ -0,0 +1,137 @@ +<?xml version='1.0' ?> +<!DOCTYPE book PUBLIC "-//OASIS//DTD DocBook XML V4.2//EN" +"http://www.oasis-open.org/docbook/xml/4.2/docbookx.dtd" [ +<!ENTITY % myents SYSTEM "entities.inc"> +%myents; +]> + +<reference id="indexes"> + <title>Index</title> + + <refentry id="clsql-index"> + <refnamediv> + <refname>Alphabetical Index for package CLSQL</refname> + <refpurpose>Clickable index of all symbols</refpurpose> + </refnamediv> + + <refsect1> + <title> + </title> + <simplelist columns="2"> + + <!-- VARIABLES --> + + <member><link linkend="backend-warning-behavior">*BACKEND-WARNING-BEHAVIOR*</link></member> + <member><link linkend="cache-table-queries-default">*CACHE-TABLE-QUERIES-DEFAULT*</link></member> + <member><link linkend="connect-if-exists">*CONNECT-IF-EXISTS*</link></member> + <member><link linkend="db-auto-sync">*DB-AUTO-SYNC*</link></member> + <member><link linkend="default-database">*DEFAULT-DATABASE*</link></member> + <member><link linkend="default-database-type">*DEFAULT-DATABASE-TYPE*</link></member> + <member><link linkend="default-update-objects-max-len">*DEFAULT-UPDATE-OBJECTS-MAX-LEN*</link></member> + <member><link linkend="default-string-length">*DEFAULT-STRING-LENGTH*</link></member> + <member><link linkend="initialized-database-types">*INITIALIZED-DATABASE-TYPES*</link></member> + + <!-- OTHER SYMBOLS IN ALPHABETICAL ORDER --> + + <member><link linkend="add-sql-stream">ADD-SQL-STREAM</link></member> + <member><link linkend="add-transaction-commit-hook">ADD-TRANSACTION-COMMIT-HOOK</link></member> + <member><link linkend="add-transaction-rollback-hook">ADD-TRANSACTION-ROLLBACK-HOOK</link></member> + <member><link linkend="attribute-type">ATTRIBUTE-TYPE</link></member> + <member><link linkend="cache-table-queries">CACHE-TABLE-QUERIES</link></member> + <member><link linkend="commit">COMMIT</link></member> + <member><link linkend="connect">CONNECT</link></member> + <member><link linkend="connected-databases">CONNECTED-DATABASES</link></member> + <member><link linkend="create-database">CREATE-DATABASE</link></member> + <member><link linkend="create-index">CREATE-INDEX</link></member> + <member><link linkend="create-sequence">CREATE-SEQUENCE</link></member> + <member><link linkend="create-table">CREATE-TABLE</link></member> + <member><link linkend="create-view">CREATE-VIEW</link></member> + <member><link linkend="create-view-from-class">CREATE-VIEW-FROM-CLASS</link></member> + <member><link linkend="database">DATABASE</link></member> + <member><link linkend="database-name">DATABASE-NAME</link></member> + <member><link linkend="database-name-from-spec">DATABASE-NAME-FROM-SPEC</link></member> + <member><link linkend="database-type">DATABASE-TYPE</link></member> + <member><link linkend="def-view-class">DEF-VIEW-CLASS</link></member> + <member><link linkend="delete-instance-records">DELETE-INSTANCE-RECORDS</link></member> + <member><link linkend="delete-records">DELETE-RECORDS</link></member> + <member><link linkend="delete-sql-stream">DELETE-SQL-STREAM</link></member> + <member><link linkend="destroy-database">DESTROY-DATABASE</link></member> + <member><link linkend="disable-sql-reader-syntax">DISABLE-SQL-READER-SYNTAX</link></member> + <member><link linkend="disconnect">DISCONNECT</link></member> + <member><link linkend="disconnect-pooled">DISCONNECT-POOLED</link></member> + <member><link linkend="do-query">DO-QUERY</link></member> + <member><link linkend="drop-index">DROP-INDEX</link></member> + <member><link linkend="drop-sequence">DROP-SEQUENCE</link></member> + <member><link linkend="drop-table">DROP-TABLE</link></member> + <member><link linkend="drop-view">DROP-VIEW</link></member> + <member><link linkend="drop-view-from-class">DROP-VIEW-FROM-CLASS</link></member> + <member><link linkend="enable-sql-reader-syntax">ENABLE-SQL-READER-SYNTAX</link></member> + <member><link linkend="execute-command">EXECUTE-COMMAND</link></member> + <member><link linkend="find-database">FIND-DATABASE</link></member> + <member><link linkend="in-transaction-p">IN-TRANSACTION-P</link></member> + <member><link linkend="index-exists-p">INDEX-EXISTS-P</link></member> + <member><link linkend="initialize-database-type">INITIALIZE-DATABASE-TYPE</link></member> + <member><link linkend="insert-records">INSERT-RECORDS</link></member> + <member><link linkend="instance-refreshed">INSTANCE-REFRESHED</link></member> + <member><link linkend="list-attribute-types">LIST-ATTRIBUTE-TYPES</link></member> + <member><link linkend="list-attributes">LIST-ATTRIBUTES</link></member> + <member><link linkend="list-classes">LIST-CLASSES</link></member> + <member><link linkend="list-databases">LIST-DATABASES</link></member> + <member><link linkend="list-indexes">LIST-INDEXES</link></member> + <member><link linkend="list-sequences">LIST-SEQUENCES</link></member> + <member><link linkend="list-sql-streams">LIST-SQL-STREAMS</link></member> + <member><link linkend="list-tables">LIST-TABLES</link></member> + <member><link linkend="list-views">LIST-VIEWS</link></member> + <member><link linkend="locally-disable-sql-reader-syntax">LOCALLY-DISABLE-SQL-READER-SYNTAX</link></member> + <member><link linkend="locally-enable-sql-reader-syntax">LOCALLY-ENABLE-SQL-READER-SYNTAX</link></member> + <member><link linkend="loop-tuples">LOOP-FOR-AS-TUPLES</link></member> + <member><link linkend="map-query">MAP-QUERY</link></member> + <member><link linkend="probe-database">PROBE-DATABASE</link></member> + <member><link linkend="query">QUERY</link></member> + <member><link linkend="reconnect">RECONNECT</link></member> + <member><link linkend="restore-sql-reader-syntax-state">RESTORE-SQL-READER-SYNTAX-STATE</link></member> + <member><link linkend="rollback">ROLLBACK</link></member> + <member><link linkend="select">SELECT</link></member> + <member><link linkend="sequence-exists-p">SEQUENCE-EXISTS-P</link></member> + <member><link linkend="sequence-last">SEQUENCE-LAST</link></member> + <member><link linkend="sequence-next">SEQUENCE-NEXT</link></member> + <member><link linkend="set-autocommit">SET-AUTOCOMMIT</link></member> + <member><link linkend="set-sequence-position">SET-SEQUENCE-POSITION</link></member> + <member><link linkend="sql">SQL</link></member> + <member><link linkend="sql-condition">SQL-CONDITION</link></member> + <member><link linkend="sql-connection-error">SQL-CONNECTION-ERROR</link></member> + <member><link linkend="sql-database-data-error">SQL-DATABASE-DATA-ERROR</link></member> + <member><link linkend="sql-database-error">SQL-DATABASE-ERROR</link></member> + <member><link linkend="sql-database-warning">SQL-DATABASE-WARNING</link></member> + <member><link linkend="sql-error">SQL-ERROR</link></member> + <member><link linkend="sql-expression">SQL-EXPRESSION</link></member> + <member><link linkend="sql-fatal-error">SQL-FATAL-ERROR</link></member> + <member><link linkend="sql-operation">SQL-OPERATION</link></member> + <member><link linkend="sql-operator">SQL-OPERATOR</link></member> + <member><link linkend="sql-recording-p">SQL-RECORDING-P</link></member> + <member><link linkend="sql-stream">SQL-STREAM</link></member> + <member><link linkend="sql-temporary-error">SQL-TEMPORARY-ERROR</link></member> + <member><link linkend="sql-timeout-error">SQL-TIMEOUT-ERROR</link></member> + <member><link linkend="sql-user-error">SQL-USER-ERROR</link></member> + <member><link linkend="sql-warning">SQL-WARNING</link></member> + <member><link linkend="start-sql-recording">START-SQL-RECORDING</link></member> + <member><link linkend="start-transaction">START-TRANSACTION</link></member> + <member><link linkend="status">STATUS</link></member> + <member><link linkend="stop-sql-recording">STOP-SQL-RECORDING</link></member> + <member><link linkend="table-exists-p">TABLE-EXISTS-P</link></member> + <member><link linkend="truncate-database">TRUNCATE-DATABASE</link></member> + <member><link linkend="update-instance-from-records">UPDATE-INSTANCE-FROM-RECORDS</link></member> + <member><link linkend="update-objects-joins">UPDATE-OBJECTS-JOINS</link></member> + <member><link linkend="update-record-from-slot">UPDATE-RECORD-FROM-SLOT</link></member> + <member><link linkend="update-record-from-slots">UPDATE-RECORD-FROM-SLOTS</link></member> + <member><link linkend="update-records">UPDATE-RECORDS</link></member> + <member><link linkend="update-records-from-instance">UPDATE-RECORDS-FROM-INSTANCE</link></member> + <member><link linkend="update-slot-from-record">UPDATE-SLOT-FROM-RECORD</link></member> + <member><link linkend="view-exists-p">VIEW-EXISTS-P</link></member> + <member><link linkend="with-database">WITH-DATABASE</link></member> + <member><link linkend="with-default-database">WITH-DEFAULT-DATABASE</link></member> + <member><link linkend="with-transaction">WITH-TRANSACTION</link></member> + </simplelist> +</refsect1> +</refentry> +</reference> diff --git a/doc/glossary.xml b/doc/glossary.xml new file mode 100644 index 0000000..fd73384 --- /dev/null +++ b/doc/glossary.xml @@ -0,0 +1,197 @@ +<?xml version='1.0' ?> +<!DOCTYPE book PUBLIC "-//OASIS//DTD DocBook XML V4.2//EN" +"http://www.oasis-open.org/docbook/xml/4.2/docbookx.dtd" [ +<!ENTITY % myents SYSTEM "entities.inc"> +%myents; +]> + +<glossary id="glossary"> + <note> + <para>This glossary is still very thinly populated, and not all + references in the main text have been properly linked and + coordinated with this glossary. This will hopefully change in + future revisions. + </para> + </note> + <glossentry id="gloss-attribute"> + <glossterm>Attribute</glossterm> + <glossdef> + <para> + A property of objects stored in a database table. Attributes are + represented as columns (or fields) in a table. + </para> + </glossdef> + </glossentry> + <glossentry> + <glossterm>Active database</glossterm> + <glosssee otherterm="gloss-database-object" /> + </glossentry> + <glossentry> + <glossterm>Connection</glossterm> + <glosssee otherterm="gloss-database-object" /> + </glossentry> + <!-- glossentry> + <glossterm>Closed Database</glossterm> + <glossdef> + <para> + An object of type <type>closed-database</type>. This is + in contrast to the terms connection, database, active + database or <glossterm + linkend="gloss-database-object">database object</glossterm> + which don't include objects which are closed database. + </para> + </glossdef> + </glossentry --> + <glossentry> + <glossterm>Column</glossterm> + <glosssee otherterm="gloss-attribute" /> + </glossentry> + <glossentry id="gloss-ddl"> + <glossterm>Data Definition Language (<acronym>DDL</acronym>) + </glossterm> + <glossdef> + <para> + The subset of SQL used for defining and examining the + structure of a database. + </para> + </glossdef> + </glossentry> + <glossentry id="gloss-dml"> + <glossterm>Data Manipulation Language (<acronym>DML</acronym>) + </glossterm> + <glossdef> + <para> + The subset of SQL used for inserting, deleting, updating and + fetching data in a database. + </para> + </glossdef> + </glossentry> + <glossentry> + <glossterm>database</glossterm> + <glosssee otherterm="gloss-database-object" /> + </glossentry> + <glossentry id="gloss-database-object"> + <glossterm>Database Object</glossterm> + <glossdef> + <para>An object of type <type>database</type>.</para> + </glossdef> + </glossentry> + <glossentry> + <glossterm>Field</glossterm> + <glosssee otherterm="gloss-attribute" /> + </glossentry> + <glossentry id="gloss-field-types"> + <glossterm>Field Types Specifier</glossterm> + <glossdef> + <para>A value that specifies the type of each field in a query.</para> + </glossdef> + </glossentry> + <glossentry id="gloss-ffi"> + <glossterm>Foreign Function Interface + (<acronym>FFI</acronym>) + </glossterm> + <glossdef> + <para> + An interface from Common Lisp to a external library which + contains compiled functions written in other programming + languages, typically C. + </para> + </glossdef> + </glossentry> + <glossentry id="gloss-query"> + <glossterm>Query</glossterm> + <glossdef> + <para> + An SQL statement which returns a set of results. + </para> + </glossdef> + </glossentry> + <glossentry> + <glossterm>RDBMS</glossterm> + <glossdef> + <para> + A Relational DataBase Management System + (<acronym>RDBMS</acronym>) is a software package for managing + a database in which the data is defined, organised and + accessed as rows and columns of a table. + </para> + </glossdef> + </glossentry> + <glossentry id="gloss-record"> + <glossterm>Record</glossterm> + <glossdef> + <para> + A sequence of attribute values stored in a database table. + </para> + </glossdef> + </glossentry> + <glossentry> + <glossterm>Row</glossterm> + <glosssee otherterm="gloss-record" /> + </glossentry> + <glossentry id="gloss-sql"> + <glossterm>Structured Query Language + (<acronym>SQL</acronym>) + </glossterm> + <glossdef> + <para> + An ANSI standard language for storing and retrieving data + in a relational database. + </para> + </glossdef> + </glossentry> + <glossentry id="gloss-sql-expression"> + <glossterm>SQL Expression</glossterm> + <glossdef> + <para>Either a string containing a valid SQL statement, or + an object of type <type>sql-expression</type>. + <!-- note> + <para>This has not been implemented yet, so only strings + are valid SQL expressions for the moment. + </para> + </note --> + </para> + </glossdef> + </glossentry> + <glossentry id="gloss-table"> + <glossterm>Table</glossterm> + <glossdef> + <para> + A collection of data which is defined, stored and accessed as + tuples of attribute values (i.e., rows and columns). + </para> + </glossdef> + </glossentry> + <glossentry id="gloss-transaction"> + <glossterm>Transaction</glossterm> + <glossdef> + <para> + An atomic unit of one or more SQL statements of which all or none are + successfully executed. + </para> + </glossdef> + </glossentry> + <glossentry> + <glossterm>Tuple</glossterm> + <glosssee otherterm="gloss-record" /> + </glossentry> + <glossentry id="gloss-view"> + <glossterm>View</glossterm> + <glossdef> + <para> + A table display whose structure and content are derived from an + existing table via a query. + </para> + </glossdef> + </glossentry> + <glossentry id="gloss-view-class"> + <glossterm>View Class</glossterm> + <glossdef> + <para> + The class <function>standard-db-object</function> or one of + its subclasses. + </para> + </glossdef> + </glossentry> +</glossary> + diff --git a/doc/html.tar.gz b/doc/html.tar.gz Binary files differnew file mode 100644 index 0000000..8718c23 --- /dev/null +++ b/doc/html.tar.gz diff --git a/doc/html.xsl b/doc/html.xsl new file mode 100644 index 0000000..163d76b --- /dev/null +++ b/doc/html.xsl @@ -0,0 +1,10 @@ +<?xml version='1.0'?> +<xsl:stylesheet xmlns:xsl="http://www.w3.org/1999/XSL/Transform" + version="1.0"> + +<xsl:import href="docbook_html.xsl"/> +<xsl:param name="use.id.as.filename" select="1"/> +<xsl:output encoding="UTF-8" method="html" /> + +</xsl:stylesheet> + diff --git a/doc/html_chunk.xsl b/doc/html_chunk.xsl new file mode 100644 index 0000000..a2bb88f --- /dev/null +++ b/doc/html_chunk.xsl @@ -0,0 +1,9 @@ +<?xml version='1.0'?> +<xsl:stylesheet xmlns:xsl="http://www.w3.org/1999/XSL/Transform" + version="1.0"> + +<xsl:import href="docbook_chunk.xsl"/> +<xsl:param name="use.id.as.filename" select="1"/> + +</xsl:stylesheet> + diff --git a/doc/intro.xml b/doc/intro.xml new file mode 100644 index 0000000..936cf59 --- /dev/null +++ b/doc/intro.xml @@ -0,0 +1,265 @@ +<?xml version='1.0' ?> +<!DOCTYPE book PUBLIC "-//OASIS//DTD DocBook XML V4.2//EN" + "http://www.oasis-open.org/docbook/xml/4.2/docbookx.dtd" [ +<!ENTITY % myents SYSTEM "entities.inc"> +%myents; +]> + +<chapter id="introduction"> + <title>Introduction</title> + + <sect1 id="purpose"> + <title>Purpose</title> + <para>&clsql; is a Common Lisp interface to <glossterm + linkend="gloss-sql">SQL</glossterm> databases. A number of Common + Lisp implementations and SQL databases are supported. The general + structure of &clsql; is based on the &commonsql; package by + LispWorks Ltd. + </para> + </sect1> + + <sect1 id="history"> + <title>History</title> + <para> + The &clsql; project was started by Kevin M. Rosenberg in 2001 to + support SQL access on multiple Common Lisp implementations using + the &uffi; library. The initial code was based substantially on + Pierre R. Mai's excellent &maisql; package. In late 2003, the + &usql; library was orphaned by its author, onShore Development, + Inc. In April 2004, Marcus Pearce ported the &usql; library to + &clsql;. The &usql; library provides a &commonsql;-compatible + API for &clsql;. + </para> + + <para>The main changes from &maisql; and &usql; are: + <itemizedlist> + <listitem> + <para>Port from the &cmucl; FFI to &uffi; which provide + compatibility with the major Common Lisp + implementations.</para> + </listitem> + <listitem> + <para>Optimized loading of integer and floating-point fields.</para> + </listitem> + <listitem> + <para>Additional database backends: &odbc;, &aodbc;, &sqlite; + and &sqlite3;.</para> + </listitem> + <listitem> + <para>A compatibility layer for &cmucl; specific code.</para> + </listitem> + <listitem> + <para>Much improved robustness for the &mysql; back-end + along with version 4 client library support.</para> + </listitem> + <listitem> + <para>Improved library loading and installation documentation.</para> + </listitem> + <listitem> + <para>Improved packages and symbol export.</para> + </listitem> + <listitem> + <para>Pooled connections.</para> + </listitem> + <listitem> + <para>Integrated transaction support for the classic + &maisql; iteration macros.</para> + </listitem> + </itemizedlist> + </para> + </sect1> + + <sect1 id="prerequisites"> + <title>Prerequisites</title> + + <sect2> + <title>&asdf;</title> + <para> + &clsql; uses &asdf; to compile and load its components. + &asdf; is included in the <ulink + url="http://cclan.sourceforge.net"><citetitle>&cclan;</citetitle></ulink> + collection. + </para> + </sect2> + + <sect2> + <title>&uffi;</title> + <para> + &clsql; uses <ulink + url="http://uffi.kpe.io/"><citetitle>&uffi;</citetitle></ulink> + as a <emphasis>Foreign Function Interface</emphasis> + (<glossterm linkend="gloss-ffi">FFI</glossterm>) to support + multiple &cl; implementations. + </para> + </sect2> + + <sect2> + <title>&md5;</title> + <para>&clsql;'s postgresql-socket interface uses Pierre Mai's + <ulink url="http://files.kpe.io/md5/">md5</ulink> + module. + </para> + </sect2> + <sect2> + <title>Supported Common Lisp Implementation</title> + <para> + The implementations that support &clsql; is governed by the supported + implementations of &uffi;. The following implementations are supported: + </para> + <itemizedlist mark="opencircle"> + <listitem><para>&acl; v6.2 through 8.0 on Debian Linux x86 & + x86_64 & PowerPC, FreeBSD 4.5, and Microsoft Windows + XP.</para></listitem> + <listitem><para>&lw; v4.3 and v4.4 on Debian Linux and Microsoft + Windows XP.</para></listitem> + <listitem><para>&cmucl; 18e on Debian Linux, FreeBSD 4.5, and + Solaris 2.8. 19c on Debian Linux.</para></listitem> + <listitem><para>&sbcl; 0.8.4 through 0.9.16 on Debian + Linux.</para></listitem> + <listitem><para>&scl; 1.1.1 on Debian Linux.</para></listitem> + <listitem><para>&openmcl; 0.14 PowerPC and 1.0pre AMD64 on Debian Linux .</para></listitem> + </itemizedlist> + </sect2> + + <sect2> + <title>Supported &sql; Implementation</title> + <para> + &clsql; supports the following databases: + </para> + <itemizedlist mark="opencircle"> + <listitem><para>&mysql; (tested v3.23.51, v4.0.18, 5.0.24).</para></listitem> + <listitem><para>&postgresql; (tested with v7.4 and 8.0 with both direct API and TCP + socket connections.</para></listitem> + <listitem><para>&sqlite;.</para></listitem> + <listitem><para>&sqlite3;.</para></listitem> + <listitem><para>Direct &odbc; interface.</para></listitem> + <listitem><para>&oracle; OCI.</para></listitem> + <listitem><para>Allegro's DB interface (&aodbc;).</para></listitem> + </itemizedlist> + </sect2> + + </sect1> + + <sect1 id="installation"> + <title>Installation</title> + + <sect2> + <title>Ensure &asdf; is loaded</title> + <para> + Simply load the file <filename>asdf.lisp</filename>. + <screen> +(load "asdf.lisp") + </screen> + </para> + </sect2> + + <sect2> + <title>Build &c; helper libraries</title> + <para>&clsql; uses functions that require 64-bit integer + parameters and return values. The &ffi; in most &clsql; + implementations do not support 64-bit integers. Thus, C helper + libraries are required to break these 64-bit integers into two compatible + 32-bit integers. The helper libraries reside in the directories + <filename>uffi</filename> and <filename>db-mysql</filename>. + </para> + + <sect3> + <title>&mswindows;</title> + <para> + Files named <filename>Makefile.msvc</filename> are supplied + for building the libraries under Microsoft Windows. Since + &mswindows; does not come with that compiler, compiled + <type>DLL</type> and <type>LIB</type> library files are + supplied with &clsql;. + </para> + </sect3> + + <sect3> + <title>&unix;</title> + <para> + Files named <filename>Makefile</filename> are supplied for + building the libraries under &unix;. Loading the + <filename>.asd</filename> files automatically invokes + <application>make</application> when necessary. So, manual + building of the helper libraries is not necessary on most + &unix; systems. However, the location of the &mysql; library + files and include files may need to adjusted in + <filename>db-mysql/Makefile</filename> on non-Debian + systems. + </para> + </sect3> + + </sect2> + + <sect2> + <title>Add &uffi; path</title> + <para> + Unzip or untar the &uffi; distribution which creates a directory + for the &uffi; files. Add that directory to &asdf;'s <varname>asdf:*central-registry*</varname>. + You can do that by pushing the pathname of the directory onto this variable. + The following example code assumes the &uffi; files reside in the + <filename>/usr/share/lisp/uffi/</filename> + directory. + <screen> +(push #P"/usr/share/lisp/uffi/" asdf:*central-registry*) + </screen> + </para> + </sect2> + <sect2> + <title>Add &md5; path</title> + <para> + If you plan to use the clsql-postgresql-socket interface, you + must load the md5 module. Unzip or untar the cl-md5 + distribution, which creates a directory for the cl-md5 files. + Add that directory to &asdf;'s + <varname>asdf:*central-registry*</varname>. You can do that by + pushing the pathname of the directory onto this variable. The + following example code assumes the cl-md5 files reside in the + <filename>/usr/share/lisp/cl-md5/</filename> directory. + <screen> +(push #P"/usr/share/lisp/cl-md5/" asdf:*central-registry*) + </screen> + </para> + </sect2> + + <sect2> + <title>Add &clsql; path and load module</title> + <para> + Unzip or untar the &clsql; distribution which creates a + directory for the &clsql; files. Add that directory to &asdf;'s + <varname>asdf:*central-registry*</varname>. You can do that by + pushing the pathname of the directory onto this variable. The + following example code assumes the &clsql; files reside in the + <filename>/usr/share/lisp/clsql/</filename> directory. You need + to load the <symbol>clsql</symbol> system. + + <screen> +(push #P"/usr/share/lisp/clsql/" asdf:*central-registry*) +(asdf:operate 'asdf:load-op 'clsql) ; main CLSQL package + </screen> + </para> + </sect2> + + <sect2> + <title>Run test suite (optional)</title> + <para> + The test suite can be executed using the &asdf; + <symbol>test-op</symbol> operator. If &clsql; has not been + loaded with <symbol>asdf:load-op</symbol>, the + <symbol>asdf:test-op</symbol> operator will automatically load + &clsql;. A configuration file named + <filename>.clsql-test.config</filename> must be created in + your home directory. There are instructures on the format of + that file in the <filename>tests/README</filename>. After + creating <filename>.clsql-test.config</filename>, you can run + the test suite with &asdf;: + <screen> + (asdf:operate 'asdf:test-op 'clsql) + </screen> + </para> + </sect2> + + </sect1> + +</chapter> + diff --git a/doc/mysql-macosx-notes.txt b/doc/mysql-macosx-notes.txt new file mode 100644 index 0000000..9687f1d --- /dev/null +++ b/doc/mysql-macosx-notes.txt @@ -0,0 +1,60 @@ +Instructions: + +---------------- +1. Install MySQL from Fink, not from mysql.com + +It is sufficient to install the binaries from Fink. +CLSQL requires the MySQL library libmysqlclient.dylib; this library +is not provided with the mysql binary install. +This library is in /sw/lib/mysql . However, it is actually called +libmysqlclient.14.0.0.dylib . +----------------- +2. After installing MySQL, do the following at the shell. +(Assuming that you do not want to have to load CLSQL as root user +every time you use it.) + +2a. Create a symbolic link from libmysqlclient.14.0.0.dylib to the +name libmysqlclient.dylib . +2b. Change ownership to yourself along the path /sw/lib/mysql/ +libmysqlclient.dylib . +----------------- +3. Either install CocoaMySQL or download the source of MySQL (e.g. +5.0) from mysql.com. + +CLSQL requires MySQL's header files. These files are not provided +with Fink's binary MySQL install. +In CocoaMySQL the headers are found at: /Applications/CocoaMySQL.app/ +Contents/Frameworks/SMySQL.framework/Versions/A/Headers +In MySQL 5.0 sources, the headers are found at: ~/Desktop/ +mysql-5.0.15/include + +3a. Copy the directory full of headers to /sw/include/mysql +3b. Make yourself the owner of these files. + +You may now dispose of CocoaMySQL or the MySQL sources, if you desire. +----------------- +4. In the CLSQL sources, modify db-mysql/makefile to read as follows: + +... CFLAGS="-I /sw/include/mysql" LDFLAGS=" -L/sw/lib/mysql/ ... + +----------------- +5. In Lisp, do the following: + +Assuming asdf and the CLSQL & UFFI sources are in the same directory; +substitute the appropriate path for ~ . +The code below is right out of the CLSQL docs, but note particularly +the commented expression. + +(load "~/asdf.lisp") + +(progn + (push "~/uffi-1.5.5/" asdf:*central-registry*) + (asdf:operate 'asdf:load-op :uffi) + (push "~/clsql-3.3.4/" asdf:*central-registry*) + (asdf:operate 'asdf:load-op :clsql)) + +(progn + (in-package :clsql) + (setf *default-database-type* :mysql) + (clsql:push-library-path "/sw/lib/mysql/") ; !! + (asdf:operate 'asdf:load-op 'clsql-mysql)) diff --git a/doc/preface.xml b/doc/preface.xml new file mode 100644 index 0000000..5e4aede --- /dev/null +++ b/doc/preface.xml @@ -0,0 +1,17 @@ +<?xml version='1.0' ?> +<!DOCTYPE book PUBLIC "-//OASIS//DTD DocBook XML V4.2//EN" + "http://www.oasis-open.org/docbook/xml/4.2/docbookx.dtd" [ +<!ENTITY % myents SYSTEM "entities.inc"> +%myents; +]> + +<preface id="preface"> + <title>Preface</title> + <para> + This guide provides reference to the features of &clsql;. The + first chapter provides an introduction to &clsql; and installation + instructions. The reference sections document all user accessible + symbols with examples of usage. There is a glossary of commonly + used terms with their definitions. + </para> +</preface> diff --git a/doc/ref-clsql-sys.xml b/doc/ref-clsql-sys.xml new file mode 100644 index 0000000..56d1615 --- /dev/null +++ b/doc/ref-clsql-sys.xml @@ -0,0 +1,103 @@ +<?xml version='1.0' ?> +<!DOCTYPE book PUBLIC "-//OASIS//DTD DocBook XML V4.2//EN" + "http://www.oasis-open.org/docbook/xml/4.2/docbookx.dtd" [ +<!ENTITY % myents SYSTEM "entities.inc"> +%myents; +]> + +<reference id="clsql-sys"> + <title><symbol>CLSQL-SYS</symbol></title> + <partintro> + <para>This part gives a reference to the symbols exported from + the package <symbol>CLSQL-SYS</symbol>, which are not exported + from <symbol>CLSQL</symbol> package.. These symbols are part of + the interface for database back-ends, but not part of the normal + user-interface of &clsql;.</para> + </partintro> + <refentry id="database-initialize-database-type"> + <refnamediv> + <refname>DATABASE-INITIALIZE-DATABASE-TYPE</refname> + <refpurpose>Back-end part of <link + linkend="initialize-database-type"><function>initialize-database-type</function></link>.</refpurpose> + <refclass>Generic Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis><function>database-initialize-database-type</function> <replaceable>database-type</replaceable> => <returnvalue>result</returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>database-type</parameter></term> + <listitem> + <para>A keyword indicating the database type to + initialize.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><returnvalue>result</returnvalue></term> + <listitem> + <para>Either <symbol>t</symbol> if the initialization + succeeds or <symbol>nil</symbol> if it fails.</para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para>This generic function implements the main part of the + database type initialization performed by + <function>initialize-database-type</function>. After + <function>initialize-database-type</function> has checked + that the given database type has not been initialized + before, as indicated by + <symbol>*initialized-database-types*</symbol>, it will call + this function with the database type as it's sole + parameter. Database back-ends are required to define a + method on this generic function which is specialized via an + eql-specializer to the keyword representing their database + type.</para> + <para>Database back-ends shall indicate successful + initialization by returning <symbol>t</symbol> from their + method, and <symbol>nil</symbol> otherwise. Methods for + this generic function are allowed to signal errors of type + <errortype>clsql-error</errortype> or subtypes thereof. + They may also signal other types of conditions, if + appropriate, but have to document this.</para> + </refsect1> + <refsect1> + <title>Examples</title> + <para></para> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para>All necessary side effects to initialize the database + instance.</para> + </refsect1> + <refsect1> + <title>Affected By</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para>Conditions of type <errortype>clsql-error</errortype> + or other conditions may be signalled, depending on the + database back-end.</para> + </refsect1> + <refsect1> + <title>See Also</title> + <para> + <simplelist> + <member><link + linkend="initialize-database-type"><function>initialize-database-type</function></link></member> + <member><link linkend="initialized-database-types"><symbol>*initialized-database-types*</symbol></link></member> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Notes</title> + <para>None.</para> + </refsect1> + </refentry> + </reference> diff --git a/doc/ref-clsql.xml b/doc/ref-clsql.xml new file mode 100644 index 0000000..b44ac4d --- /dev/null +++ b/doc/ref-clsql.xml @@ -0,0 +1,2416 @@ +<?xml version='1.0' ?> +<!DOCTYPE book PUBLIC "-//OASIS//DTD DocBook XML V4.2//EN" + "http://www.oasis-open.org/docbook/xml/4.2/docbookx.dtd" [ +<!ENTITY % myents SYSTEM "entities.inc"> +%myents; +]> + +<reference id="clsql"> + <title><symbol>CLSQL</symbol></title> + <partintro> + <para>This part gives a reference to the symbols exported from the + <symbol>CLSQL</symbol> package. These symbols constitute + the normal user-interface of &clsql;. Currently, the symbols of + the &commonsql;-API are not documented here.</para> + </partintro> + <!-- Conditions --> + <refentry id="sql-condition"> + <refnamediv> + <refname>SQL-CONDITION</refname> + <refpurpose>the super-type of all + &clsql;-specific + conditions</refpurpose> + <refclass>Condition Type</refclass> + </refnamediv> + <refsect1> + <title>Class Precedence List</title> + <para> + <simplelist type="inline"> + <member><errortype>sql-condition</errortype></member> + <member><errortype>condition</errortype></member> + <member><errortype>t</errortype></member> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Description</title> + <para>This is the super-type of all + &clsql;-specific conditions + defined by &clsql;, or any of it's + database-specific interfaces. There are no defined + initialization arguments nor any accessors.</para> + </refsect1> + </refentry> + <refentry id="sql-error"> + <refnamediv> + <refname>SQL-ERROR</refname> + <refpurpose>the super-type of all + &clsql;-specific + errors</refpurpose> + <refclass>Condition Type</refclass> + </refnamediv> + <refsect1> + <title>Class Precedence List</title> + <para> + <simplelist type="inline"> + <member><errortype>sql-error</errortype></member> + <member><errortype>error</errortype></member> + <member><errortype>serious-condition</errortype></member> + <member><errortype>sql-condition</errortype></member> + <member><errortype>condition</errortype></member> + <member><errortype>t</errortype></member> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Description</title> + <para>This is the super-type of all + &clsql;-specific conditions that + represent errors, as defined by + &clsql;, or any of it's + database-specific interfaces. There are no defined + initialization arguments nor any accessors.</para> + </refsect1> + </refentry> + <refentry id="sql-warning"> + <refnamediv> + <refname>SQL-WARNING</refname> + <refpurpose>the super-type of all + &clsql;-specific + warnings</refpurpose> + <refclass>Condition Type</refclass> + </refnamediv> + <refsect1> + <title>Class Precedence List</title> + <para> + <simplelist type="inline"> + <member><errortype>sql-warning</errortype></member> + <member><errortype>warning</errortype></member> + <member><errortype>sql-condition</errortype></member> + <member><errortype>condition</errortype></member> + <member><errortype>t</errortype></member> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Description</title> + <para>This is the super-type of all + &clsql;-specific conditions that + represent warnings, as defined by + &clsql;, or any of it's + database-specific interfaces. There are no defined + initialization arguments nor any accessors.</para> + </refsect1> + </refentry> + <!-- Specifc Conditions --> + <refentry id="sql-user-error"> + <refnamediv> + <refname>CLSQL-USER-ERROR</refname> + <refpurpose>condition representing errors because of invalid + parameters from the library user.</refpurpose> + <refclass>Condition Type</refclass> + </refnamediv> + <refsect1> + <title>Class Precedence List</title> + <para> + <simplelist type="inline"> + <member><errortype>sql-error</errortype></member> + <member><errortype>sql-condition</errortype></member> + <member><errortype>condition</errortype></member> + <member><errortype>t</errortype></member> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Description</title> + <para>This condition represents errors that occur because the + user supplies invalid data to &clsql;. This includes errors such as + an invalid format connection specification or an error in the syntax + for the <function>LOOP</function> macro extensions.</para> + </refsect1> + </refentry> + <refentry id="sql-connection-error"> + <refnamediv> + <refname>SQL-CONNECTION-ERROR</refname> + <refpurpose>condition representing errors during + connection</refpurpose> + <refclass>Condition Type</refclass> + </refnamediv> + <refsect1> + <title>Class Precedence List</title> + <para> + <simplelist type="inline"> + <member><errortype>sql-connection-error</errortype></member> + <member><errortype>sql-database-error</errortype></member> + <member><errortype>sql-error</errortype></member> + <member><errortype>sql-condition</errortype></member> + <member><errortype>condition</errortype></member> + <member><errortype>t</errortype></member> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Description</title> + <para>This condition represents errors that occur while trying + to connect to a database. The following initialization + arguments and accessors exist:</para> + <segmentedlist> + <segtitle>Initarg</segtitle> + <segtitle>Accessor</segtitle> + <segtitle>Description</segtitle> + <seglistitem> + <seg><symbol>:database-type</symbol></seg> + <seg><function>sql-connection-error-database-type</function></seg> + <seg>Database type for the connection attempt</seg> + </seglistitem> + <seglistitem> + <seg><symbol>:connection-spec</symbol></seg> + <seg><function>sql-connection-error-connection-spec</function></seg> + <seg>The connection specification used in the + connection attempt.</seg> + </seglistitem> + <seglistitem> + <seg><symbol>:errno</symbol></seg> + <seg><function>sql-connection-error-errno</function></seg> + <seg>The numeric or symbolic error specification + returned by the database back-end. The values and + semantics of this are interface specific.</seg> + </seglistitem> + <seglistitem> + <seg><symbol>:error</symbol></seg> + <seg><function>sql-connection-error-error</function></seg> + <seg>A string describing the problem that occurred, + possibly one returned by the database back-end.</seg> + </seglistitem> + </segmentedlist> + </refsect1> + </refentry> + <refentry id="sql-database-error"> + <refnamediv> + <refname>SQL-DATABASE-ERROR</refname> + <refpurpose>condition representing errors during query or + command execution</refpurpose> + <refclass>Condition Type</refclass> + </refnamediv> + <refsect1> + <title>Class Precedence List</title> + <para> + <simplelist type="inline"> + <member><errortype>sql-database-error</errortype></member> + <member><errortype>sql-error</errortype></member> + <member><errortype>error</errortype></member> + <member><errortype>serious-condition</errortype></member> + <member><errortype>sql-condition</errortype></member> + <member><errortype>condition</errortype></member> + <member><errortype>t</errortype></member> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Description</title> + <para>This condition represents errors that occur while + executing SQL statements, either as part of query operations + or command execution, either explicitly or implicitly, as + caused e.g. by <function>with-transaction</function>. + The following initialization arguments and accessors exist:</para> + <segmentedlist> + <segtitle>Initarg</segtitle> + <segtitle>Accessor</segtitle> + <segtitle>Description</segtitle> + <seglistitem> + <seg><symbol>:database</symbol></seg> + <seg><function>sql-database-error-database</function></seg> + <seg>The database object that was involved in the + incident.</seg> + </seglistitem> + <seglistitem> + <seg><symbol>:expression</symbol></seg> + <seg><function>sql-database-error-expression</function></seg> + <seg>The SQL expression whose execution caused the error.</seg> + </seglistitem> + <seglistitem> + <seg><symbol>:errno</symbol></seg> + <seg><function>sql-database-error-errno</function></seg> + <seg>The numeric or symbolic error specification + returned by the database back-end. The values and + semantics of this are interface specific.</seg> + </seglistitem> + <seglistitem> + <seg><symbol>:error</symbol></seg> + <seg><function>sql-database-error-error</function></seg> + <seg>A string describing the problem that occurred, + possibly one returned by the database back-end.</seg> + </seglistitem> + </segmentedlist> + </refsect1> + </refentry> + + <!-- Database Types --> + <refentry id="default-database-type"> + <refnamediv> + <refname>*DEFAULT-DATABASE-TYPE*</refname> + <refpurpose>The default database type to use</refpurpose> + <refclass>Variable</refclass> + </refnamediv> + <refsect1> + <title>Value Type</title> + <para>Any keyword representing a valid database back-end of + &clsql;, or + <symbol>nil</symbol>.</para> + </refsect1> + <refsect1> + <title>Initial Value</title> + <para><symbol>nil</symbol></para> + </refsect1> + <refsect1> + <title>Description</title> + <para>The value of this variable is used in calls to + <function>initialize-database-type</function> and + <function>connect</function> as the default + value of the <parameter>database-type</parameter> + parameter.</para> + <caution> + <para>If the value of this variable is <symbol>nil</symbol>, + then all calls to + <function>initialize-database-type</function> or + <function>connect</function> will have to specify the + <parameter>database-type</parameter> to use, or a + general-purpose error will be signalled.</para> + </caution> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(setf *default-database-type* :mysql) +=> :mysql +(initialize-database-type) +=> t + </screen> + </refsect1> + <refsect1> + <title>Affected By</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>See Also</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>Notes</title> + <para>None.</para> + </refsect1> + </refentry> + <refentry id="initialized-database-types"> + <refnamediv> + <refname>*INITIALIZED-DATABASE-TYPES*</refname> + <refpurpose>List of all initialized database types</refpurpose> + <refclass>Variable</refclass> + </refnamediv> + <refsect1> + <title>Value Type</title> + <para>A list of all initialized database types, each of which + represented by it's corresponding keyword.</para> + </refsect1> + <refsect1> + <title>Initial Value</title> + <para><symbol>nil</symbol></para> + </refsect1> + <refsect1> + <title>Description</title> + <para>This variable is updated whenever + <function>initialize-database-type</function> is called for a + database type which hasn't already been initialized before, + as determined by this variable. In that case the keyword + representing the database type is pushed onto the list + stored in + <symbol>*INITIALIZED-DATABASE-TYPES*</symbol>.</para> + <caution> + <para>Attempts to modify the value of this variable will + result in undefined behaviour.</para> + </caution> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(setf *default-database-type* :mysql) +=> :mysql +(initialize-database-type) +=> t +*initialized-database-types* +=> (:MYSQL) + </screen> + </refsect1> + <refsect1> + <title>Affected By</title> + <para> + <simplelist> + <member><function>initialize-database-type</function></member> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>See Also</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>Notes</title> + <para>Direct access to this variable is primarily provided + because of compatibility with Harlequin's <application>Common + SQL</application>.</para> + </refsect1> + </refentry> + <refentry id="initialize-database-type"> + <refnamediv> + <refname>INITIALIZE-DATABASE-TYPE</refname> + <refpurpose>Initializes a database type</refpurpose> + <refclass>Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis><function>initialize-database-type</function> &key <replaceable>database-type</replaceable> => <returnvalue>result</returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>database-type</parameter></term> + <listitem> + <para>The database type to initialize, i.e. a keyword + symbol denoting a known database back-end. Defaults to + the value of + <symbol>*default-database-type*</symbol>.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><returnvalue>result</returnvalue></term> + <listitem> + <para>Either <symbol>nil</symbol> if the initialization + attempt fails, or <symbol>t</symbol> otherwise.</para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para>If the back-end specified by + <parameter>database-type</parameter> has not already been + initialized, as seen from + <symbol>*initialized-database-types*</symbol>, an attempt is + made to initialize the database. If this attempt succeeds, + or the back-end has already been initialized, the function + returns t, and places the keyword denoting the database type + onto the list stored in + <symbol>*initialized-database-types*</symbol>, if not + already present.</para> + <para>If initialization fails, the function returns + <symbol>nil</symbol>, and/or signals an error of type + <errortype>clsql-error</errortype>. The kind of action + taken depends on the back-end and the cause of the + problem.</para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +*initialized-database-types* +=> NIL +(setf *default-database-type* :mysql) +=> :MYSQL +(initialize-database-type) +>> Compiling LAMBDA (#:G897 #:G898 #:G901 #:G902): +>> Compiling Top-Level Form: +>> +=> T +*initialized-database-types* +=> (:MYSQL) +(initialize-database-type) +=> T +*initialized-database-types* +=> (:MYSQL) + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para>The database back-end corresponding to the database type + specified is initialized, unless it has already been + initialized. This can involve any number of other side + effects, as determined by the back-end implementation (like + e.g. loading of foreign code, calling of foreign code, + networking operations, etc.). If initialization is + attempted and succeeds, the + <parameter>database-type</parameter> is pushed onto the list + stored in + <symbol>*initialized-database-types*</symbol>.</para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para> + <simplelist> + <member><symbol>*default-database-type*</symbol></member> + <member><symbol>*initialized-database-types*</symbol></member> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para>If an error is encountered during the initialization + attempt, the back-end may signal errors of kind + <errortype>clsql-error</errortype>.</para> + </refsect1> + <refsect1> + <title>See Also</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>Notes</title> + <para>None.</para> + </refsect1> + </refentry> + <!-- Databases Connection and Disconnection --> + <refentry id="connect-if-exists"> + <refnamediv> + <refname>*CONNECT-IF-EXISTS*</refname> + <refpurpose>Default value for the + <parameter>if-exists</parameter> parameter of + <function>connect</function>.</refpurpose> + <refclass>Variable</refclass> + </refnamediv> + <refsect1> + <title>Value Type</title> + <para>A valid argument to the <parameter>if-exists</parameter> + parameter of <function>connect</function>, i.e. one of + <simplelist type="inline"> + <member><symbol>:new</symbol></member> + <member><symbol>:warn-new</symbol></member> + <member><symbol>:error</symbol></member> + <member><symbol>:warn-old</symbol></member> + <member><symbol>:old</symbol></member> + </simplelist>. + </para> + </refsect1> + <refsect1> + <title>Initial Value</title> + <para><symbol>:error</symbol></para> + </refsect1> + <refsect1> + <title>Description</title> + <para>The value of this variable is used in calls to + <function>connect</function> as the default + value of the <parameter>if-exists</parameter> + parameter. See <link + linkend="connect"><function>connect</function></link> for + the semantics of the valid values for this variable.</para> + </refsect1> + <refsect1> + <title>Examples</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>Affected By</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>See Also</title> + <para> + <simplelist> + <member><link + linkend="connect"><function>connect</function></link></member> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Notes</title> + <para>None.</para> + </refsect1> + </refentry> + <refentry id="connected-databases"> + <refnamediv> + <refname>CONNECTED-DATABASES</refname> + <refpurpose>Return the list of active database + objects.</refpurpose> + <refclass>Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis><function>connected-databases</function> => <returnvalue>databases</returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><returnvalue>databases</returnvalue></term> + <listitem> + <para>The list of active database objects.</para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para>This function returns the list of active database + objects, i.e. all those database objects created by calls to + <function>connect</function>, which have not been closed by + calling <function>disconnect</function> on them.</para> + <caution> + <para>The consequences of modifying the list returned by + <function>connected-databases</function> are + undefined.</para> + </caution> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(connected-databases) +=> NIL +(connect '(nil "template1" "dent" nil) :database-type :postgresql) +=> #<CLSQL-POSTGRESQL:POSTGRESQL-DATABASE {4830BC65}> +(connect '("dent" "newesim" "dent" "dent") :database-type :mysql) +=> #<CLSQL-MYSQL:MYSQL-DATABASE {4830C5AD}> +(connected-databases) +=> (#<CLSQL-MYSQL:MYSQL-DATABASE {4830C5AD}> + #<CLSQL-POSTGRESQL:POSTGRESQL-DATABASE {4830BC65}>) +(disconnect) +=> T +(connected-databases) +=> (#<CLSQL-POSTGRESQL:POSTGRESQL-DATABASE {4830BC65}>) +(disconnect) +=> T +(connected-databases) +=> NIL + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>Affected By</title> + <para> + <simplelist> + <member><function>connect</function></member> + <member><function>disconnect</function></member> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>See Also</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>Notes</title> + <para>None.</para> + </refsect1> + </refentry> + <refentry id="default-database"> + <refnamediv> + <refname>*DEFAULT-DATABASE*</refname> + <refpurpose>The default database object to use</refpurpose> + <refclass>Variable</refclass> + </refnamediv> + <refsect1> + <title>Value Type</title> + <para>Any object of type <type>database</type>, or nil to + indicate no default database.</para> + </refsect1> + <refsect1> + <title>Initial Value</title> + <para><symbol>nil</symbol></para> + </refsect1> + <refsect1> + <title>Description</title> + <para>Any function or macro in + &clsql; that operates on a + database uses the value of this variable as the default + value for it's <parameter>database</parameter> + parameter.</para> + <para>The value of this parameter is changed by calls to + <function>connect</function>, which sets + <symbol>*default-database*</symbol> to the database object + it returns. It is also changed by calls to + <function>disconnect</function>, when the database object + being disconnected is the same as the value of + <symbol>*default-database*</symbol>. In this case + <function>disconnect</function> sets + <symbol>*default-database*</symbol> to the first database + that remains in the list of active databases as returned by + <function>connected-databases</function>, or + <symbol>nil</symbol> if no further active databases + exist.</para> + <para>The user may change <symbol>*default-database*</symbol> + at any time to a valid value of his choice.</para> + <caution> + <para>If the value of <symbol>*default-database*</symbol> is + <symbol>nil</symbol>, then all calls to + &clsql; functions on databases + must provide a suitable <parameter>database</parameter> + parameter, or an error will be signalled.</para> + </caution> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(connected-databases) +=> NIL +(connect '("dent" "newesim" "dent" "dent") :database-type :mysql) +=> #<CLSQL-MYSQL:MYSQL-DATABASE {48385F55}> +(connect '(nil "template1" "dent" nil) :database-type :postgresql) +=> #<CLSQL-POSTGRESQL:POSTGRESQL-DATABASE {483868FD}> +(connect '("dent" "newesim" "dent" "dent") :database-type :mysql :if-exists :new) +=> #<CLSQL-MYSQL:MYSQL-DATABASE {48387265}> +*default-database* +=> #<CLSQL-MYSQL:MYSQL-DATABASE {48387265}> +(disconnect) +=> T +*default-database* +=> #<CLSQL-POSTGRESQL:POSTGRESQL-DATABASE {483868FD}> +(disconnect) +=> T +*default-database* +=> #<CLSQL-MYSQL:MYSQL-DATABASE {48385F55}> +(disconnect) +=> T +*default-database* +=> NIL +(connected-databases) +=> NIL + </screen> + </refsect1> + <refsect1> + <title>Affected By</title> + <para> + <simplelist> + <member><link linkend="connect"><function>connect</function></link></member> + <member><link linkend="disconnect"><function>disconnect</function></link></member> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>See Also</title> + <para> + <simplelist> + <member><link linkend="connected-databases"><function>connected-databases</function></link></member> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Notes</title> + <note> + <para>This variable is intended to facilitate working with + &clsql; in an interactive + fashion at the top-level loop, and because of this, + <function>connect</function> and + <function>disconnect</function> provide some fairly + complex behaviour to keep + <symbol>*default-database*</symbol> set to useful values. + Programmatic use of &clsql; + should never depend on the value of + <symbol>*default-database*</symbol> and should provide + correct database objects via the + <parameter>database</parameter> parameter to functions + called.</para> + </note> + </refsect1> + </refentry> + <!-- Classes --> + <refentry id="database"> + <refnamediv> + <refname>DATABASE</refname> + <refpurpose>The super-type of all + &clsql; databases</refpurpose> + <refclass>Class</refclass> + </refnamediv> + <refsect1> + <title>Class Precedence List</title> + <para> + <simplelist type="inline"> + <member><type>database</type></member> + <member><type>standard-object</type></member> + <member><type>t</type></member> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Description</title> + <para>This class is the superclass of all + &clsql; databases. The different + database back-ends derive subclasses of this class to + implement their databases. No instances of this class are + ever created by &clsql;.</para> + </refsect1> + </refentry> + <refentry id="closed-database"> + <refnamediv> + <refname>CLOSED-DATABASE</refname> + <refpurpose>The class representing all closed + &clsql; databases</refpurpose> + <refclass>Class</refclass> + </refnamediv> + <refsect1> + <title>Class Precedence List</title> + <para> + <simplelist type="inline"> + <member><type>closed-database</type></member> + <member><type>standard-object</type></member> + <member><type>t</type></member> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Description</title> + <para>&clsql; <type>database</type> + instances are changed to this class via + <function>change-class</function> after they are closed via + <function>disconnect</function>. All functions and generic + functions that take database objects as arguments will + signal errors of type + <errortype>clsql-closed-error</errortype> when they are + called on instances of <type>closed-database</type>, with + the exception of <function>database-name</function>, which + will continue to work as for instances of + <type>database</type>.</para> + </refsect1> + </refentry> + <!-- Functions --> + <refentry id="database-name"> + <refnamediv> + <refname>DATABASE-NAME</refname> + <refpurpose>Get the name of a database object</refpurpose> + <refclass>Generic Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis><function>database-name</function> <replaceable>database</replaceable> => <returnvalue>name</returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>database</parameter></term> + <listitem> + <para>A database object, either of type + <type>database</type> or of type + <type>closed-database</type>.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><returnvalue>name</returnvalue></term> + <listitem> + <para>A string describing the identity of the database + to which this database object is connected to.</para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para>This function returns the database name of the given + database. The database name is a string which somehow + describes the identity of the database to which this + database object is or has been connected. The database name + of a database object is determined at + <function>connect</function> time, when a call to + <function>database-name-from-spec</function> derives the + database name from the connection specification passed to + <function>connect</function> in the + <parameter>connection-spec</parameter> parameter.</para> + <para>The database name is used via + <function>find-database</function> in + <function>connect</function> to determine whether database + connections to the specified database exist already.</para> + <para>Usually the database name string will include + indications of the host, database name, user, or port that + where used during the connection attempt. The only + important thing is that this string shall try to identify + the database at the other end of the connection. Connection + specifications parts like passwords and credentials shall + not be used as part of the database name.</para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(database-name-from-spec '("dent" "newesim" "dent" "dent") :mysql) +=> "dent/newesim/dent" +(connect '("dent" "newesim" "dent" "dent") :database-type :mysql) +=> #<CLSQL-MYSQL:MYSQL-DATABASE {48391DCD}> +(database-name *default-database*) +=> "dent/newesim/dent" + +(database-name-from-spec '(nil "template1" "dent" nil) :postgresql) +=> "/template1/dent" +(connect '(nil "template1" "dent" nil) :database-type :postgresql) +=> #<CLSQL-POSTGRESQL:POSTGRESQL-DATABASE {48392D2D}> +(database-name *default-database*) +=> "/template1/dent" + +(database-name-from-spec '("www.pmsf.de" "template1" "dent" nil) :postgresql) +=> "www.pmsf.de/template1/dent" + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>Affected By</title> + <para> + <simplelist> + <member><link linkend="database-name-from-spec"><function>database-name-from-spec</function></link></member> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para>Will signal an error if the object passed as the + <parameter>database</parameter> parameter is neither of type + <type>database</type> nor of type + <type>closed-database</type>.</para> + </refsect1> + <refsect1> + <title>See Also</title> + <para> + <simplelist> + <member><link + linkend="connect"><function>connect</function></link></member> + <member><link + linkend="find-database"><function>find-database</function></link></member> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Notes</title> + <para>None.</para> + </refsect1> + </refentry> + <refentry id="find-database"> + <refnamediv> + <refname>FIND-DATABASE</refname> + <refpurpose>Locate a database object through it's + name.</refpurpose> + <refclass>Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis><function>find-database</function> <replaceable>database</replaceable> &optional <replaceable>errorp</replaceable> => <returnvalue>result</returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>database</parameter></term> + <listitem> + <para>A database object or a string, denoting a database + name.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>errorp</parameter></term> + <listitem> + <para>A generalized boolean. Defaults to + <symbol>t</symbol>.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><returnvalue>result</returnvalue></term> + <listitem> + <para>Either a database object, or, if + <parameter>errorp</parameter> is <symbol>nil</symbol>, + possibly <symbol>nil</symbol>.</para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para><function>find-database</function> locates an active + database object given the specification in + <parameter>database</parameter>. If + <parameter>database</parameter> is an object of type + <type>database</type>, <function>find-database</function> + returns this. Otherwise it will search the active databases + as indicated by the list returned by + <function>connected-databases</function> for a database + whose name (as returned by + <function>database-name</function> is equal as per + <function>string=</function> to the string passed as + <parameter>database</parameter>. If it succeeds, it returns + the first database found.</para> + <para>If it fails to find a matching database, it will signal + an error of type <errortype>clsql-error</errortype> if + <parameter>errorp</parameter> is true. If + <parameter>errorp</parameter> is <symbol>nil</symbol>, it + will return <symbol>nil</symbol> instead.</para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(database-name-from-spec '("dent" "newesim" "dent" "dent") :mysql) +=> "dent/newesim/dent" +(connect '("dent" "newesim" "dent" "dent") :database-type :mysql) +=> #<CLSQL-MYSQL:MYSQL-DATABASE {48391DCD}> +(database-name *default-database*) +=> "dent/newesim/dent" + +(database-name-from-spec '(nil "template1" "dent" nil) :postgresql) +=> "/template1/dent" +(connect '(nil "template1" "dent" nil) :database-type :postgresql) +=> #<CLSQL-POSTGRESQL:POSTGRESQL-DATABASE {48392D2D}> +(database-name *default-database*) +=> "/template1/dent" + +(database-name-from-spec '("www.pmsf.de" "template1" "dent" nil) :postgresql) +=> "www.pmsf.de/template1/dent" + +(find-database "dent/newesim/dent") +=> #<CLSQL-MYSQL:MYSQL-DATABASE {484E91C5}> +(find-database "/template1/dent") +=> #<CLSQL-POSTGRESQL:POSTGRESQL-DATABASE {48392D2D}> +(find-database "www.pmsf.de/template1/dent" nil) +=> NIL +(find-database **) +=> #<CLSQL-POSTGRESQL:POSTGRESQL-DATABASE {48392D2D}> + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>Affected By</title> + <para> + <simplelist> + <member><link linkend="connected-databases"><function>connected-databases</function></link></member> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para>Will signal an error of type + <errortype>clsql-error</errortype> if no matching database + can be found, and <parameter>errorp</parameter> is true. + Will signal an error if the value of + <parameter>database</parameter> is neither an object of type + <type>database</type> nor a string.</para> + </refsect1> + <refsect1> + <title>See Also</title> + <para> + <simplelist> + <member><link + linkend="database-name"><function>database-name</function></link></member> + <member><link + linkend="database-name-from-spec"><function>database-name-from-spec</function></link></member> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Notes</title> + <para>None.</para> + </refsect1> + </refentry> + + <refentry id="connect"> + <refnamediv> + <refname>CONNECT</refname> + <refpurpose>create a connection to a database</refpurpose> + <refclass>Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis><function>connect</function> <replaceable>connection-spec</replaceable> &key <replaceable>if-exists</replaceable> <replaceable>database-type</replaceable> <replaceable>pool</replaceable> => <returnvalue>database</returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>connection-spec</parameter></term> + <listitem> + <para>A connection specification</para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>if-exists</parameter></term> + <listitem> + <para>This indicates the action to take if a connection + to the same database exists already. See below for the + legal values and actions. It defaults to the value of + <symbol>*connect-if-exists*</symbol>.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>database-type</parameter></term> + <listitem> + <para>A database type specifier, i.e. a keyword. + This defaults to the value of + <symbol>*default-database-type*</symbol></para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>pool</parameter></term> + <listitem> + <para>A boolean flag. If &t;, acquire connection from a + pool of open connections. If the pool is empty, a new + connection is created. The default is &nil;. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><returnvalue>database</returnvalue></term> + <listitem> + <para>The database object representing the connection.</para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para>This function takes a connection specification and + a database type and creates a connection to the database + specified by those. The type and structure of the + connection specification depend on the database type.</para> + <para>The parameter <parameter>if-exists</parameter> specifies + what to do if a connection to the database specified exists + already, which is checked by calling + <function>find-database</function> on the database name + returned by <function>database-name-from-spec</function> + when called with the <parameter>connection-spec</parameter> + and <parameter>database-type</parameter> parameters. The + possible values of <parameter>if-exists</parameter> are: + <variablelist> + <varlistentry> + <term><symbol>:new</symbol></term> + <listitem> + <para>Go ahead and create a new connection.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><symbol>:warn-new</symbol></term> + <listitem> + <para>This is just like <symbol>:new</symbol>, but + also signals a warning of type + <errortype>clsql-exists-warning</errortype>, + indicating the old and newly created + databases.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><symbol>:error</symbol></term> + <listitem> + <para>This will cause <function>connect</function> to + signal a correctable error of type + <errortype>clsql-exists-error</errortype>. The + user may choose to proceed, either by indicating + that a new connection shall be created, via the + restart <symbol>create-new</symbol>, or by + indicating that the existing connection shall be + used, via the restart + <symbol>use-old</symbol>.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><symbol>:old</symbol></term> + <listitem> + <para>This will cause <function>connect</function> to + use an old connection if one exists.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><symbol>:warn-old</symbol></term> + <listitem> + <para>This is just like <symbol>:old</symbol>, but + also signals a warning of type + <errortype>clsql-exists-warning</errortype>, + indicating the old database used, via the slots + <symbol>old-db</symbol> and + <symbol>new-db</symbol></para> + </listitem> + </varlistentry> + </variablelist> + </para> + <para>The database name of the returned database object will + be the same under <function>string=</function> as that which + would be returned by a call to + <function>database-name-from-spec</function> with the given + <parameter>connection-spec</parameter> and + <parameter>database-type</parameter> parameters.</para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(database-name-from-spec '("dent" "newesim" "dent" "dent") :mysql) +=> "dent/newesim/dent" +(connect '("dent" "newesim" "dent" "dent") :database-type :mysql) +=> #<CLSQL-MYSQL:MYSQL-DATABASE {48036F6D}> +(database-name *) +=> "dent/newesim/dent" + +(connect '("dent" "newesim" "dent" "dent") :database-type :mysql) +>> In call to CONNECT: +>> There is an existing connection #<CLSQL-MYSQL:MYSQL-DATABASE {48036F6D}> to database dent/newesim/dent. +>> +>> Restarts: +>> 0: [CREATE-NEW] Create a new connection. +>> 1: [USE-OLD ] Use the existing connection. +>> 2: [ABORT ] Return to Top-Level. +>> +>> Debug (type H for help) +>> +>> (CONNECT ("dent" "newesim" "dent" "dent") :IF-EXISTS NIL :DATABASE-TYPE ...) +>> Source: +>> ; File: /prj/CLSQL/sql/sql.cl +>> (RESTART-CASE (ERROR 'CLSQL-EXISTS-ERROR :OLD-DB OLD-DB) +>> (CREATE-NEW NIL :REPORT "Create a new connection." +>> (SETQ RESULT #)) +>> (USE-OLD NIL :REPORT "Use the existing connection." +>> (SETQ RESULT OLD-DB))) +>> 0] 0 +=> #<CLSQL-MYSQL:MYSQL-DATABASE {480451F5}> + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para>A database connection is established, and the resultant + database object is registered, so as to appear in the list + returned by <function>connected-databases</function>.</para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para> + <simplelist> + <member><symbol>*default-database-type*</symbol></member> + <member><symbol>*connect-if-exists*</symbol></member> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para>If the connection specification is not syntactically or + semantically correct for the given database type, an error + of type <errortype>clsql-invalid-spec-error</errortype> is + signalled. If during the connection attempt an error is + detected (e.g. because of permission problems, network + trouble or any other cause), an error of type + <errortype>sql-connection-error</errortype> is + signalled.</para> + <para>If a connection to the database specified by + <parameter>connection-spec</parameter> exists already, + conditions are signalled according to the + <parameter>if-exists</parameter> parameter, as described + above.</para> + </refsect1> + <refsect1> + <title>See Also</title> + <para> + <simplelist> + <member><function>connected-databases</function></member> + <member><link linkend="disconnect"><function>disconnect</function></link></member> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Notes</title> + <para>None.</para> + </refsect1> + </refentry> + + <refentry id="disconnect"> + <refnamediv> + <refname>DISCONNECT</refname> + <refpurpose>close a database connection</refpurpose> + <refclass>Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis><function>disconnect</function> &key <replaceable>database</replaceable> <replaceable>pool</replaceable> => <returnvalue>t</returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>pool</parameter></term> + <listitem> + <para>A boolean flag indicating whether to put the database into a +pool of opened databases. If &t;, rather than terminating the database connection, the +connection is left open and the connection is placed into a pool of connections. Subsequent +calls to <link linkend="connect"><function>connect</function></link> can then reuse this connection. +The default is &nil;. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>database</parameter></term> + <listitem> + <para>The database to disconnect, which defaults to the + database indicated by + <symbol>*default-database*</symbol>.</para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para>This function takes a <type>database</type> object as + returned by <function>connect</function>, and closes the + connection. The class of the object passed is changed to + <type>closed-database</type> after the disconnection + succeeds, thereby preventing further use of the object as + an argument to &clsql; functions, + with the exception of <function>database-name</function>. + If the user does pass a closed database object to any other + &clsql; function, an error of type + <errortype>clsql-closed-error</errortype> is + signalled.</para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(disconnect :database (find-database "dent/newesim/dent")) +=> T + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para>The database connection is closed, and the database + object is removed from the list of connected databases as + returned by <function>connected-databases</function>.</para> + <para>The class of the database object is changed to + <type>closed-database</type>.</para> + <para>If the database object passed is the same under + <function>eq</function> as the value of + <symbol>*default-database*</symbol>, then + <symbol>*default-database*</symbol> is set to the first + remaining database from + <function>connected-databases</function> or to nil if no + further active database exists.</para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para> + <simplelist> + <member><symbol>*default-database*</symbol></member> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para>If during the disconnection attempt an error is + detected (e.g. because of network trouble or any other + cause), an error of type <errortype>clsql-error</errortype> + might be signalled.</para> + </refsect1> + <refsect1> + <title>See Also</title> + <para> + <simplelist> + <member><link linkend="connect"><function>connect</function></link></member> + <member><link linkend="connect"><function>closed-database</function></link></member> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Notes</title> + <para>None.</para> + </refsect1> + </refentry> + + <refentry id="disconnect-pooled"> + <refnamediv> + <refname>DISCONNECT-POOLED</refname> + <refpurpose>closes all pooled database connections</refpurpose> + <refclass>Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis><function>disconnect-pool</function> => <returnvalue>t</returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Description</title> + <para>This function disconnects all database connections + that have been placed into the pool. Connections are placed + in the pool by calling <link + linkend="disconnect"><function>disconnection</function></link>. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(disconnect-pool) +=> T + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para>Database connections will be closed and entries in the pool are removed. + </para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para> + <simplelist> + <member><function>disconnect</function></member> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para>If during the disconnection attempt an error is + detected (e.g. because of network trouble or any other + cause), an error of type <errortype>clsql-error</errortype> + might be signalled.</para> + </refsect1> + <refsect1> + <title>See Also</title> + <para> + <simplelist> + <member><link linkend="connect"><function>connect</function></link></member> + <member><link linkend="connect"><function>closed-database</function></link></member> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Notes</title> + <para>None.</para> + </refsect1> + </refentry> + + <refentry id="create_db"> + <refnamediv> + <refname>CREATE-DATABASE</refname> + <refpurpose>create a database</refpurpose> + <refclass>Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis><function>create-database</function> <replaceable>connection-spec</replaceable> &key <replaceable>database-type</replaceable> => <returnvalue>success</returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>connection-spec</parameter></term> + <listitem> + <para>A connection specification</para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>database-type</parameter></term> + <listitem> + <para>A database type specifier, i.e. a keyword. + This defaults to the value of + <symbol>*default-database-type*</symbol></para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>success</parameter></term> + <listitem> + <para>A boolean flag. If &t;, a new database was + successfully created. + </para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para>This function creates a database in the database system + specified by <parameter>database-type</parameter>. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(create-database '("localhost" "new" "dent" "dent") :database-type :mysql) +=> T + +(create-database '("localhost" "new" "dent" "badpasswd") :database-type :mysql) +=> +Error: While trying to access database localhost/new/dent + using database-type MYSQL: + Error database-create failed: mysqladmin: connect to server at 'localhost' failed +error: 'Access denied for user: 'root@localhost' (Using password: YES)' + has occurred. + [condition type: CLSQL-ACCESS-ERROR] + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para>A database will be created on the filesystem of the host.</para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para>An exception will be thrown if the database system does + not allow new databases to be created or if database creation + fails.</para> + </refsect1> + <refsect1> + <title>Notes</title> + <para>This function may invoke the operating systems + functions. Thus, some database systems may require the + administration functions to be available in the current + <symbol>PATH</symbol>. At this time, the + <symbol>:mysql</symbol> backend requires + <filename>mysqladmin</filename> and the + <symbol>:postgresql</symbol> backend requires + <filename>createdb</filename>.</para> + </refsect1> + </refentry> + + <refentry id="destroy_db"> + <refnamediv> + <refname>DESTROY-DATABASE</refname> + <refpurpose>destroys a database</refpurpose> + <refclass>Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis><function>destroy-database</function> <replaceable>connection-spec</replaceable> &key <replaceable>database-type</replaceable> => <returnvalue>success</returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>connection-spec</parameter></term> + <listitem> + <para>A connection specification</para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>database-type</parameter></term> + <listitem> + <para>A database type specifier, i.e. a keyword. + This defaults to the value of + <symbol>*default-database-type*</symbol></para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>success</parameter></term> + <listitem> + <para>A boolean flag. If &t;, the database was + successfully destroyed. + </para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para>This function destroy a database in the database system + specified by <parameter>database-type</parameter>. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(destroy-database '("localhost" "new" "dent" "dent") :database-type :postgresql) +=> T + +(destroy-database '("localhost" "new" "dent" "dent") :database-type :postgresql) +=> +Error: While trying to access database localhost/test2/root + using database-type POSTGRESQL: + Error database-destroy failed: dropdb: database removal failed: ERROR: database "test2" does not exist + has occurred. + [condition type: CLSQL-ACCESS-ERROR] + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para>A database will be removed from the filesystem of the host.</para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para>An exception will be thrown if the database system does not + allow databases to be removed, the database does not exist, or + if database removal fails.</para> + </refsect1> + <refsect1> + <title>Notes</title> + <para>This function may invoke the operating systems + functions. Thus, some database systems may require the + administration functions to be available in the current + <symbol>PATH</symbol>. At this time, the + <symbol>:mysql</symbol> backend requires + <filename>mysqladmin</filename> and the + <symbol>:postgresql</symbol> backend requires + <filename>dropdb</filename>.</para> + </refsect1> + </refentry> + + <refentry id="probe_db"> + <refnamediv> + <refname>PROBE-DATABASE</refname> + <refpurpose>tests for existence of a database</refpurpose> + <refclass>Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis><function>probe-database</function> <replaceable>connection-spec</replaceable> &key <replaceable>database-type</replaceable> => <returnvalue>success</returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>connection-spec</parameter></term> + <listitem> + <para>A connection specification</para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>database-type</parameter></term> + <listitem> + <para>A database type specifier, i.e. a keyword. + This defaults to the value of + <symbol>*default-database-type*</symbol></para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>success</parameter></term> + <listitem> + <para>A boolean flag. If &t;, the database exists + in the database system. + </para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para>This function tests for the existence of a database in + the database system specified by + <parameter>database-type</parameter>. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(probe-database '("localhost" "new" "dent" "dent") :database-type :postgresql) +=> T + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para>None</para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para>An exception maybe thrown if the database system does + not receive administrator-level authentication since function + may need to read the administrative database of the database + system.</para> + </refsect1> + <refsect1> + <title>Notes</title> + <para>None.</para> + </refsect1> + </refentry> + + <refentry id="database-name-from-spec"> + <refnamediv> + <refname>DATABASE-NAME-FROM-SPEC</refname> + <refpurpose>Return the database name string corresponding to + the given connection specification.</refpurpose> + <refclass>Generic Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis> + <function>database-name-from-spec</function> <replaceable>connection-spec</replaceable> <replaceable>database-type</replaceable> => <returnvalue>name</returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>connection-spec</parameter></term> + <listitem> + <para>A connection specification, whose structure and + interpretation are dependent on the + <parameter>database-type</parameter>.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>database-type</parameter></term> + <listitem> + <para>A database type specifier, i.e. a keyword.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><returnvalue>name</returnvalue></term> + <listitem> + <para>A string denoting a database name.</para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para>This generic function takes a connection specification + and a database type and returns the database name of the + database object that would be created had + <function>connect</function> been called with the given + connection specification and database types.</para> + <para>This function is useful in determining a database name + from the connection specification, since the way the + connection specification is converted into a database name + is dependent on the database type.</para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(database-name-from-spec '("dent" "newesim" "dent" "dent") :mysql) +=> "dent/newesim/dent" +(connect '("dent" "newesim" "dent" "dent") :database-type :mysql) +=> #<CLSQL-MYSQL:MYSQL-DATABASE {48391DCD}> +(database-name *default-database*) +=> "dent/newesim/dent" + +(database-name-from-spec '(nil "template1" "dent" nil) :postgresql) +=> "/template1/dent" +(connect '(nil "template1" "dent" nil) :database-type :postgresql) +=> #<CLSQL-POSTGRESQL:POSTGRESQL-DATABASE {48392D2D}> +(database-name *default-database*) +=> "/template1/dent" + +(database-name-from-spec '("www.pmsf.de" "template1" "dent" nil) :postgresql) +=> "www.pmsf.de/template1/dent" + +(find-database "dent/newesim/dent") +=> #<CLSQL-MYSQL:MYSQL-DATABASE {484E91C5}> +(find-database "/template1/dent") +=> #<CLSQL-POSTGRESQL:POSTGRESQL-DATABASE {48392D2D}> +(find-database "www.pmsf.de/template1/dent" nil) +=> NIL +(find-database **) +=> #<CLSQL-POSTGRESQL:POSTGRESQL-DATABASE {48392D2D}> + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para>If the value of <parameter>connection-spec</parameter> + is not a valid connection specification for the given + database type, an error of type + <errortype>clsql-invalid-spec-error</errortype> might be + signalled.</para> + </refsect1> + <refsect1> + <title>See Also</title> + <para> + <simplelist> + <member><link linkend="connect"><function>connect</function></link></member> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Notes</title> + <para>None.</para> + </refsect1> + </refentry> + <!-- Querying Operations --> + <refentry id="execute-command"> + <refnamediv> + <refname>EXECUTE-COMMAND</refname> + <refpurpose>Execute an SQL command which returns no + values.</refpurpose> + <refclass>Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis><function>execute-command</function> <replaceable>sql-expression</replaceable> &key <replaceable>database</replaceable> => <returnvalue>t</returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>sql-expression</parameter></term> + <listitem> + <para>An <glossterm linkend="gloss-sql-expression">sql + expression</glossterm> that represents an SQL + statement which will return no values.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>database</parameter></term> + <listitem> + <para>A + <glossterm linkend="gloss-database-object">database + object</glossterm>. This will default to the value + of <symbol>*default-database*</symbol>.</para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para>This will execute the command given by + <parameter>sql-expression</parameter> in the + <parameter>database</parameter> specified. If the execution + succeeds it will return <symbol>t</symbol>, otherwise an + error of type <errortype>sql-database-error</errortype> will + be signalled.</para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(execute-command "create table eventlog (time char(30),event char(70))") +=> T + +(execute-command "create table eventlog (time char(30),event char(70))") +>> +>> While accessing database #<CLSQL-POSTGRESQL:POSTGRESQL-DATABASE {480B2B6D}> +>> with expression "create table eventlog (time char(30),event char(70))": +>> Error NIL: ERROR: amcreate: eventlog relation already exists +>> has occurred. +>> +>> Restarts: +>> 0: [ABORT] Return to Top-Level. +>> +>> Debug (type H for help) +>> +>> (CLSQL-POSTGRESQL::|(PCL::FAST-METHOD DATABASE-EXECUTE-COMMAND (T POSTGRESQL-DATABASE))| +>> #<unused-arg> +>> #<unused-arg> +>> #<unavailable-arg> +>> #<unavailable-arg>) +>> Source: (ERROR 'SQL-DATABASE-ERROR :DATABASE DATABASE :EXPRESSION ...) +>> 0] 0 + +(execute-command "drop table eventlog") +=> T + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para>Whatever effects the execution of the SQL statement has + on the underlying database, if any.</para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para>If the execution of the SQL statement leads to any + errors, an error of type + <errortype>sql-database-error</errortype> is signalled.</para> + </refsect1> + <refsect1> + <title>See Also</title> + <para> + <simplelist> + <member><link linkend="query"><function>query</function></link></member> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Notes</title> + <para>None.</para> + </refsect1> + </refentry> + <refentry id="query"> + <refnamediv> + <refname>QUERY</refname> + <refpurpose>Execute an SQL query and return the tuples as a + list</refpurpose> + <refclass>Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis><function>query</function> <replaceable>query-expression</replaceable> &key <replaceable>database</replaceable> <replaceable>result-types</replaceable> <replaceable>field-names</replaceable> => <returnvalue>result</returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>query-expression</parameter></term> + <listitem> + <para>An <glossterm linkend="gloss-sql-expression">sql + expression</glossterm> that represents an SQL + query which is expected to return a (possibly empty) + result set.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>database</parameter></term> + <listitem> + <para>A + <glossterm linkend="gloss-database-object">database + object</glossterm>. This will default to the value + of <symbol>*default-database*</symbol>.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>result-types</parameter></term> + <listitem> + <para>A + <glossterm linkend="gloss-field-types">field type + specifier</glossterm>. The default is &nil;. + </para> + <para> + The purpose of this argument is cause &clsql; to + import SQL numeric fields into numeric Lisp objects + rather than strings. This reduces the cost of + allocating a temporary string and the &clsql; users' + inconvenience of converting number strings into number + objects. + </para> + <para> + A value of <symbol>:auto</symbol> causes &clsql; + to automatically convert SQL fields into a + numeric format where applicable. The default value of + &nil; causes all fields to be returned as strings + regardless of the SQL type. Otherwise a list is expected + which has a element for each field that specifies the + conversion. If the list is shorter than the number + of fields, the a value of <symbol>t</symbol> is + assumed for the field. If the list is longer than + the number of fields, the extra elements are + ignored. + <simplelist type="vert"> + <member><symbol>:int</symbol> Field is imported as a + signed integer, from 8-bits to 64-bits depending + upon the field type. + </member> + <member><symbol>:double</symbol> Field is imported as a + double-float number. + </member> + <member><symbol>t</symbol> Field is imported as a + string. + </member> + </simplelist> + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>field-names</parameter></term> + <listitem> + <para> + A boolean with a default value of &t;. When &t;, this + function results a second value of a list of field + names. When &nil;, this function only returns one value + - the list of rows. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><returnvalue>result</returnvalue></term> + <listitem> + <para>A list representing the result set obtained. For + each tuple in the result set, there is an element in + this list, which is itself a list of all the attribute + values in the tuple.</para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para>This will execute the query given by + <parameter>query-expression</parameter> in the + <parameter>database</parameter> specified. If the execution + succeeds it will return the result set returned by the + database, otherwise an error of type + <errortype>sql-database-error</errortype> will + be signalled.</para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(execute-command "create table simple (name char(50), salary numeric(10,2))") +=> T +(execute-command "insert into simple values ('Mai, Pierre',10000)") +=> T +(execute-command "insert into simple values ('Hacker, Random J.',8000.50)") +=> T +(query "select * from simple") +=> (("Mai, Pierre" "10000.00") ("Hacker, Random J." "8000.50")) +(query "select salary from simple") +=> (("10000.00") ("8000.50")) +(query "select salary from simple where salary > 10000") +=> NIL +(query "select salary,name from simple where salary > 10000") +=> NIL +(query "select salary,name from simple where salary > 9000") +=> (("10000.00" "Mai, Pierre")) +(query "select salary,name from simple where salary > 8000") +=> (("10000.00" "Mai, Pierre") ("8000.50" "Hacker, Random J.")) + +;; MySQL-specific: +(query "show tables") +=> (("demo") ("log") ("newlog") ("simple") ("spacetrial")) + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para>Whatever effects the execution of the SQL query has + on the underlying database, if any.</para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para>If the execution of the SQL query leads to any + errors, an error of type + <errortype>sql-database-error</errortype> is signalled.</para> + </refsect1> + <refsect1> + <title>See Also</title> + <para> + <simplelist> + <member><link linkend="execute-command"><function>execute-command</function></link></member> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Notes</title> + <para>None.</para> + </refsect1> + </refentry> + <!-- Iteration --> + <refentry id="map-query"> + <refnamediv> + <refname>MAP-QUERY</refname> + <refpurpose>Map a function over all the tuples from a + query</refpurpose> + <refclass>Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis><function>map-query</function> <replaceable>output-type-spec</replaceable> <replaceable>function</replaceable> <replaceable>query-expression</replaceable> &key <replaceable>database</replaceable> <replaceable>result-types</replaceable> => <returnvalue>result</returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>output-type-spec</parameter></term> + <listitem> + <para>A sequence type specifier or <symbol>nil</symbol>.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>function</parameter></term> + <listitem> + <para>A function designator. + <parameter>function</parameter> takes a single argument which + is the atom value for a query single with a single column + or is a list of values for a multi-column query.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>query-expression</parameter></term> + <listitem> + <para>An <glossterm linkend="gloss-sql-expression">sql + expression</glossterm> that represents an SQL + query which is expected to return a (possibly empty) + result set.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>database</parameter></term> + <listitem> + <para>A + <glossterm linkend="gloss-database-object">database + object</glossterm>. This will default to the value + of <symbol>*default-database*</symbol>.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>result-types</parameter></term> + <listitem> + <para> + A <glossterm linkend="gloss-field-types">field type specifier</glossterm>. + The default is &nil;. See <link + linkend="query"><function>query</function></link> + for the semantics of this argument. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><returnvalue>result</returnvalue></term> + <listitem> + <para>If <parameter>output-type-spec</parameter> is a + type specifier other than <symbol>nil</symbol>, then a + sequence of the type it denotes. Otherwise + <symbol>nil</symbol> is returned.</para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para>Applies <parameter>function</parameter> to the + successive tuples in the result set returned + by executing the SQL + <parameter>query-expression</parameter>. If the + <parameter>output-type-spec</parameter> is + <symbol>nil</symbol>, then the result of each application + of <parameter>function</parameter> is discarded, and + <function>map-query</function> returns + <symbol>nil</symbol>. Otherwise the result of each + successive application of <parameter>function</parameter> is + collected in a sequence of type + <parameter>output-type-spec</parameter>, where the jths + element is the result of applying + <parameter>function</parameter> to the attributes of the + jths tuple in the result set. The collected sequence is the + result of the call to <function>map-query</function>. + </para> + <para>If the <parameter>output-type-spec</parameter> is a + subtype of <type>list</type>, the result will be a + <type>list</type>.</para> + <para>If the <parameter>result-type</parameter> is a subtype + of <type>vector</type>, then if the implementation can + determine the element type specified for the + <parameter>result-type</parameter>, the element type of the + resulting array is the result of + <emphasis>upgrading</emphasis> that element type; or, if the + implementation can determine that the element type is + unspecified (or <symbol>*</symbol>), the element type of the + resulting array is <type>t</type>; otherwise, an error is + signaled.</para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(map-query 'list #'(lambda (tuple) + (multiple-value-bind (salary name) tuple + (declare (ignorable name)) + (read-from-string salary))) + "select salary,name from simple where salary > 8000") +=> (10000.0 8000.5) + +(map-query '(vector double-float) + #'(lambda (tuple) + (multiple-value-bind (salary name) tuple + (declare (ignorable name)) + (let ((*read-default-float-format* 'double-float)) + (coerce (read-from-string salary) 'double-float)) + "select salary,name from simple where salary > 8000"))) +=> #(10000.0d0 8000.5d0) +(type-of *) +=> (SIMPLE-ARRAY DOUBLE-FLOAT (2)) + +(let (list) + (values (map-query nil #'(lambda (tuple) + (multiple-value-bind (salary name) tuple + (push (cons name (read-from-string salary)) list)) + "select salary,name from simple where salary > 8000") + list)) +=> NIL +=> (("Hacker, Random J." . 8000.5) ("Mai, Pierre" . 10000.0)) + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para>Whatever effects the execution of the SQL query has + on the underlying database, if any.</para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para>If the execution of the SQL query leads to any + errors, an error of type + <errortype>sql-database-error</errortype> is signalled.</para> + <para>An error of type <errortype>type-error</errortype> must + be signaled if the <parameter>output-type-spec</parameter> is + not a recognizable subtype of <type>list</type>, not a + recognizable subtype of <type>vector</type>, and not + <symbol>nil</symbol>.</para> + <para>An error of type <errortype>type-error</errortype> + should be signaled if + <parameter>output-type-spec</parameter> specifies the number + of elements and the size of the result set is different from + that number.</para> + </refsect1> + <refsect1> + <title>See Also</title> + <para> + <simplelist> + <member><link linkend="query"><function>query</function></link></member> + <member><link linkend="do-query"><function>do-query</function></link></member> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Notes</title> + <para>None.</para> + </refsect1> + </refentry> + <refentry id="do-query"> + <refnamediv> + <refname>DO-QUERY</refname> + <refpurpose>Iterate over all the tuples of a + query</refpurpose> + <refclass>Macro</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis><function>do-query</function> ((&rest <replaceable>args</replaceable>) <replaceable>query-expression</replaceable> &key <replaceable>database</replaceable> <replaceable>result-types</replaceable>) &body <replaceable>body</replaceable> => <returnvalue>nil</returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>args</parameter></term> + <listitem> + <para>A list of variable names.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>query-expression</parameter></term> + <listitem> + <para>An <glossterm linkend="gloss-sql-expression">sql + expression</glossterm> that represents an SQL + query which is expected to return a (possibly empty) + result set, where each tuple has as many attributes as + <parameter>function</parameter> takes arguments.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>database</parameter></term> + <listitem> + <para>A + <glossterm linkend="gloss-database-object">database + object</glossterm>. This will default to + <symbol>*default-database*</symbol>.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>result-types</parameter></term> + <listitem> + <para> + A <glossterm linkend="gloss-field-types">field type specifier</glossterm>. + The default is &nil;. See <link + linkend="query"><function>query</function></link> + for the semantics of this argument. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>body</parameter></term> + <listitem> + <para>A body of Lisp code, like in a + <function>destructuring-bind</function> form.</para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para>Executes the <parameter>body</parameter> of code + repeatedly with the variable names in + <parameter>args</parameter> bound to the attributes of each + tuple in the result set returned by executing the SQL + <parameter>query-expression</parameter> on the + <parameter>database</parameter> specified.</para> + <para>The body of code is executed in a block named + <symbol>nil</symbol> which may be returned from prematurely + via <function>return</function> or + <function>return-from</function>. In this case the result + of evaluating the <function>do-query</function> form will be + the one supplied to <function>return</function> or + <function>return-from</function>. Otherwise the result will + be <symbol>nil</symbol>.</para> + <para>The body of code appears also is if wrapped in a + <function>destructuring-bind</function> form, thus allowing + declarations at the start of the body, especially those + pertaining to the bindings of the variables named in + <parameter>args</parameter>.</para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(do-query ((salary name) "select salary,name from simple") + (format t "~30A gets $~2,5$~%" name (read-from-string salary))) +>> Mai, Pierre gets $10000.00 +>> Hacker, Random J. gets $08000.50 +=> NIL + +(do-query ((salary name) "select salary,name from simple") + (return (cons salary name))) +=> ("10000.00" . "Mai, Pierre") + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para>Whatever effects the execution of the SQL query has + on the underlying database, if any.</para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para>If the execution of the SQL query leads to any + errors, an error of type + <errortype>sql-database-error</errortype> is signalled.</para> + <para>If the number of variable names in + <parameter>args</parameter> and the number of attributes in + the tuples in the result set don't match up, an error is + signalled.</para> + </refsect1> + <refsect1> + <title>See Also</title> + <para> + <simplelist> + <member><link linkend="query"><function>query</function></link></member> + <member><link linkend="map-query"><function>map-query</function></link></member> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Notes</title> + <para>None.</para> + </refsect1> + </refentry> + <refentry id="loop-tuples"> + <refnamediv> + <refname>LOOP-FOR-AS-TUPLES</refname> + <refpurpose>Iterate over all the tuples of a + query via a loop clause</refpurpose> + <refclass>Loop Clause</refclass> + </refnamediv> + <refsect1> + <title>Compatibility</title> + <caution><para><function>loop-for-as-tuples</function> only works with &cmucl;.</para></caution> + </refsect1> + <refsect1> + <title>Syntax</title> + <synopsis><replaceable>var</replaceable> [<replaceable>type-spec</replaceable>] being {each | the} {record | records | tuple | tuples} {in | of} <replaceable>query</replaceable> [from <replaceable>database</replaceable>]</synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>var</parameter></term> + <listitem> + <para>A <literal>d-var-spec</literal>, as defined in the + grammar for <function>loop</function>-clauses in the + ANSI Standard for Common Lisp. This allows for the + usual loop-style destructuring.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>type-spec</parameter></term> + <listitem> + <para>An optional <literal>type-spec</literal> either + simple or destructured, as defined in the grammar for + <function>loop</function>-clauses in the ANSI Standard + for Common Lisp.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>query</parameter></term> + <listitem> + <para>An <glossterm linkend="gloss-sql-expression">sql + expression</glossterm> that represents an SQL + query which is expected to return a (possibly empty) + result set, where each tuple has as many attributes as + <parameter>function</parameter> takes arguments.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>database</parameter></term> + <listitem> + <para>An optional + <glossterm linkend="gloss-database-object">database + object</glossterm>. This will default to the value + of <symbol>*default-database*</symbol>.</para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para>This clause is an iteration driver for + <function>loop</function>, that binds the given variable + (possibly destructured) to the consecutive tuples (which are + represented as lists of attribute values) in the result set + returned by executing the SQL <parameter>query</parameter> + expression on the <parameter>database</parameter> + specified.</para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(defvar *my-db* (connect '("dent" "newesim" "dent" "dent")) + "My database" +=> *MY-DB* +(loop with time-graph = (make-hash-table :test #'equal) + with event-graph = (make-hash-table :test #'equal) + for (time event) being the tuples of "select time,event from log" + from *my-db* + do + (incf (gethash time time-graph 0)) + (incf (gethash event event-graph 0)) + finally + (flet ((show-graph (k v) (format t "~40A => ~5D~%" k v))) + (format t "~&Time-Graph:~%===========~%") + (maphash #'show-graph time-graph) + (format t "~&~%Event-Graph:~%============~%") + (maphash #'show-graph event-graph)) + (return (values time-graph event-graph))) +>> Time-Graph: +>> =========== +>> D => 53000 +>> X => 3 +>> test-me => 3000 +>> +>> Event-Graph: +>> ============ +>> CLOS Benchmark entry. => 9000 +>> Demo Text... => 3 +>> doit-text => 3000 +>> C Benchmark entry. => 12000 +>> CLOS Benchmark entry => 32000 +=> #<EQUAL hash table, 3 entries {48350A1D}> +=> #<EQUAL hash table, 5 entries {48350FCD}> + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para>Whatever effects the execution of the SQL query has + on the underlying database, if any.</para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para>If the execution of the SQL query leads to any + errors, an error of type + <errortype>sql-database-error</errortype> is signalled.</para> + <para>Otherwise, any of the exceptional situations of + <function>loop</function> applies.</para> + </refsect1> + <refsect1> + <title>See Also</title> + <para> + <simplelist> + <member><link linkend="query"><function>query</function></link></member> + <member><link linkend="map-query"><function>map-query</function></link></member> + <member><link linkend="do-query"><function>do-query</function></link></member> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Notes</title> + <para>None.</para> + </refsect1> + </refentry> + </reference> diff --git a/doc/ref-conditions.xml b/doc/ref-conditions.xml new file mode 100644 index 0000000..992fa9a --- /dev/null +++ b/doc/ref-conditions.xml @@ -0,0 +1,813 @@ +<?xml version='1.0' ?> +<!DOCTYPE book PUBLIC "-//OASIS//DTD DocBook XML V4.2//EN" +"http://www.oasis-open.org/docbook/xml/4.2/docbookx.dtd" [ +<!ENTITY % myents SYSTEM "entities.inc"> +%myents; +]> + +<!-- Condition System --> + +<reference id="ref-conditions"> + <title>CLSQL Condition System</title> + <partintro> + <para> + &clsql; provides and uses a condition system in which all errors + and warnings are of type <link + linkend="sql-condition"><errortype>sql-condition</errortype></link>. This + section describes the various subclasses of <link + linkend="sql-condition"><errortype>sql-condition</errortype></link> + defined by &clsql;. Details are also provided for how they are + used in &clsql; and intended to be signalled in user + code. Finally, slot accessors for some of the condition types + are described. + </para> + </partintro> + + <refentry id="backend-warning-behavior"> + <refmeta> + <refentrytitle>*BACKEND-WARNING-BEHAVIOR*</refentrytitle> + </refmeta> + <refnamediv> + <refname>*BACKEND-WARNING-BEHAVIOR*</refname> + <refpurpose>Controls behaviour on warnings from underlying RDBMS.</refpurpose> + <refclass>Variable</refclass> + </refnamediv> + <refsect1> + <title>Value Type</title> + <para> + Meaningful values are <symbol>:warn</symbol>, + <symbol>:error</symbol>, <symbol>:ignore</symbol> and &nil;. + </para> + </refsect1> + <refsect1> + <title>Initial Value</title> + <para><symbol>:warn</symbol></para> + </refsect1> + <refsect1> + <title>Description</title> + <para> + Action to perform on warning messages + from backend. Default is to <symbol>:warn</symbol>. May also be + set to <symbol>:error</symbol> to signal an error or + <symbol>:ignore</symbol> or &nil; to silently ignore the + warning. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> + <!-- examples --> + </screen> + </refsect1> + <refsect1> + <title>Affected By</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>See Also</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>Notes</title> + <para><symbol>*backend-warning-behaviour*</symbol> is a &clsql; + extension.</para> + </refsect1> + </refentry> + + <refentry id="sql-condition"> + <refmeta> + <refentrytitle>SQL-CONDITION</refentrytitle> + </refmeta> + <refnamediv> + <refname>SQL-CONDITION</refname> + <refpurpose>the super-type of all + &clsql;-specific + conditions</refpurpose> + <refclass>Condition Type</refclass> + </refnamediv> + <refsect1> + <title>Class Precedence List</title> + <para> + <simplelist type="inline"> + <member><link linkend="sql-condition"><errortype>sql-condition</errortype></link></member> + <member><errortype>condition</errortype></member> + <member><errortype>t</errortype></member> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Description</title> + <para> + This is the super-type of all &clsql;-specific conditions + defined by &clsql;, or any of it's database-specific + interfaces. There are no defined initialization arguments nor + any accessors. + </para> + </refsect1> + <refsect1> + <title>Notes</title> + <para><errortype>sql-condition</errortype> is a &clsql; + extension.</para> + </refsect1> + </refentry> + + <refentry id="sql-error"> + <refmeta> + <refentrytitle>SQL-ERROR</refentrytitle> + </refmeta> + <refnamediv> + <refname>SQL-ERROR</refname> + <refpurpose>the super-type of all + &clsql;-specific + errors</refpurpose> + <refclass>Condition Type</refclass> + </refnamediv> + <refsect1> + <title>Class Precedence List</title> + <para> + <simplelist type="inline"> + <member><link linkend="sql-error"><errortype>sql-error</errortype></link></member> + <member><errortype>simple-error</errortype></member> + <member><errortype>simple-condition</errortype></member> + <member><errortype>error</errortype></member> + <member><errortype>serious-condition</errortype></member> + <member><link linkend="sql-condition"><errortype>sql-condition</errortype></link></member> + <member><errortype>condition</errortype></member> + <member><errortype>t</errortype></member> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Description</title> + <para> + This is the super-type of all &clsql;-specific conditions that + represent errors, as defined by &clsql;, or any of it's + database-specific interfaces. There are no defined + initialization arguments nor any accessors. + </para> + </refsect1> + <refsect1> + <title>Notes</title> + <para><errortype>sql-error</errortype> is a &clsql; extension.</para> + </refsect1> + </refentry> + + <refentry id="sql-warning"> + <refmeta> + <refentrytitle>SQL-WARNING</refentrytitle> + </refmeta> + <refnamediv> + <refname>SQL-WARNING</refname> + <refpurpose>the super-type of all + &clsql;-specific + warnings</refpurpose> + <refclass>Condition Type</refclass> + </refnamediv> + <refsect1> + <title>Class Precedence List</title> + <para> + <simplelist type="inline"> + <member><link linkend="sql-warning"><errortype>sql-warning</errortype></link></member> + <member><errortype>warning</errortype></member> + <member><link linkend="sql-condition"><errortype>sql-condition</errortype></link></member> + <member><errortype>condition</errortype></member> + <member><errortype>t</errortype></member> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Description</title> + <para> + This is the super-type of all &clsql;-specific conditions that + represent warnings, as defined by &clsql;, or any of it's + database-specific interfaces. There are no defined + initialization arguments nor any accessors. + </para> + </refsect1> + <refsect1> + <title>Notes</title> + <para><errortype>sql-warning</errortype> is a &clsql; extension.</para> + </refsect1> + </refentry> + + <refentry id="sql-database-warning"> + <refmeta> + <refentrytitle>SQL-DATABASE-WARNING</refentrytitle> + </refmeta> + <refnamediv> + <refname>SQL-DATABASE-WARNING</refname> + <refpurpose>Used to warn while accessing a + &clsql; database.</refpurpose> + <refclass>Condition Type</refclass> + </refnamediv> + <refsect1> + <title>Class Precedence List</title> + <para> + <simplelist type="inline"> + <member><link linkend="sql-database-warning"><errortype>sql-database-warning</errortype></link></member> + <member><link linkend="sql-warning"><errortype>sql-warning</errortype></link></member> + <member><errortype>warning</errortype></member> + <member><link linkend="sql-condition"><errortype>sql-condition</errortype></link></member> + <member><errortype>condition</errortype></member> + <member><errortype>t</errortype></member> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Description</title> + <para> + This condition represents warnings signalled while accessing + a database. + </para> + <para> + The following initialization arguments and accessors exist: + </para> + <segmentedlist> + <segtitle>Initarg</segtitle> + <segtitle>Accessor</segtitle> + <segtitle>Description</segtitle> + <seglistitem> + <seg><symbol>:database</symbol></seg> + <seg><function>sql-warning-database</function></seg> + <seg>The database object that was involved in the + incident.</seg> + </seglistitem> + </segmentedlist> + </refsect1> + <refsect1> + <title>Notes</title> + <para><errortype>sql-database-warning</errortype> is a &clsql; + extension.</para> + </refsect1> + </refentry> + + <!-- Specific Conditions --> + + <refentry id="sql-user-error"> + <refmeta> + <refentrytitle>SQL-USER-ERROR</refentrytitle> + </refmeta> + <refnamediv> + <refname>SQL-USER-ERROR</refname> + <refpurpose>condition representing errors because of invalid + parameters from the library user.</refpurpose> + <refclass>Condition Type</refclass> + </refnamediv> + <refsect1> + <title>Class Precedence List</title> + <para> + <simplelist type="inline"> + <member><errortype>sql-user-error</errortype></member> + <member><link linkend="sql-error"><errortype>sql-error</errortype></link></member> + <member><errortype>simple-error</errortype></member> + <member><errortype>simple-condition</errortype></member> + <member><errortype>error</errortype></member> + <member><errortype>serious-condition</errortype></member> + <member><link linkend="sql-condition"><errortype>sql-condition</errortype></link></member> + <member><errortype>condition</errortype></member> + <member><errortype>t</errortype></member> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Description</title> + <para> + This condition represents errors that occur because the user + supplies invalid data to &clsql;. This includes errors such + as an invalid format connection specification or an error in + the syntax for the <function>LOOP</function> macro extensions. + </para> + <para> + The following initialization arguments and accessors exist: + </para> + <segmentedlist> + <segtitle>Initarg</segtitle> + <segtitle>Accessor</segtitle> + <segtitle>Description</segtitle> + <seglistitem> + <seg><symbol>:message</symbol></seg> + <seg><function>sql-user-error-message</function></seg> + <seg>The error message.</seg> + </seglistitem> + </segmentedlist> + </refsect1> + <refsect1> + <title>Notes</title> + <para>The slot accessor + <function>sql-user-error-message</function> is a &clsql; + extension.</para> + </refsect1> + </refentry> + + <refentry id="sql-database-error"> + <refmeta> + <refentrytitle>SQL-DATABASE-ERROR</refentrytitle> + </refmeta> + <refnamediv> + <refname>SQL-DATABASE-ERROR</refname> + <refpurpose>condition representing errors during query or + command execution</refpurpose> + <refclass>Condition Type</refclass> + </refnamediv> + <refsect1> + <title>Class Precedence List</title> + <para> + <simplelist type="inline"> + <member><link linkend="sql-database-error"><errortype>sql-database-error</errortype></link></member> + <member><link linkend="sql-error"><errortype>sql-error</errortype></link></member> + <member><errortype>simple-error</errortype></member> + <member><errortype>simple-condition</errortype></member> + <member><errortype>error</errortype></member> + <member><errortype>serious-condition</errortype></member> + <member><link linkend="sql-condition"><errortype>sql-condition</errortype></link></member> + <member><errortype>condition</errortype></member> + <member><errortype>t</errortype></member> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Description</title> + <para> + This condition represents errors that occur while executing + SQL statements, either as part of query operations or command + execution, either explicitly or implicitly, as caused e.g. by + <function>with-transaction</function>. + </para> + <para> + The following initialization arguments and accessors exist: + </para> + <segmentedlist> + <segtitle>Initarg</segtitle> + <segtitle>Accessor</segtitle> + <segtitle>Description</segtitle> + <seglistitem> + <seg><symbol>:database</symbol></seg> + <seg><function>sql-error-database</function></seg> + <seg>The database object that was involved in the + incident.</seg> + </seglistitem> + <seglistitem> + <seg><symbol>:error-id</symbol></seg> + <seg><function>sql-error-error-id</function></seg> + <seg>The numeric or symbolic error specification + returned by the database back-end. The values and + semantics of this are interface specific.</seg> + </seglistitem> + <seglistitem> + <seg><symbol>:secondary-error-id</symbol></seg> + <seg><function>sql-error-secondary-error-id</function></seg> + <seg>The secondary numeric or symbolic error specification + returned by the database back-end. The values and + semantics of this are interface specific.</seg> + </seglistitem> + <seglistitem> + <seg><symbol>:message</symbol></seg> + <seg><function>sql-error-database-message</function></seg> + <seg>A string describing the problem that occurred, + possibly one returned by the database back-end.</seg> + </seglistitem> + </segmentedlist> + </refsect1> + <refsect1> + <title>Notes</title> + <para> + The slot accessor + <function>sql-error-database</function> is a &clsql; + extension. + </para> + </refsect1> + </refentry> + + <refentry id="sql-connection-error"> + <refmeta> + <refentrytitle>SQL-CONNECTION-ERROR</refentrytitle> + </refmeta> + <refnamediv> + <refname>SQL-CONNECTION-ERROR</refname> + <refpurpose>condition representing errors during + connection</refpurpose> + <refclass>Condition Type</refclass> + </refnamediv> + <refsect1> + <title>Class Precedence List</title> + <para> + <simplelist type="inline"> + <member><link linkend="sql-connection-error"><errortype>sql-connection-error</errortype></link></member> + <member><link linkend="sql-database-error"><errortype>sql-database-error</errortype></link></member> + <member><link linkend="sql-error"><errortype>sql-error</errortype></link></member> + <member><errortype>simple-error</errortype></member> + <member><errortype>simple-condition</errortype></member> + <member><errortype>error</errortype></member> + <member><errortype>serious-condition</errortype></member> + <member><link linkend="sql-condition"><errortype>sql-condition</errortype></link></member> + <member><errortype>condition</errortype></member> + <member><errortype>t</errortype></member> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Description</title> + <para> + This condition represents errors that occur while trying to + connect to a database. + </para> + <para> + The following initialization arguments and accessors exist: + </para> + <segmentedlist> + <segtitle>Initarg</segtitle> + <segtitle>Accessor</segtitle> + <segtitle>Description</segtitle> + <seglistitem> + <seg><symbol>:database-type</symbol></seg> + <seg><function>sql-error-database-type</function></seg> + <seg>Database type for the connection attempt</seg> + </seglistitem> + <seglistitem> + <seg><symbol>:connection-spec</symbol></seg> + <seg><function>sql-error-connection-spec</function></seg> + <seg>The connection specification used in the + connection attempt.</seg> + </seglistitem> + <seglistitem> + <seg><symbol>:database</symbol></seg> + <seg><function>sql-error-database</function></seg> + <seg>The database object that was involved in the + incident.</seg> + </seglistitem> + <seglistitem> + <seg><symbol>:error-id</symbol></seg> + <seg><function>sql-error-error-id</function></seg> + <seg>The numeric or symbolic error specification + returned by the database back-end. The values and + semantics of this are interface specific.</seg> + </seglistitem> + <seglistitem> + <seg><symbol>:secondary-error-id</symbol></seg> + <seg><function>sql-error-secondary-error-id</function></seg> + <seg>The secondary numeric or symbolic error specification + returned by the database back-end. The values and + semantics of this are interface specific.</seg> + </seglistitem> + <seglistitem> + <seg><symbol>:message</symbol></seg> + <seg><function>sql-database-error-error</function></seg> + <seg>A string describing the problem that occurred, + possibly one returned by the database back-end.</seg> + </seglistitem> + </segmentedlist> + </refsect1> + <refsect1> + <title>Notes</title> + <para> + The slot accessors + <function>sql-error-database</function>, + <function>sql-error-database-type</function> and + <function>sql-error-connection-spec</function> are + &clsql; extensions. + </para> + </refsect1> + </refentry> + + <refentry id="sql-database-data-error"> + <refmeta> + <refentrytitle>SQL-DATABASE-DATA-ERROR</refentrytitle> + </refmeta> + <refnamediv> + <refname>SQL-DATABASE-DATA-ERROR</refname> + <refpurpose>Used to signal an error with the SQL data passed + to a database.</refpurpose> + <refclass>Condition Type</refclass> + </refnamediv> + <refsect1> + <title>Class Precedence List</title> + <para> + <simplelist type="inline"> + <member><errortype>sql-database-data-error</errortype></member> + <member><link linkend="sql-database-error"><errortype>sql-database-error</errortype></link></member> + <member><link linkend="sql-error"><errortype>sql-error</errortype></link></member> + <member><errortype>simple-error</errortype></member> + <member><errortype>simple-condition</errortype></member> + <member><errortype>error</errortype></member> + <member><errortype>serious-condition</errortype></member> + <member><link linkend="sql-condition"><errortype>sql-condition</errortype></link></member> + <member><errortype>condition</errortype></member> + <member><errortype>t</errortype></member> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Description</title> + <para>This condition represents errors that occur while + executing SQL statements, specifically as a result of + malformed SQL expressions. + </para> + <para> + The following initialization arguments and accessors exist: + </para> + <segmentedlist> + <segtitle>Initarg</segtitle> + <segtitle>Accessor</segtitle> + <segtitle>Description</segtitle> + <seglistitem> + <seg><symbol>:expression</symbol></seg> + <seg><function>sql-error-expression</function></seg> + <seg>The SQL expression whose execution caused the error.</seg> + </seglistitem> + <seglistitem> + <seg><symbol>:database</symbol></seg> + <seg><function>sql-error-database</function></seg> + <seg>The database object that was involved in the + incident.</seg> + </seglistitem> + <seglistitem> + <seg><symbol>:error-id</symbol></seg> + <seg><function>sql-error-error-id</function></seg> + <seg>The numeric or symbolic error specification + returned by the database back-end. The values and + semantics of this are interface specific.</seg> + </seglistitem> + <seglistitem> + <seg><symbol>:secondary-error-id</symbol></seg> + <seg><function>sql-error-secondary-error-id</function></seg> + <seg>The secondary numeric or symbolic error specification + returned by the database back-end. The values and + semantics of this are interface specific.</seg> + </seglistitem> + <seglistitem> + <seg><symbol>:message</symbol></seg> + <seg><function>sql-error-database-message</function></seg> + <seg>A string describing the problem that occurred, + possibly one returned by the database back-end.</seg> + </seglistitem> + </segmentedlist> + </refsect1> + <refsect1> + <title>Notes</title> + <para> + The slot accessors + <function>sql-error-database</function> and + <function>sql-error-expression</function> are + &clsql; extensions. + </para> + </refsect1> + </refentry> + + <refentry id="sql-temporary-error"> + <refmeta> + <refentrytitle>SQL-TEMPORARY-ERROR</refentrytitle> + </refmeta> + <refnamediv> + <refname>SQL-TEMPORARY-ERROR</refname> + <refpurpose>Used to signal a temporary error in the database + backend.</refpurpose> + <refclass>Condition Type</refclass> + </refnamediv> + <refsect1> + <title>Class Precedence List</title> + <para> + <simplelist type="inline"> + <member><errortype>sql-temporary-error</errortype></member> + <member><link linkend="sql-database-error"><errortype>sql-database-error</errortype></link></member> + <member><link linkend="sql-error"><errortype>sql-error</errortype></link></member> + <member><errortype>simple-error</errortype></member> + <member><errortype>simple-condition</errortype></member> + <member><errortype>error</errortype></member> + <member><errortype>serious-condition</errortype></member> + <member><link linkend="sql-condition"><errortype>sql-condition</errortype></link></member> + <member><errortype>condition</errortype></member> + <member><errortype>t</errortype></member> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Description</title> + <para> + This condition represents errors occurring when the database + cannot currently process a valid interaction because, for + example, it is still executing another command possibly issued + by another user. + </para> + <para> + The following initialization arguments and accessors exist: + </para> + <segmentedlist> + <segtitle>Initarg</segtitle> + <segtitle>Accessor</segtitle> + <segtitle>Description</segtitle> + <seglistitem> + <seg><symbol>:database</symbol></seg> + <seg><function>sql-error-database</function></seg> + <seg>The database object that was involved in the + incident.</seg> + </seglistitem> + <seglistitem> + <seg><symbol>:error-id</symbol></seg> + <seg><function>sql-error-error-id</function></seg> + <seg>The numeric or symbolic error specification + returned by the database back-end. The values and + semantics of this are interface specific.</seg> + </seglistitem> + <seglistitem> + <seg><symbol>:secondary-error-id</symbol></seg> + <seg><function>sql-error-secondary-error-id</function></seg> + <seg>The secondary numeric or symbolic error specification + returned by the database back-end. The values and + semantics of this are interface specific.</seg> + </seglistitem> + <seglistitem> + <seg><symbol>:message</symbol></seg> + <seg><function>sql-error-database-message</function></seg> + <seg>A string describing the problem that occurred, + possibly one returned by the database back-end.</seg> + </seglistitem> + </segmentedlist> + </refsect1> + <refsect1> + <title>Notes</title> + <para> + The slot accessor + <function>sql-error-database</function> is a &clsql; + extension. + </para> + </refsect1> + </refentry> + + <refentry id="sql-timeout-error"> + <refmeta> + <refentrytitle>SQL-TIMEOUT-ERROR</refentrytitle> + </refmeta> + <refnamediv> + <refname>SQL-TIMEOUT-ERROR</refname> + <refpurpose>condition representing errors when a connection + times out.</refpurpose> + <refclass>Condition Type</refclass> + </refnamediv> + <refsect1> + <title>Class Precedence List</title> + <para> + <simplelist type="inline"> + <member><link linkend="sql-connection-error"><errortype>sql-connection-error</errortype></link></member> + <member><link linkend="sql-database-error"><errortype>sql-database-error</errortype></link></member> + <member><link linkend="sql-error"><errortype>sql-error</errortype></link></member> + <member><errortype>simple-error</errortype></member> + <member><errortype>simple-condition</errortype></member> + <member><errortype>error</errortype></member> + <member><errortype>serious-condition</errortype></member> + <member><link linkend="sql-condition"><errortype>sql-condition</errortype></link></member> + <member><errortype>condition</errortype></member> + <member><errortype>t</errortype></member> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Description</title> + <para>This condition represents errors that occur when the + database times out while processing some operation. The + following initialization arguments and accessors exist:</para> + <segmentedlist> + <segtitle>Initarg</segtitle> + <segtitle>Accessor</segtitle> + <segtitle>Description</segtitle> + <seglistitem> + <seg><symbol>:database-type</symbol></seg> + <seg><function>sql-error-database-type</function></seg> + <seg>Database type for the connection attempt</seg> + </seglistitem> + <seglistitem> + <seg><symbol>:connection-spec</symbol></seg> + <seg><function>sql-error-connection-spec</function></seg> + <seg>The connection specification used in the + connection attempt.</seg> + </seglistitem> + <seglistitem> + <seg><symbol>:database</symbol></seg> + <seg><function>sql-error-database</function></seg> + <seg>The database object that was involved in the + incident.</seg> + </seglistitem> + <seglistitem> + <seg><symbol>:error-id</symbol></seg> + <seg><function>sql-error-error-id</function></seg> + <seg>The numeric or symbolic error specification + returned by the database back-end. The values and + semantics of this are interface specific.</seg> + </seglistitem> + <seglistitem> + <seg><symbol>:secondary-error-id</symbol></seg> + <seg><function>sql-error-secondary-error-id</function></seg> + <seg>The secondary numeric or symbolic error specification + returned by the database back-end. The values and + semantics of this are interface specific.</seg> + </seglistitem> + <seglistitem> + <seg><symbol>:message</symbol></seg> + <seg><function>sql-error-database-message</function></seg> + <seg>A string describing the problem that occurred, + possibly one returned by the database back-end.</seg> + </seglistitem> + </segmentedlist> + </refsect1> + <refsect1> + <title>Notes</title> + <para> + The slot accessors + <function>sql-error-database</function>, + <function>sql-error-database-type</function> and + <function>sql-error-connection-spec</function> are + &clsql; extensions. + </para> + </refsect1> + </refentry> + + <refentry id="sql-fatal-error"> + <refmeta> + <refentrytitle>SQL-FATAL-ERROR</refentrytitle> + </refmeta> + <refnamediv> + <refname>SQL-FATAL-ERROR</refname> + <refpurpose>condition representing a fatal error in a database + connection</refpurpose> + <refclass>Condition Type</refclass> + </refnamediv> + <refsect1> + <title>Class Precedence List</title> + <para> + <simplelist type="inline"> + <member><link linkend="sql-connection-error"><errortype>sql-connection-error</errortype></link></member> + <member><link linkend="sql-database-error"><errortype>sql-database-error</errortype></link></member> + <member><link linkend="sql-error"><errortype>sql-error</errortype></link></member> + <member><errortype>simple-error</errortype></member> + <member><errortype>simple-condition</errortype></member> + <member><errortype>error</errortype></member> + <member><errortype>serious-condition</errortype></member> + <member><link linkend="sql-condition"><errortype>sql-condition</errortype></link></member> + <member><errortype>condition</errortype></member> + <member><errortype>t</errortype></member> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Description</title> + <para>This condition represents errors occurring when the + database connection is no longer usable. + </para> + <para> + The following initialization arguments and accessors exist: + </para> + <segmentedlist> + <segtitle>Initarg</segtitle> + <segtitle>Accessor</segtitle> + <segtitle>Description</segtitle> + <seglistitem> + <seg><symbol>:database-type</symbol></seg> + <seg><function>sql-error-database-type</function></seg> + <seg>Database type for the connection attempt</seg> + </seglistitem> + <seglistitem> + <seg><symbol>:connection-spec</symbol></seg> + <seg><function>sql-error-connection-spec</function></seg> + <seg>The connection specification used in the + connection attempt.</seg> + </seglistitem> + <seglistitem> + <seg><symbol>:database</symbol></seg> + <seg><function>sql-error-database</function></seg> + <seg>The database object that was involved in the + incident.</seg> + </seglistitem> + <seglistitem> + <seg><symbol>:error-id</symbol></seg> + <seg><function>sql-error-error-id</function></seg> + <seg>The numeric or symbolic error specification + returned by the database back-end. The values and + semantics of this are interface specific.</seg> + </seglistitem> + <seglistitem> + <seg><symbol>:secondary-error-id</symbol></seg> + <seg><function>sql-error-secondary-error-id</function></seg> + <seg>The secondary numeric or symbolic error specification + returned by the database back-end. The values and + semantics of this are interface specific.</seg> + </seglistitem> + <seglistitem> + <seg><symbol>:message</symbol></seg> + <seg><function>sql-error-database-message</function></seg> + <seg>A string describing the problem that occurred, + possibly one returned by the database back-end.</seg> + </seglistitem> + </segmentedlist> + </refsect1> + <refsect1> + <title>Notes</title> + <para> + The slot accessors + <function>sql-error-database</function>, + <function>sql-error-database-type</function> and + <function>sql-error-connection-spec</function> are + &clsql; extensions. + </para> + </refsect1> + </refentry> + +</reference> diff --git a/doc/ref-connect.xml b/doc/ref-connect.xml new file mode 100644 index 0000000..1e299b9 --- /dev/null +++ b/doc/ref-connect.xml @@ -0,0 +1,2364 @@ +<?xml version='1.0' ?> +<!DOCTYPE book PUBLIC "-//OASIS//DTD DocBook XML V4.2//EN" +"http://www.oasis-open.org/docbook/xml/4.2/docbookx.dtd" [ +<!ENTITY % myents SYSTEM "entities.inc"> +%myents; +]> + +<reference id="ref-connect"> + <title>Connection and Initialisation</title> + <partintro> + <para> + This section describes the &clsql; interface for initialising + database interfaces of different types, creating and destroying + databases and connecting and disconnecting from databases. + </para> + </partintro> + + <!-- Connection and Initialisation --> + + <refentry id="database"> + <refmeta> + <refentrytitle>DATABASE</refentrytitle> + </refmeta> + <refnamediv> + <refname>DATABASE</refname> + <refpurpose>The super-type of all &clsql; databases</refpurpose> + <refclass>Class</refclass> + </refnamediv> + <refsect1> + <title>Class Precedence List</title> + <para> + <simplelist type="inline"> + <member><type>database</type></member> + <member><type>standard-object</type></member> + <member><type>t</type></member> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Description</title> <para>This class is the superclass of + all &clsql; databases. The different database back-ends derive + subclasses of this class to implement their databases. No + instances of this class are ever created by &clsql;.</para> + </refsect1> + <!-- + <refsect1> + <title class="contenttitle">Class details</title> + <programlisting>(defclass DATABASE ()(...))</programlisting> + </refsect1> + <refsect1> + <title class="contenttitle">Slots</title> + <para> + <simplelist> + <property>slot COMMAND-RECORDING-STREAM is of type T</property> + <property>slot CONN-POOL is of type T</property> + <property>slot NAME is of type T</property> + <property>slot RECORD-CACHES is of type T</property> + <property>slot RESULT-RECORDING-STREAM is of type T</property> + <property>slot STATE is of type T</property> + <property>slot TRANSACTION is of type T</property> + <property>slot TRANSACTION-LEVEL is of type T</property> + <property>slot VIEW-CLASSES is of type T</property> + </simplelist> + </para> + </refsect1> + --> + </refentry> + + <refentry id="connect-if-exists"> + <refmeta> + <refentrytitle>*CONNECT-IF-EXISTS*</refentrytitle> + </refmeta> + <refnamediv> + <refname>*CONNECT-IF-EXISTS*</refname> + <refpurpose>Default value for the + <parameter>if-exists</parameter> parameter of <link + linkend="connect"><function>connect</function></link>.</refpurpose> + <refclass>Variable</refclass> + </refnamediv> + <refsect1> + <title>Value Type</title> + <para>A valid argument to the <parameter>if-exists</parameter> + parameter of <function>connect</function>, that is, one of + <simplelist type="inline"> + <member><symbol>:new</symbol></member> + <member><symbol>:warn-new</symbol></member> + <member><symbol>:error</symbol></member> + <member><symbol>:warn-old</symbol></member> + <member><symbol>:old</symbol></member> + </simplelist>. + </para> + </refsect1> + <refsect1> + <title>Initial Value</title> + <para><symbol>:error</symbol></para> + </refsect1> + <refsect1> + <title>Description</title> + <para>The value of this variable is used in calls to + <function>connect</function> as the default + value of the <parameter>if-exists</parameter> + parameter. See <link + linkend="connect"><function>connect</function></link> for + the semantics of the valid values for this variable.</para> + </refsect1> + <refsect1> + <title>Examples</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>Affected By</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>See Also</title> + <para> + <simplelist> + <member><link + linkend="connect"><function>connect</function></link></member> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Notes</title> + <para>None.</para> + </refsect1> + </refentry> + <refentry id="db-pool-max-free-connections"> + <refmeta> + <refentrytitle>*DB-POOL-MAX-FREE-CONNECTIONS*</refentrytitle> + </refmeta> + <refnamediv> + <refname>*DB-POOL-MAX-FREE-CONNECTIONS*</refname> + <refpurpose>How many free connections should the connection pool try to keep.</refpurpose> + <refclass>Parameter</refclass> + </refnamediv> + <refsect1> + <title>Value Type</title> + <para>Integer</para> + </refsect1> + <refsect1> + <title>Initial Value</title> + <para>4</para> + </refsect1> + <refsect1> + <title>Description</title> + <para>Threshold of free-connections in the pool before we + disconnect a database rather than returning it to the pool. NIL for + no limit. This is really a heuristic that should, on avg keep the + free connections about this size.</para> + <note> + <para>This is not a hard limit, the number of connections in + the pool may exceed this value.</para> + </note> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> + (setf clsql-sys:*db-pool-max-free-connections* 2) + </screen> + </refsect1> + <refsect1> + <title>Affected By</title> + <para>None</para> + </refsect1> + <refsect1> + <title>See Also</title> + <para> + <simplelist> + <member><link linkend="connect"><function>connect</function></link></member> + <member><link linkend="disconnect"><function>disconnect</function></link></member> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Notes</title> + <note> + <para></para> + </note> + </refsect1> + </refentry> + + + <refentry id="default-database"> + <refmeta> + <refentrytitle>*DEFAULT-DATABASE*</refentrytitle> + </refmeta> + <refnamediv> + <refname>*DEFAULT-DATABASE*</refname> + <refpurpose>The default database object to use.</refpurpose> + <refclass>Variable</refclass> + </refnamediv> + <refsect1> + <title>Value Type</title> + <para>Any object of type <type>database</type>, or &nil; to + indicate no default database.</para> + </refsect1> + <refsect1> + <title>Initial Value</title> + <para>&nil;</para> + </refsect1> + <refsect1> + <title>Description</title> + <para>Any function or macro in &clsql; that operates on a + database uses the value of this variable as the default value + for it's <parameter>database</parameter> parameter.</para> + <para>The value of this parameter is changed by calls to + <function>connect</function>, which sets + <symbol>*default-database*</symbol> to the database object + it returns. It is also changed by calls to + <function>disconnect</function>, when the database object + being disconnected is the same as the value of + <symbol>*default-database*</symbol>. In this case + <function>disconnect</function> sets + <symbol>*default-database*</symbol> to the first database + that remains in the list of active databases as returned by + <function>connected-databases</function>, or + &nil; if no further active databases + exist.</para> + <para>The user may change <symbol>*default-database*</symbol> + at any time to a valid value of his choice.</para> + <caution> + <para>If the value of <symbol>*default-database*</symbol> is + &nil;, then all calls to &clsql; functions on + databases must provide a suitable + <parameter>database</parameter> parameter, or an error will be + signalled.</para> + </caution> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> + (connected-databases) + => NIL + (connect '("dent" "newesim" "dent" "dent") :database-type :mysql) + => #<CLSQL-MYSQL:MYSQL-DATABASE {48385F55}> + (connect '(nil "template1" "dent" nil) :database-type :postgresql) + => #<CLSQL-POSTGRESQL:POSTGRESQL-DATABASE {483868FD}> + (connect '("dent" "newesim" "dent" "dent") :database-type :mysql :if-exists :new) + => #<CLSQL-MYSQL:MYSQL-DATABASE {48387265}> + *default-database* + => #<CLSQL-MYSQL:MYSQL-DATABASE {48387265}> + (disconnect) + => T + *default-database* + => #<CLSQL-POSTGRESQL:POSTGRESQL-DATABASE {483868FD}> + (disconnect) + => T + *default-database* + => #<CLSQL-MYSQL:MYSQL-DATABASE {48385F55}> + (disconnect) + => T + *default-database* + => NIL + (connected-databases) + => NIL + </screen> + </refsect1> + <refsect1> + <title>Affected By</title> + <simplelist> + <member><link linkend="connect"><function>connect</function></link></member> + <member><link linkend="disconnect"><function>disconnect</function></link></member> + </simplelist> + </refsect1> + <refsect1> + <title>See Also</title> + <para> + <simplelist> + <member><link linkend="connected-databases"><function>connected-databases</function></link></member> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Notes</title> + <note> + <para>This variable is intended to facilitate working with + &clsql; in an interactive + fashion at the top-level loop, and because of this, + <function>connect</function> and + <function>disconnect</function> provide some fairly + complex behaviour to keep + <symbol>*default-database*</symbol> set to useful values. + Programmatic use of &clsql; + should never depend on the value of + <symbol>*default-database*</symbol> and should provide + correct database objects via the + <parameter>database</parameter> parameter to functions + called.</para> + </note> + </refsect1> + </refentry> + + <refentry id="default-database-type"> + <refmeta> + <refentrytitle>*DEFAULT-DATABASE-TYPE*</refentrytitle> + </refmeta> + <refnamediv> + <refname>*DEFAULT-DATABASE-TYPE*</refname> + <refpurpose>The default database type to use</refpurpose> + <refclass>Variable</refclass> + </refnamediv> + <refsect1> + <title>Value Type</title> + <para>Any keyword representing a valid database back-end of + &clsql;, or &nil;.</para> + </refsect1> + <refsect1> + <title>Initial Value</title> + <para>&nil;</para> + </refsect1> + <refsect1> + <title>Description</title> + <para>The value of this variable is used in calls to + <function>initialize-database-type</function> and + <function>connect</function> as the default value of the + <parameter>database-type</parameter> parameter.</para> + <caution> + <para>If the value of this variable is &nil;, + then all calls to + <function>initialize-database-type</function> or + <function>connect</function> will have to specify the + <parameter>database-type</parameter> to use, or a + general-purpose error will be signalled.</para> + </caution> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> + (setf *default-database-type* :mysql) + => :mysql + (initialize-database-type) + => t + </screen> + </refsect1> + <refsect1> + <title>Affected By</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>See Also</title> + <simplelist> + <member><link + linkend="initialize-database-type"><function>intitialize-database-type</function></link></member> + </simplelist> + </refsect1> + <refsect1> + <title>Notes</title> + <para>None.</para> + </refsect1> + </refentry> + + <refentry id="initialized-database-types"> + <refmeta> + <refentrytitle>*INITIALIZED-DATABASE-TYPES*</refentrytitle> + </refmeta> + <refnamediv> + <refname>*INITIALIZED-DATABASE-TYPES*</refname> + <refpurpose>List of all initialized database types</refpurpose> + <refclass>Variable</refclass> + </refnamediv> + <refsect1> + <title>Value Type</title> + <para>A list of all initialized database types, each of which + represented by it's corresponding keyword.</para> + </refsect1> + <refsect1> + <title>Initial Value</title> + <para>&nil;</para> + </refsect1> + <refsect1> + <title>Description</title> + <para>This variable is updated whenever + <function>initialize-database-type</function> is called for a + database type which hasn't already been initialized before, as + determined by this variable. In that case the keyword + representing the database type is pushed onto the list stored in + <symbol>*INITIALIZED-DATABASE-TYPES*</symbol>.</para> + <caution> + <para>Attempts to modify the value of this variable will + result in undefined behaviour.</para> + </caution> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> + (setf *default-database-type* :mysql) + => :mysql + (initialize-database-type) + => t + *initialized-database-types* + => (:MYSQL) + </screen> + </refsect1> + <refsect1> + <title>Affected By</title> + <para> + <simplelist> + <member><function>initialize-database-type</function></member> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>See Also</title> + <simplelist> + <member><link + linkend="initialize-database-type"><function>intitialize-database-type</function></link></member> + </simplelist> + </refsect1> + <refsect1> + <title>Notes</title> + <para>Direct access to this variable is primarily provided + because of compatibility with Harlequin's <application>Common + SQL</application>.</para> + </refsect1> + </refentry> + + <refentry id="connect"> + <refmeta> + <refentrytitle>CONNECT</refentrytitle> + </refmeta> + <refnamediv> + <refname>CONNECT</refname> + <refpurpose>create a connection to a database.</refpurpose> + <refclass>Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis><function>connect</function> <replaceable>connection-spec</replaceable> &key <replaceable>if-exists</replaceable> <replaceable>database-type</replaceable> <replaceable>pool</replaceable> <replaceable>make-default</replaceable> => <returnvalue>database</returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>connection-spec</parameter></term> + <listitem> + <para>A SQL backend specific connection specification + supplied as a list or as a string.</para> + <para>For the MySQL backend, this list includes an + optional associative list of connection options. The + options list is parsed and supplied to the MySQL API + using <function>mysql_options</function> in between the + calls to <function>mysql_init</function> + and <function>mysql_real_connect</function>.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>if-exists</parameter></term> + <listitem> + <para>This indicates the action to take if a connection + to the same database exists already. See below for the + legal values and actions. It defaults to the value of + <symbol>*connect-if-exists*</symbol>.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>database-type</parameter></term> + <listitem> + <para>A database type specifier, i.e. a keyword. + This defaults to the value of + <symbol>*default-database-type*</symbol></para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>pool</parameter></term> + <listitem> + <para>A boolean flag. If &t;, acquire connection from a + pool of open connections. If the pool is empty, a new + connection is created. The default is &nil;. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>make-default</parameter></term> + <listitem> + <para>A boolean flag. If &t;, + <symbol>*default-database*</symbol> is set to the new + connection, otherwise <symbol>*default-database*</symbol> + is not changed. The default is &t;. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><returnvalue>database</returnvalue></term> + <listitem> + <para>The database object representing the connection.</para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para>This function takes a connection specification and + a database type and creates a connection to the database + specified by those. The type and structure of the + connection specification depend on the database type.</para> + <para>The parameter <parameter>if-exists</parameter> specifies + what to do if a connection to the database specified exists + already, which is checked by calling + <function>find-database</function> on the database name + returned by <function>database-name-from-spec</function> + when called with the <parameter>connection-spec</parameter> + and <parameter>database-type</parameter> parameters. The + possible values of <parameter>if-exists</parameter> are: + <variablelist> + <varlistentry> + <term><symbol>:new</symbol></term> + <listitem> + <para>Go ahead and create a new connection.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><symbol>:warn-new</symbol></term> + <listitem> + <para>This is just like <symbol>:new</symbol>, but + also signals a warning of type + <errortype>clsql-exists-warning</errortype>, + indicating the old and newly created + databases.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><symbol>:error</symbol></term> + <listitem> + <para>This will cause <function>connect</function> to + signal a correctable error of type + <errortype>clsql-exists-error</errortype>. The + user may choose to proceed, either by indicating + that a new connection shall be created, via the + restart <symbol>create-new</symbol>, or by + indicating that the existing connection shall be + used, via the restart + <symbol>use-old</symbol>.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><symbol>:old</symbol></term> + <listitem> + <para>This will cause <function>connect</function> to + use an old connection if one exists.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><symbol>:warn-old</symbol></term> + <listitem> + <para>This is just like <symbol>:old</symbol>, but + also signals a warning of type + <errortype>clsql-exists-warning</errortype>, + indicating the old database used, via the slots + <symbol>old-db</symbol> and + <symbol>new-db</symbol></para> + </listitem> + </varlistentry> + </variablelist> + </para> + <para>The database name of the returned database object will + be the same under <function>string=</function> as that which + would be returned by a call to + <function>database-name-from-spec</function> with the given + <parameter>connection-spec</parameter> and + <parameter>database-type</parameter> parameters.</para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(database-name-from-spec '("dent" "newesim" "dent" "dent") :mysql) +=> "dent/newesim/dent" +(connect '("dent" "newesim" "dent" "dent") :database-type :mysql) +=> #<CLSQL-MYSQL:MYSQL-DATABASE {48036F6D}> +(database-name *) +=> "dent/newesim/dent" + +(connect '("dent" "newesim" "dent" "dent") :database-type :mysql) +>> In call to CONNECT: +>> There is an existing connection #<CLSQL-MYSQL:MYSQL-DATABASE {48036F6D}> to database dent/newesim/dent. +>> +>> Restarts: +>> 0: [CREATE-NEW] Create a new connection. +>> 1: [USE-OLD ] Use the existing connection. +>> 2: [ABORT ] Return to Top-Level. +>> +>> Debug (type H for help) +>> +>> (CONNECT ("dent" "newesim" "dent" "dent") :IF-EXISTS NIL :DATABASE-TYPE ...) +>> Source: +>> ; File: /prj/CLSQL/sql/sql.cl +>> (RESTART-CASE (ERROR 'CLSQL-EXISTS-ERROR :OLD-DB OLD-DB) +>> (CREATE-NEW NIL :REPORT "Create a new connection." +>> (SETQ RESULT #)) +>> (USE-OLD NIL :REPORT "Use the existing connection." +>> (SETQ RESULT OLD-DB))) +>> 0] 0 +=> #<CLSQL-MYSQL:MYSQL-DATABASE {480451F5}> + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para>A database connection is established, and the resultant + database object is registered, so as to appear in the list + returned by <function>connected-databases</function>. + <symbol>*default-database*</symbol> may be rebound to the + created object.</para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para> + <simplelist> + <member> + <link linkend="default-database-type"> + <symbol>*default-database-type*</symbol> + </link> + </member> + <member> + <link linkend="connect-if-exists"> + <symbol>*connect-if-exists*</symbol> + </link> + </member> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para>If the connection specification is not syntactically or + semantically correct for the given database type, an error of + type <errortype>sql-user-error</errortype> is + signalled. If during the connection attempt an error is + detected (e.g. because of permission problems, network trouble + or any other cause), an error of type + <errortype>sql-database-error</errortype> is signalled.</para> + <para>If a connection to the database specified by + <parameter>connection-spec</parameter> exists already, + conditions are signalled according to the + <parameter>if-exists</parameter> parameter, as described + above.</para> + </refsect1> + <refsect1> + <title>See Also</title> + <simplelist> + <member><link linkend="connected-databases"><function>connected-databases</function></link></member> + <member><link linkend="disconnect"><function>disconnect</function></link></member> + <member><link linkend="reconnect"><function>reconnect</function></link></member> + <member><link linkend="connect-if-exists"><function>*connect-if-exists*</function></link></member> + <member><link linkend="find-database"><function>find-database</function></link></member> + <member><link linkend="status"><function>status</function></link></member> + </simplelist> + </refsect1> + <refsect1> + <title>Notes</title> + <para>The <parameter>pool</parameter> and + <parameter>make-default</parameter> keyword arguments to + <function>connect</function> are &clsql; extensions.</para> + </refsect1> + </refentry> + + <refentry id="connected-databases"> + <refmeta> + <refentrytitle>CONNECTED-DATABASES</refentrytitle> + </refmeta> + <refnamediv> + <refname>CONNECTED-DATABASES</refname> + <refpurpose>Return the list of active database objects.</refpurpose> + <refclass>Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis> + <function>connected-databases</function> => <returnvalue>databases</returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><returnvalue>databases</returnvalue></term> + <listitem> + <para>The list of active database objects.</para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para>This function returns the list of active database + objects, i.e. all those database objects created by calls to + <function>connect</function>, which have not been closed by + calling <function>disconnect</function> on them.</para> + <caution> + <para>The consequences of modifying the list returned by + <function>connected-databases</function> are + undefined.</para> + </caution> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(connected-databases) +=> NIL +(connect '(nil "template1" "dent" nil) :database-type :postgresql) +=> #<CLSQL-POSTGRESQL:POSTGRESQL-DATABASE {4830BC65}> +(connect '("dent" "newesim" "dent" "dent") :database-type :mysql) +=> #<CLSQL-MYSQL:MYSQL-DATABASE {4830C5AD}> +(connected-databases) +=> (#<CLSQL-MYSQL:MYSQL-DATABASE {4830C5AD}> + #<CLSQL-POSTGRESQL:POSTGRESQL-DATABASE {4830BC65}>) +(disconnect) +=> T +(connected-databases) +=> (#<CLSQL-POSTGRESQL:POSTGRESQL-DATABASE {4830BC65}>) +(disconnect) +=> T +(connected-databases) +=> NIL + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>Affected By</title> + <para> + <simplelist> + <member><function>connect</function></member> + <member><function>disconnect</function></member> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>See Also</title> + <simplelist> + <member><link linkend="disconnect"><function>disconnect</function></link></member> + <member><link linkend="connect"><function>connect</function></link></member> + <member><link linkend="status"><function>status</function></link></member> + <member><link linkend="find-database"><function>find-database</function></link></member> + </simplelist> + </refsect1> + <refsect1> + <title>Notes</title> + <para>None.</para> + </refsect1> + </refentry> + + + <refentry id="database-name"> + <refmeta> + <refentrytitle>DATABASE-NAME</refentrytitle> + </refmeta> + <refnamediv> + <refname>DATABASE-NAME</refname> + <refpurpose>Get the name of a database object</refpurpose> + <refclass>Generic Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis><function>database-name</function> <replaceable>database</replaceable> => <returnvalue>name</returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>database</parameter></term> + <listitem> + <para>A database object, either of type + <type>database</type> or of type + <type>closed-database</type>.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><returnvalue>name</returnvalue></term> + <listitem> + <para>A string describing the identity of the database + to which this database object is connected to.</para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para>This function returns the database name of the given + database. The database name is a string which somehow + describes the identity of the database to which this + database object is or has been connected. The database name + of a database object is determined at + <function>connect</function> time, when a call to + <function>database-name-from-spec</function> derives the + database name from the connection specification passed to + <function>connect</function> in the + <parameter>connection-spec</parameter> parameter.</para> + <para>The database name is used via + <function>find-database</function> in + <function>connect</function> to determine whether database + connections to the specified database exist already.</para> + <para>Usually the database name string will include + indications of the host, database name, user, or port that + where used during the connection attempt. The only + important thing is that this string shall try to identify + the database at the other end of the connection. Connection + specifications parts like passwords and credentials shall + not be used as part of the database name.</para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(database-name-from-spec '("dent" "newesim" "dent" "dent") :mysql) +=> "dent/newesim/dent" +(connect '("dent" "newesim" "dent" "dent") :database-type :mysql) +=> #<CLSQL-MYSQL:MYSQL-DATABASE {48391DCD}> +(database-name *default-database*) +=> "dent/newesim/dent" + +(database-name-from-spec '(nil "template1" "dent" nil) :postgresql) +=> "/template1/dent" +(connect '(nil "template1" "dent" nil) :database-type :postgresql) +=> #<CLSQL-POSTGRESQL:POSTGRESQL-DATABASE {48392D2D}> +(database-name *default-database*) +=> "/template1/dent" + +(database-name-from-spec '("www.pmsf.de" "template1" "dent" nil) :postgresql) +=> "www.pmsf.de/template1/dent" + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>Affected By</title> + <para> + <simplelist> + <member><link linkend="database-name-from-spec"><function>database-name-from-spec</function></link></member> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para>Will signal an error if the object passed as the + <parameter>database</parameter> parameter is neither of type + <type>database</type> nor of type + <type>closed-database</type>.</para> + </refsect1> + <refsect1> + <title>See Also</title> + <para> + <simplelist> + <member><link + linkend="connect"><function>connect</function></link></member> + <member><link + linkend="find-database"><function>find-database</function></link></member> + <member><link linkend="connected-databases"><function>connected-databases</function></link></member> + <member><link linkend="disconnect"><function>disconnect</function></link></member> + <member><link linkend="status"><function>status</function></link></member> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Notes</title> + <para>None.</para> + </refsect1> + </refentry> + + <refentry id="database-name-from-spec"> + <refmeta> + <refentrytitle>DATABASE-NAME-FROM-SPEC</refentrytitle> + </refmeta> + <refnamediv> + <refname>DATABASE-NAME-FROM-SPEC</refname> + <refpurpose>Return the database name string corresponding to + the given connection specification.</refpurpose> + <refclass>Generic Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis> + <function>database-name-from-spec</function> <replaceable>connection-spec</replaceable> <replaceable>database-type</replaceable> => <returnvalue>name</returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>connection-spec</parameter></term> + <listitem> + <para>A connection specification, whose structure and + interpretation are dependent on the + <parameter>database-type</parameter>.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>database-type</parameter></term> + <listitem> + <para>A database type specifier, i.e. a keyword.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><returnvalue>name</returnvalue></term> + <listitem> + <para>A string denoting a database name.</para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para>This generic function takes a connection specification + and a database type and returns the database name of the + database object that would be created had + <function>connect</function> been called with the given + connection specification and database types.</para> + <para>This function is useful in determining a database name + from the connection specification, since the way the + connection specification is converted into a database name + is dependent on the database type.</para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(database-name-from-spec '("dent" "newesim" "dent" "dent") :mysql) +=> "dent/newesim/dent" +(connect '("dent" "newesim" "dent" "dent") :database-type :mysql) +=> #<CLSQL-MYSQL:MYSQL-DATABASE {48391DCD}> +(database-name *default-database*) +=> "dent/newesim/dent" + +(database-name-from-spec '(nil "template1" "dent" nil) :postgresql) +=> "/template1/dent" +(connect '(nil "template1" "dent" nil) :database-type :postgresql) +=> #<CLSQL-POSTGRESQL:POSTGRESQL-DATABASE {48392D2D}> +(database-name *default-database*) +=> "/template1/dent" + +(database-name-from-spec '("www.pmsf.de" "template1" "dent" nil) :postgresql) +=> "www.pmsf.de/template1/dent" + +(find-database "dent/newesim/dent") +=> #<CLSQL-MYSQL:MYSQL-DATABASE {484E91C5}> +(find-database "/template1/dent") +=> #<CLSQL-POSTGRESQL:POSTGRESQL-DATABASE {48392D2D}> +(find-database "www.pmsf.de/template1/dent" nil) +=> NIL +(find-database **) +=> #<CLSQL-POSTGRESQL:POSTGRESQL-DATABASE {48392D2D}> + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para>If the value of <parameter>connection-spec</parameter> + is not a valid connection specification for the given + database type, an error of type + <errortype>clsql-invalid-spec-error</errortype> might be + signalled.</para> + </refsect1> + <refsect1> + <title>See Also</title> + <para> + <simplelist> + <member><link linkend="connect"><function>connect</function></link></member> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Notes</title> + <para><function>database-name-from-spec</function> is a + &clsql; extension.</para> + </refsect1> + </refentry> + + <refentry id="database-type"> + <refmeta> + <refentrytitle>DATABASE-TYPE</refentrytitle> + </refmeta> + <refnamediv> + <refname>DATABASE-TYPE</refname> + <refpurpose>Get the type of a database object.</refpurpose> + <refclass>Generic Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis> + <function>database-type</function> <replaceable>DATABASE</replaceable> => <returnvalue>type</returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>database</parameter></term> + <listitem> + <para>A database object, either of type + <type>database</type> or of type + <type>closed-database</type>.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><returnvalue>type</returnvalue></term> + <listitem> + <para>A keyword symbol denoting a known database back-end.</para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para> + Returns the type of <parameter>database</parameter>. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(connect '(nil "template1" "dent" nil) :database-type :postgresql) +=> #<CLSQL-POSTGRESQL:POSTGRESQL-DATABASE {48392D2D}> +(database-type *default-database*) +=> :postgresql + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para> + None. + </para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para> + None. + </para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para>Will signal an error if the object passed as the + <parameter>database</parameter> parameter is neither of type + <type>database</type> nor of type + <type>closed-database</type>.</para> + </refsect1> + <refsect1> + <title>See Also</title> + <para> + <simplelist> + <member><link + linkend="connect"><function>connect</function></link></member> + <member><link + linkend="find-database"><function>find-database</function></link></member> + <member><link linkend="connected-databases"><function>connected-databases</function></link></member> + <member><link linkend="disconnect"><function>disconnect</function></link></member> + <member><link linkend="status"><function>status</function></link></member> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Notes</title> + <para> + <function>database-type</function> is a &clsql; extension. + </para> + </refsect1> + </refentry> + + <refentry id="disconnect"> + <refmeta> + <refentrytitle>DISCONNECT</refentrytitle> + </refmeta> + <refnamediv> + <refname>DISCONNECT</refname> + <refpurpose>close a database connection</refpurpose> + <refclass>Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis><function>disconnect</function> &key <replaceable>database</replaceable> <replaceable>error</replaceable> => <returnvalue>result</returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>error</parameter></term> + <listitem> + <para>A boolean flag indicating whether to signal an error + if <parameter>database</parameter> is non-&nil; but cannot + be found. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>database</parameter></term> + <listitem> + <para>The database to disconnect, which defaults to the + database indicated by + <symbol>*default-database*</symbol>.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>result</parameter></term> + <listitem> + <para>A Boolean indicating whether a connection was + successfully disconnected. + </para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para>This function takes a <type>database</type> object as + returned by <function>connect</function>, and closes the + connection. If no matching database is found and + <parameter>error</parameter> and + <parameter>database</parameter> are both non-&nil; an error is + signaled, otherwise &nil; is returned. If the database is from a + pool it will be released to this pool. + </para> + + <para>The status of the object passed is changed to closed + after the disconnection succeeds, thereby preventing further + use of the object as an argument to &clsql; functions, with + the exception of <function>database-name</function> and + <function>database-type</function>. If the user does pass a + closed database to any other &clsql; function, an error of + type <errortype>sql-fatal-error</errortype> is + signalled.</para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(disconnect :database (find-database "dent/newesim/dent")) +=> T + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para>The database object is removed from the list of connected databases as + returned by <link linkend="connected-databases"><function>connected-databases</function></link>.</para> + <para>If the database object passed is the same under + <function>eq</function> as the value of + <symbol>*default-database*</symbol>, then + <symbol>*default-database*</symbol> is set to the first + remaining database from + <function>connected-databases</function> or to &nil; if no + further active database exists.</para> + <refsect2> + <title>Non-pooled</title> + <para>The database connection is closed and the state of the + database object is changed to <type>closed</type>.</para> + </refsect2> + <refsect2> + <title>Pooled</title> + <para>Unless there are already <link linkend="db-pool-max-free-connections"> + <symbol>*db-pool-max-free-connections*</symbol> + </link> free connections in the pool it is returned to the + pool, with the backend having an opportunity to run + generic cleanup on the connection first. If the max free + connections has already been reached then it is + disconnected as if it were not in the pool. + </para> + </refsect2> + </refsect1> + <refsect1> + <title>Affected by</title> + <para> + <simplelist> + <member> + <link linkend="default-database"> + <symbol>*default-database*</symbol> + </link> + </member> + <member> + <link linkend="db-pool-max-free-connections"> + <symbol>*db-pool-max-free-connections*</symbol> + </link> + </member> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para>If during the disconnection attempt an error is detected + (e.g. because of network trouble or any other cause), an error + of type <errortype>sql-error</errortype> might be + signalled.</para> + </refsect1> + <refsect1> + <title>See Also</title> + <para> + <simplelist> + <member><link linkend="connect"><function>connect</function></link></member> + <member><link linkend="disconnect-pooled"><function>disconnect-pooled</function></link></member> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Notes</title> + <para>None.</para> + </refsect1> + </refentry> + + <refentry id="disconnect-pooled"> + <refmeta> + <refentrytitle>DISCONNECT-POOLED</refentrytitle> + </refmeta> + <refnamediv> + <refname>DISCONNECT-POOLED</refname> + <refpurpose>closes all pooled database connections</refpurpose> + <refclass>Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis><function>disconnect-pooled</function> &optional <symbol>clear</symbol> => <returnvalue>t</returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Description</title> + <para>This function disconnects all database connections + that have been placed into the pool by calling <link + linkend="connect"><function>connect</function></link> with + :pool &t;. + </para> + <para>If optional argument <symbol>clear</symbol> is non-&nil; + then the connection-pool objects are also removed.</para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(disconnect-pool) +=> T + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para>Database connections will be closed and *all* entries in + the pool are removed. This is done with great prejudice and no + thought to thread safety or whether that connection is + currently in use.</para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para> + <simplelist> + <member><function>disconnect</function></member> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para>If during the disconnection attempt an error is + detected (e.g. because of network trouble or any other + cause), an error of type <errortype>clsql-error</errortype> + might be signalled.</para> + </refsect1> + <refsect1> + <title>See Also</title> + <para> + <simplelist> + <member><link linkend="connect"><function>connect</function></link></member> + <member><link linkend="disconnect"><function>disconnect</function></link></member> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Notes</title> + <para><function>disconnect-pooled</function> is a &clsql; + extension.</para> + </refsect1> + </refentry> + + <refentry id="find-database"> + <refmeta> + <refentrytitle>FIND-DATABASE</refentrytitle> + </refmeta> + <refnamediv> + <refname>FIND-DATABASE</refname> + <refpurpose>>Locate a database object through it's + name.</refpurpose> + <refclass>Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis><function>find-database</function> <replaceable>database</replaceable> &optional <replaceable>errorp</replaceable> => <returnvalue>result</returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>database</parameter></term> + <listitem> + <para>A database object or a string, denoting a database + name.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>errorp</parameter></term> + <listitem> + <para>A generalized boolean. Defaults to + <symbol>t</symbol>.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>db-type</parameter></term> + <listitem> + <para> + A keyword symbol denoting a known database back-end. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><returnvalue>result</returnvalue></term> + <listitem> + <para>Either a database object, or, if + <parameter>errorp</parameter> is &nil;, + possibly &nil;.</para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para><function>find-database</function> locates an active + database object given the specification in + <parameter>database</parameter>. If + <parameter>database</parameter> is an object of type + <type>database</type>, <function>find-database</function> + returns this. Otherwise it will search the active databases + as indicated by the list returned by + <function>connected-databases</function> for a database of + type <parameter>db-type</parameter> whose name (as returned by + <function>database-name</function> is equal as per + <function>string=</function> to the string passed as + <parameter>database</parameter>. If it succeeds, it returns + the first database found.</para> + <para> + If <parameter>db-type</parameter> is &nil; all databases + matching the string <parameter>database</parameter> are + considered. If no matching databases are found and + <parameter>errorp</parameter> is &nil; then &nil; is + returned. If <parameter>errorp</parameter> is &nil; and one or + more matching databases are found, then the most recently + connected database is returned as a first value and the + number of matching databases is returned as a second + value. If no, or more than one, matching databases are found + and <parameter>errorp</parameter> is true, an error is + signalled. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(database-name-from-spec '("dent" "newesim" "dent" "dent") :mysql) +=> "dent/newesim/dent" +(connect '("dent" "newesim" "dent" "dent") :database-type :mysql) +=> #<CLSQL-MYSQL:MYSQL-DATABASE {48391DCD}> +(database-name *default-database*) +=> "dent/newesim/dent" + +(database-name-from-spec '(nil "template1" "dent" nil) :postgresql) +=> "/template1/dent" +(connect '(nil "template1" "dent" nil) :database-type :postgresql) +=> #<CLSQL-POSTGRESQL:POSTGRESQL-DATABASE {48392D2D}> +(database-name *default-database*) +=> "/template1/dent" + +(database-name-from-spec '("www.pmsf.de" "template1" "dent" nil) :postgresql) +=> "www.pmsf.de/template1/dent" + +(find-database "dent/newesim/dent") +=> #<CLSQL-MYSQL:MYSQL-DATABASE {484E91C5}> +(find-database "/template1/dent") +=> #<CLSQL-POSTGRESQL:POSTGRESQL-DATABASE {48392D2D}> +(find-database "www.pmsf.de/template1/dent" nil) +=> NIL +(find-database **) +=> #<CLSQL-POSTGRESQL:POSTGRESQL-DATABASE {48392D2D}> + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>Affected By</title> + <para> + <simplelist> + <member><link linkend="connected-databases"><function>connected-databases</function></link></member> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para>Will signal an error of type + <errortype>clsql-error</errortype> if no matching database + can be found, and <parameter>errorp</parameter> is true. + Will signal an error if the value of + <parameter>database</parameter> is neither an object of type + <type>database</type> nor a string.</para> + </refsect1> + <refsect1> + <title>See Also</title> + <para> + <simplelist> + <member><link + linkend="database-name"><function>database-name</function></link></member> + <member><link + linkend="database-name-from-spec"><function>database-name-from-spec</function></link></member> + <member><link linkend="disconnect"><function>disconnect</function></link></member> + <member><link linkend="connect"><function>connect</function></link></member> + <member><link linkend="status"><function>status</function></link></member> + <member><link linkend="connected-databases"><function>connected-databases</function></link></member> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Notes</title> + <para>The <parameter>db-type</parameter> keyword argument to + <function>find-database</function> is a &clsql; + extension. </para> + </refsect1> + </refentry> + + <refentry id="initialize-database-type"> + <refmeta> + <refentrytitle>INITIALIZE-DATABASE-TYPE</refentrytitle> + </refmeta> + <refnamediv> + <refname>INITIALIZE-DATABASE-TYPE</refname> + <refpurpose>Initializes a database type</refpurpose> + <refclass>Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis> + <function>initialize-database-type &key database-type</function> => <returnvalue>result</returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>database-type</parameter></term> + <listitem> + <para>The database type to initialize, i.e. a keyword + symbol denoting a known database back-end. Defaults to + the value of + <symbol>*default-database-type*</symbol>.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><returnvalue>result</returnvalue></term> + <listitem> + <para>Either &nil; if the initialization + attempt fails, or <symbol>t</symbol> otherwise.</para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para>If the back-end specified by + <parameter>database-type</parameter> has not already been + initialized, as seen from + <symbol>*initialized-database-types*</symbol>, an attempt is + made to initialize the database. If this attempt succeeds, + or the back-end has already been initialized, the function + returns t, and places the keyword denoting the database type + onto the list stored in + <symbol>*initialized-database-types*</symbol>, if not + already present.</para> + <para>If initialization fails, the function returns + &nil;, and/or signals an error of type + <errortype>clsql-error</errortype>. The kind of action + taken depends on the back-end and the cause of the + problem.</para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +*initialized-database-types* +=> NIL +(setf *default-database-type* :mysql) +=> :MYSQL +(initialize-database-type) +>> Compiling LAMBDA (#:G897 #:G898 #:G901 #:G902): +>> Compiling Top-Level Form: +>> +=> T +*initialized-database-types* +=> (:MYSQL) +(initialize-database-type) +=> T +*initialized-database-types* +=> (:MYSQL) + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para>The database back-end corresponding to the database type + specified is initialized, unless it has already been + initialized. This can involve any number of other side + effects, as determined by the back-end implementation (like + e.g. loading of foreign code, calling of foreign code, + networking operations, etc.). If initialization is + attempted and succeeds, the + <parameter>database-type</parameter> is pushed onto the list + stored in + <symbol>*initialized-database-types*</symbol>.</para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para> + <simplelist> + <member><symbol>*default-database-type*</symbol></member> + <member><symbol>*initialized-database-types*</symbol></member> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para>If an error is encountered during the initialization + attempt, the back-end may signal errors of kind + <errortype>clsql-error</errortype>.</para> + </refsect1> + <refsect1> + <title>See Also</title> + <simplelist> + <member><link linkend="initialized-database-types"><function>*initialized-database-types*</function></link></member> + <member><link linkend="default-database-type"><function>*default-database-type*</function></link></member> + </simplelist> + </refsect1> + <refsect1> + <title>Notes</title> + <para>None.</para> + </refsect1> + </refentry> + + <refentry id="reconnect"> + <refmeta> + <refentrytitle>RECONNECT</refentrytitle> + </refmeta> + <refnamediv> + <refname>RECONNECT</refname> + <refpurpose>Re-establishes the connection between a database object and its RDBMS.</refpurpose> + <refclass>Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis> + <function>reconnect</function> &key <parameter>database</parameter> <parameter>error</parameter> <parameter>force</parameter> => <returnvalue>result</returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>database</parameter></term> + <listitem> + <para>The database to reconnect, which defaults to the + database indicated by + <symbol>*default-database*</symbol>.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>error</parameter></term> + <listitem> + <para>A boolean flag indicating whether to signal an error + if <parameter>database</parameter> is non-nil but cannot + be found. The default value is &nil;. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>force</parameter></term> + <listitem> + <para>A Boolean indicating whether to signal an error if the + database connection has been lost. The default value is &t;. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>result</parameter></term> + <listitem> + <para>A Boolean indicating whether the database was + successfully reconnected. + </para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para>Reconnects <parameter>database</parameter> which defaults + to <symbol>*default-database*</symbol> to the underlying + database management system. On success, &t; is returned and the + variable <symbol>*default-database*</symbol> is set to the newly + reconnected database. If <parameter>database</parameter> is a + database instance, this object is closed. If + <parameter>database</parameter> is a string, then a connected + database whose name matches <parameter>database</parameter> is + sought in the list of connected databases. If no matching + database is found and <parameter>error</parameter> and + <parameter>database</parameter> are both non-&nil; an error is + signaled, otherwise &nil; is returned.</para> + + <para> When the current database connection has been lost, if + <parameter>force</parameter> is non-&nil; as it is by default, the + connection is closed and errors are suppressed. If + <parameter>force</parameter> is &nil; and the database connection + cannot be closed, an error is signalled. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +*default-database* +=> #<CLSQL-SQLITE:SQLITE-DATABASE :memory: OPEN {48CFBEA5}> +(reconnect) +=> #<CLSQL-SQLITE:SQLITE-DATABASE :memory: OPEN {48D64105}> + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para>A database connection is re-established and + <symbol>*default-database*</symbol> may be rebound to the supplied + database object.</para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para> + <simplelist> + <member><symbol>*default-database*</symbol></member> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para> + An error may be signalled if the specified database cannot be + located or if the database cannot be closed. + </para> + </refsect1> + <refsect1> + <title>See Also</title> + <para> + <simplelist> + <member><link + linkend="connect"><function>connect</function></link></member> + <member><link + linkend="disconnect"><function>disconnect</function></link></member> + <member><link + linkend="disconnect-pooled"><function>disconnect-pooled</function></link></member> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Notes</title> + <para> + None. + </para> + </refsect1> + </refentry> + + <refentry id="status"> + <refmeta> + <refentrytitle>STATUS</refentrytitle> + </refmeta> + <refnamediv> + <refname>STATUS</refname> + <refpurpose>Print information about connected databases.</refpurpose> + <refclass>Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis> + <function>status</function> &optional <parameter>full</parameter> => <returnvalue></returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>full</parameter></term> + <listitem> + <para>A boolean indicating whether to print additional + table information. The default value is &nil;. + </para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para>Prints information about the currently connected databases + to <symbol>*STANDARD-OUTPUT*</symbol>. The argument + <parameter>full</parameter> is &nil; by default and a value of t + means that more detailed information about each database is + printed. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(status) + +CLSQL STATUS: 2004-06-13 15:07:39 +-------------------------------------------------------- + DATABASE TYPE RECORDING +-------------------------------------------------------- + localhost/test/petrov mysql nil + localhost/test/petrov postgresql nil + localhost/test/petrov postgresql-socket nil + test/petrov odbc nil +* :memory: sqlite nil +-------------------------------------------------------- + +(status t) + +CLSQL STATUS: 2004-06-13 15:08:08 +------------------------------------------------------------------------------- + DATABASE TYPE RECORDING POOLED TABLES VIEWS +------------------------------------------------------------------------------- + localhost/test/petrov mysql nil nil 7 0 + localhost/test/petrov postgresql nil nil 7 0 + localhost/test/petrov postgresql-socket nil nil 7 0 + test/petrov odbc nil nil 7 0 +* :memory: sqlite nil nil 0 0 +------------------------------------------------------------------------------- +</screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para> + None. + </para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para> + None. + </para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para> + None. + </para> + </refsect1> + <refsect1> + <title>See Also</title> + <para> + <simplelist> + <member><link linkend="connected-databases"><function>connected-databases</function></link></member> + <member><link linkend="connect"><function>connect</function></link></member> + <member><link linkend="disconnect"><function>disconnect</function></link></member> + <member><link linkend="connect-if-exists"><function>*connect-if-exists*</function></link></member> + <member><link linkend="find-database"><function>find-database</function></link></member> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Notes</title> + <para> + None. + </para> + </refsect1> + </refentry> + + + <!-- create/probe/list/destroytruncate-database --> + + <refentry id="create-database"> + <refmeta> + <refentrytitle>CREATE-DATABASE</refentrytitle> + </refmeta> + <refnamediv> + <refname>CREATE-DATABASE</refname> + <refpurpose>create a database</refpurpose> + <refclass>Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis><function>create-database</function> <replaceable>connection-spec</replaceable> &key <replaceable>database-type</replaceable> => <returnvalue>success</returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>connection-spec</parameter></term> + <listitem> + <para>A connection specification</para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>database-type</parameter></term> + <listitem> + <para>A database type specifier, i.e. a keyword. + This defaults to the value of + <symbol>*default-database-type*</symbol></para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>success</parameter></term> + <listitem> + <para>A boolean flag. If &t;, a new database was + successfully created. + </para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para>This function creates a database in the database system + specified by <parameter>database-type</parameter>. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(create-database '("localhost" "new" "dent" "dent") :database-type :mysql) +=> T + +(create-database '("localhost" "new" "dent" "badpasswd") :database-type :mysql) +=> +Error: While trying to access database localhost/new/dent + using database-type MYSQL: + Error database-create failed: mysqladmin: connect to server at 'localhost' failed +error: 'Access denied for user: 'root@localhost' (Using password: YES)' + has occurred. + [condition type: CLSQL-ACCESS-ERROR] + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para>A database will be created on the filesystem of the host.</para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para>An exception will be thrown if the database system does + not allow new databases to be created or if database creation + fails.</para> + </refsect1> + <refsect1> + <title>See Also</title> + <para> + <simplelist> + <member><link linkend="destroy-database"><function>destroy-database</function></link></member> + <member><link linkend="probe-database"><function>probe-database</function></link></member> + <member><link linkend="list-databases"><function>list-databases</function></link></member> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Notes</title> + <para>This function may invoke the operating systems + functions. Thus, some database systems may require the + administration functions to be available in the current + <symbol>PATH</symbol>. At this time, the + <symbol>:mysql</symbol> backend requires + <filename>mysqladmin</filename> and the + <symbol>:postgresql</symbol> backend requires + <filename>createdb</filename>.</para> + <para> + <function>create-database</function> is a &clsql; extension. + </para> + </refsect1> + </refentry> + + <refentry id="destroy-database"> + <refmeta> + <refentrytitle>DESTROY-DATABASE</refentrytitle> + </refmeta> + <refnamediv> + <refname>DESTROY-DATABASE</refname> + <refpurpose>destroys a database</refpurpose> + <refclass>Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis><function>destroy-database</function> <replaceable>connection-spec</replaceable> &key <replaceable>database-type</replaceable> => <returnvalue>success</returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>connection-spec</parameter></term> + <listitem> + <para>A connection specification</para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>database-type</parameter></term> + <listitem> + <para>A database type specifier, i.e. a keyword. + This defaults to the value of + <symbol>*default-database-type*</symbol></para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>success</parameter></term> + <listitem> + <para>A boolean flag. If &t;, the database was + successfully destroyed. + </para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para>This function destroys a database in the database system + specified by <parameter>database-type</parameter>. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(destroy-database '("localhost" "new" "dent" "dent") :database-type :postgresql) +=> T + +(destroy-database '("localhost" "new" "dent" "dent") :database-type :postgresql) +=> +Error: While trying to access database localhost/test2/root + using database-type POSTGRESQL: + Error database-destroy failed: dropdb: database removal failed: ERROR: database "test2" does not exist + has occurred. + [condition type: CLSQL-ACCESS-ERROR] + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para>A database will be removed from the filesystem of the host.</para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para>An exception will be thrown if the database system does not + allow databases to be removed, the database does not exist, or + if database removal fails.</para> + </refsect1> + <refsect1> + <title>See Also</title> + <para> + <simplelist> + <member><link linkend="create-database"><function>create-database</function></link></member> + <member><link linkend="probe-database"><function>probe-database</function></link></member> + <member><link linkend="list-databases"><function>list-databases</function></link></member> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Notes</title> + <para>This function may invoke the operating systems + functions. Thus, some database systems may require the + administration functions to be available in the current + <symbol>PATH</symbol>. At this time, the + <symbol>:mysql</symbol> backend requires + <filename>mysqladmin</filename> and the + <symbol>:postgresql</symbol> backend requires + <filename>dropdb</filename>.</para> + <para> + <function>destroy-database</function> is a &clsql; extension. + </para> + </refsect1> + </refentry> + + <refentry id="probe-database"> + <refmeta> + <refentrytitle>PROBE-DATABASE</refentrytitle> + </refmeta> + <refnamediv> + <refname>PROBE-DATABASE</refname> + <refpurpose>tests for existence of a database</refpurpose> + <refclass>Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis><function>probe-database</function> <replaceable>connection-spec</replaceable> &key <replaceable>database-type</replaceable> => <returnvalue>success</returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>connection-spec</parameter></term> + <listitem> + <para>A connection specification</para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>database-type</parameter></term> + <listitem> + <para>A database type specifier, i.e. a keyword. + This defaults to the value of + <symbol>*default-database-type*</symbol></para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>success</parameter></term> + <listitem> + <para>A boolean flag. If &t;, the database exists + in the database system. + </para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para>This function tests for the existence of a database in + the database system specified by + <parameter>database-type</parameter>. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(probe-database '("localhost" "new" "dent" "dent") :database-type :postgresql) +=> T + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para>None</para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para>An exception maybe thrown if the database system does + not receive administrator-level authentication since function + may need to read the administrative database of the database + system.</para> + </refsect1> + <refsect1> + <title>See Also</title> + <para> + <simplelist> + <member><link linkend="create-database"><function>create-database</function></link></member> + <member><link linkend="destroy-database"><function>destroy-database</function></link></member> + <member><link linkend="list-databases"><function>list-databases</function></link></member> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Notes</title> + <para> + <function>probe-database</function> is a &clsql; extension. + </para> + </refsect1> + </refentry> + + <refentry id="list-databases"> + <refmeta> + <refentrytitle>LIST-DATABASES</refentrytitle> + </refmeta> + <refnamediv> + <refname>LIST-DATABASES</refname> + <refpurpose>List databases matching the supplied connection spec + and database type.</refpurpose> + <refclass>Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis> + <function>list-databases</function> <parameter>connection-spec</parameter> &key <parameter>database-type</parameter> => <returnvalue>result</returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>connection-spec</parameter></term> + <listitem> + <para>A connection specification</para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>database-type</parameter></term> + <listitem> + <para>A database type specifier, i.e. a keyword. + This defaults to the value of + <symbol>*default-database-type*</symbol></para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>result</parameter></term> + <listitem> + <para>A list of matching databases. + </para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para> + This function returns a list of databases existing in the + database system specified by + <parameter>database-type</parameter>. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(list-databases '("localhost" "new" "dent" "dent") :database-type :postgresql) +=> ("address-book" "sql-test" "template1" "template0" "test1" "dent" "test") + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para> + None. + </para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para> + None. + </para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para> + An exception maybe thrown if the database system does not + receive administrator-level authentication since function may + need to read the administrative database of the database + system. + </para> + </refsect1> + <refsect1> + <title>See Also</title> + <para> + <simplelist> + <member><link linkend="create-database"><function>create-database</function></link></member> + <member><link linkend="destroy-database"><function>destroy-database</function></link></member> + <member><link linkend="probe-database"><function>probe-database</function></link></member> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Notes</title> + <para> + <function>list-databases</function> is a &clsql; extension. + </para> + </refsect1> + </refentry> + + + <!-- with-database and with-default-database --> + + <refentry id="with-database"> + <refmeta> + <refentrytitle>WITH-DATABASE</refentrytitle> + </refmeta> + <refnamediv> + <refname>WITH-DATABASE</refname> + <refpurpose>Execute a body of code with a variable bound to a + specified database object.</refpurpose> + <refclass>Macro</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis> + <function>with-database</function> <replaceable>db-var</replaceable> <replaceable>connection-spec</replaceable> &rest <replaceable>connect-args</replaceable> &body <replaceable>body</replaceable> => <returnvalue>result</returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>db-var</parameter></term> + <listitem> + <para>A variable which is bound to the specified database. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>connection-spec</parameter></term> + <listitem> + <para>A vendor specific connection specification supplied + as a list or as a string.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>connect-args</parameter></term> + <listitem> + <para>Other optional arguments to + <function>connect</function>. This macro use a value of + &nil; for <function>connect</function>'s + <replaceable>make-default</replaceable> key, This is in + contrast to to the connect function which has a default + value of &t; for <replaceable>make-default</replaceable>. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>body</parameter></term> + <listitem> + <para>A Lisp code body. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>result</parameter></term> + <listitem> + <para>Determined by the result of executing the last + expression in <parameter>body</parameter>. + </para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para>Evaluate <parameter>body</parameter> in an environment, + where <parameter>db-var</parameter> is bound to the database + connection given by <parameter>connection-spec</parameter> and + <parameter>connect-args</parameter>. The connection is + automatically closed or released to the pool on exit from the + body. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(connected-databases) +=> NIL +(with-database (db '(":memory:") :database-type :sqlite + :make-default nil) + (database-name db)) +=> ":memory:" +(connected-databases) +=> NIL + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para> + See <function>connect</function> and <function>disconnect</function>. + </para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para> + See <function>connect</function> and <function>disconnect</function>. + </para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para> + See <function>connect</function> and <function>disconnect</function>. + </para> + </refsect1> + <refsect1> + <title>See Also</title> + <para> + <simplelist> + <member><link linkend="connect"><function>connect</function></link></member> + <member><link linkend="disconnect"><function>disconnect</function></link></member> + <member><link linkend="disconnect-pooled"><function>disconnect-pooled</function></link></member> + <member><link linkend="with-default-database"><function>with-default-database</function></link></member> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Notes</title> + <para> + <function>with-database</function> is a &clsql; extension. + </para> + </refsect1> + </refentry> + + <refentry id="with-default-database"> + <refmeta> + <refentrytitle>WITH-DEFAULT-DATABASE</refentrytitle> + </refmeta> + <refnamediv> + <refname>WITH-DEFAULT-DATABASE</refname> + <refpurpose>Execute a body of code with <symbol>*default-database*</symbol> bound to a specified database.</refpurpose> + <refclass>Macro</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis> + <function>with-default-database</function> <replaceable>database</replaceable> &rest <replaceable>body</replaceable> => <returnvalue>result</returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>database</parameter></term> + <listitem> + <para>An active database object. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>body</parameter></term> + <listitem> + <para>A Lisp code body. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>result</parameter></term> + <listitem> + <para>Determined by the result of executing the last + expression in <parameter>body</parameter>. + </para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para>Perform <parameter>body</parameter> with + <parameter>DATABASE</parameter> bound as + <symbol>*default-database*</symbol>. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +*default-database* +=> #<CLSQL-ODBC:ODBC-DATABASE new/dent OPEN {49095CAD}> + +(let ((database (clsql:find-database ":memory:"))) + (with-default-database (database) + (database-name *default-database*))) +=> ":memory:" + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para> + None. + </para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para> + None. + </para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para> + Calls to &clsql; functions in <parameter>body</parameter> may signal + errors if <parameter>database</parameter> is not an active database + object. + </para> + </refsect1> + <refsect1> + <title>See Also</title> + <para> + <simplelist> + <member><link linkend="with-database"><function>with-database</function></link></member> + <member><link linkend="default-database"><symbol>*default-database*</symbol></link></member> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Notes</title> + <para> + <function>with-default-database</function> is a &clsql; extension. + </para> + </refsect1> + </refentry> + + +</reference> diff --git a/doc/ref-fddl.xml b/doc/ref-fddl.xml new file mode 100644 index 0000000..b48bd3b --- /dev/null +++ b/doc/ref-fddl.xml @@ -0,0 +1,2618 @@ +<?xml version='1.0' ?> +<!DOCTYPE book PUBLIC "-//OASIS//DTD DocBook XML V4.2//EN" +"http://www.oasis-open.org/docbook/xml/4.2/docbookx.dtd" [ +<!ENTITY % myents SYSTEM "entities.inc"> +%myents; +]> + +<!-- Functional Data Definition Language --> +<reference id="ref-fddl"> + <title>Functional Data Definition Language (FDDL)</title> + <partintro> + <para> + &clsql; provides a functional DDL which supports the creation + and destruction of a variety of database objects including + tables, views, indexes and sequences. Functions which return + information about currently defined database objects are also + provided. In addition, the FDDL includes functionality for + examining table attributes and attribute types. + </para> + </partintro> + + <refentry id="create-table"> + <refmeta> + <refentrytitle>CREATE-TABLE</refentrytitle> + </refmeta> + <refnamediv> + <refname>CREATE-TABLE</refname> + <refpurpose>Create a database table.</refpurpose> + <refclass>Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis> + <function>create-table</function> <replaceable>name</replaceable> <replaceable>description</replaceable> &key <replaceable>database</replaceable> <replaceable>constraints</replaceable> <replaceable>transactions</replaceable> => <returnvalue></returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>name</parameter></term> + <listitem> + <para> + The name of the table as a string, symbol or SQL expression. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>database</parameter></term> + <listitem> + <para> + A database object which defaults to + <symbol>*default-database*</symbol>. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>description</parameter></term> + <listitem> + <para> + A list. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>constraints</parameter></term> + <listitem> + <para> + A string, a list of strings or &nil;. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>transactions</parameter></term> + <listitem> + <para> + A Boolean. The default value is &t;. + </para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para>Creates a table called <parameter>name</parameter>, which + may be a string, symbol or SQL table identifier, in + <parameter>database</parameter> which defaults to + <symbol>*default-database*</symbol>. <parameter>description</parameter> + is a list whose elements are lists containing the attribute + names, types, and other constraints such as not-null or + primary-key for each column in the table. + </para> + <para> + <parameter>constraints</parameter> is a string representing an + SQL table constraint expression or a list of such strings. + </para> + <para> + With MySQL databases, if <parameter>transactions</parameter> + is &t; an InnoDB table is created which supports transactions. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(create-table [foo] + '(([id] integer) + ([height] float) + ([name] (string 24)) + ([comments] text))) +=> +(table-exists-p [foo]) +=> T + +(create-table [foo] '(([bar] integer :not-null :unique :primary-key) + ([baz] string :not-null :unique))) +=> +(table-exists-p [foo]) +=> T + +(create-table [foo] '(([bar] integer :not-null) ([baz] string :not-null)) + :constraints '("UNIQUE (bar,baz)" "PRIMARY KEY (bar)")) +=> +(table-exists-p [foo]) +=> T + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para> + A table is created in <parameter>database</parameter>. + </para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para> + <symbol>*default-database*</symbol> + </para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para> + An error is signalled if <parameter>name</parameter> is not a + string, symbol or SQL expression. An error of type + <symbol>sql-database-data-error</symbol> is signalled if a + relation called <parameter>name</parameter> already exists. + </para> + </refsect1> + <refsect1> + <title>See Also</title> + <simplelist> + <member><link linkend="drop-table"><function>drop-table</function></link></member> + <member><link linkend="list-tables"><function>list-tables</function></link></member> + <member><link linkend="table-exists-p"><function>table-exists-p</function></link></member> + </simplelist> + </refsect1> + <refsect1> + <title>Notes</title> + <para> + The <parameter>constraints</parameter> and + <parameter>transactions</parameter> keyword arguments to + <function>create-table</function> are &clsql; extensions. The + <parameter>transactions</parameter> keyword argument is for + compatibility with MySQL databases. + </para> + </refsect1> + </refentry> + + <refentry id="drop-table"> + <refmeta> + <refentrytitle>DROP-TABLE</refentrytitle> + </refmeta> + <refnamediv> + <refname>DROP-TABLE</refname> + <refpurpose>Drop a database table.</refpurpose> + <refclass>Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis> + <function>drop-table</function> <replaceable>name</replaceable> &key <replaceable>if-does-not-exist</replaceable> <replaceable>database</replaceable> => <returnvalue></returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>name</parameter></term> + <listitem> + <para> + The name of the table as a string, symbol or SQL expression. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>database</parameter></term> + <listitem> + <para> + A database object which defaults to + <symbol>*default-database*</symbol>. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>if-does-not-exist</parameter></term> + <listitem> + <para> + A symbol. Meaningful values are <symbol>:ignore</symbol> + or <symbol>:error</symbol> (the default). + </para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para>Drops the table called <parameter>name</parameter> from + <parameter>database</parameter> which defaults to + <symbol>*default-database*</symbol>. If the table does not exist + and <parameter>if-does-not-exist</parameter> is + <symbol>:ignore</symbol> then <function>drop-table</function> + returns &nil; whereas an error is signalled if + <parameter>if-does-not-exist</parameter> is + <symbol>:error</symbol>. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(table-exists-p [foo]) +=> T +(drop-table [foo] :if-does-not-exist :ignore) +=> +(table-exists-p [foo]) +=> NIL + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para> + A table is dropped <parameter>database</parameter>. + </para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para> + <symbol>*default-database*</symbol> + </para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para> + An error is signalled if <parameter>name</parameter> is not a + string, symbol or SQL expression. An error of type + <symbol>sql-database-data-error</symbol> is signalled if + <parameter>name</parameter> doesn't exist and + <parameter>if-does-not-exist</parameter> has a value of + <symbol>:error</symbol>. + </para> + </refsect1> + <refsect1> + <title>See Also</title> + <simplelist> + <member><link linkend="create-table"><function>create-table</function></link></member> + <member><link linkend="list-tables"><function>list-tables</function></link></member> + <member><link linkend="table-exists-p"><function>table-exists-p</function></link></member> + </simplelist> + </refsect1> + <refsect1> + <title>Notes</title> + <para> + The <parameter>if-does-not-exist</parameter> keyword argument + to <function>drop-table</function> is a &clsql; extension. + </para> + </refsect1> + </refentry> + + <refentry id="list-tables"> + <refmeta> + <refentrytitle>LIST-TABLES</refentrytitle> + </refmeta> + <refnamediv> + <refname>LIST-TABLES</refname> + <refpurpose>Returns a list of database tables.</refpurpose> + <refclass>Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis> + <function>list-tables</function> &key <replaceable>owner</replaceable> <replaceable>database</replaceable> => <returnvalue>result</returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>owner</parameter></term> + <listitem> + <para> + A string, &nil; or <symbol>:all</symbol>. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>database</parameter></term> + <listitem> + <para> + A database object which defaults to + <symbol>*default-database*</symbol>. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>result</parameter></term> + <listitem> + <para> + A list of strings. + </para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para>Returns a list of strings representing table names in + <parameter>database</parameter> which defaults to + <symbol>*default-database*</symbol>. <parameter>owner</parameter> + is &nil; by default which means that only tables owned by users + are listed. If <parameter>owner</parameter> is a string denoting + a user name, only tables owned by <parameter>owner</parameter> + are listed. If <parameter>owner</parameter> is + <symbol>:all</symbol> then all tables are listed. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(list-tables :owner "fred") +=> ("type_table" "type_bigint" "employee" "company" "addr" "ea_join" "big") + +(list-tables :owner :all) +=> ("pg_description" "pg_group" "pg_proc" "pg_rewrite" "pg_type" "pg_attribute" + "pg_class" "pg_inherits" "pg_index" "pg_operator" "pg_opclass" "pg_am" + "pg_amop" "pg_amproc" "pg_language" "pg_largeobject" "pg_aggregate" + "pg_trigger" "pg_listener" "pg_cast" "pg_namespace" "pg_shadow" + "pg_conversion" "pg_depend" "pg_attrdef" "pg_constraint" "pg_database" + "type_table" "type_bigint" "employee" "company" "pg_statistic" "addr" + "ea_join" "big") + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para> + None. + </para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para> + <symbol>*default-database*</symbol> + </para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para> + None. + </para> + </refsect1> + <refsect1> + <title>See Also</title> + <simplelist> + <member><link linkend="create-table"><function>create-table</function></link></member> + <member><link linkend="drop-table"><function>drop-table</function></link></member> + <member><link linkend="table-exists-p"><function>table-exists-p</function></link></member> + </simplelist> + </refsect1> + <refsect1> + <title>Notes</title> + <para> + None. + </para> + </refsect1> + </refentry> + + <refentry id="table-exists-p"> + <refmeta> + <refentrytitle>TABLE-EXISTS-P</refentrytitle> + </refmeta> + <refnamediv> + <refname>TABLE-EXISTS-P</refname> + <refpurpose>Tests for the existence of a database table.</refpurpose> + <refclass>Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis> + <function>table-exists-p</function> <replaceable>name</replaceable> &key <replaceable>owner</replaceable> <replaceable>database</replaceable> => <returnvalue>result</returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>name</parameter></term> + <listitem> + <para> + The name of the table as a string, symbol or SQL expression. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>owner</parameter></term> + <listitem> + <para> + A string, &nil; or <symbol>:all</symbol>. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>database</parameter></term> + <listitem> + <para> + A database object which defaults to + <symbol>*default-database*</symbol>. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>result</parameter></term> + <listitem> + <para> + A Boolean. + </para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para>Tests for the existence of an SQL table called + <parameter>name</parameter> in <parameter>database</parameter> + which defaults to <symbol>*default-database*</symbol>. + <parameter>owner</parameter> is &nil; by default which means + that only tables owned by users are examined. If + <parameter>owner</parameter> is a string denoting a user name, + only tables owned by <parameter>owner</parameter> are + examined. If <parameter>owner</parameter> is + <symbol>:all</symbol> then all tables are examined. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(table-exists-p [foo]) +=> T + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para> + None. + </para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para> + <symbol>*default-database*</symbol> + </para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para> + None. + </para> + </refsect1> + <refsect1> + <title>See Also</title> + <simplelist> + <member><link linkend="create-table"><function>create-table</function></link></member> + <member><link linkend="drop-table"><function>drop-table</function></link></member> + <member><link linkend="list-tables"><function>list-tables</function></link></member> + </simplelist> + </refsect1> + <refsect1> + <title>Notes</title> + <para> + None. + </para> + </refsect1> + </refentry> + + <refentry id="create-view"> + <refmeta> + <refentrytitle>CREATE-VIEW</refentrytitle> + </refmeta> + <refnamediv> + <refname>CREATE-VIEW</refname> + <refpurpose>Create a database view.</refpurpose> + <refclass>Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis> + <function>create-view</function> <replaceable>name</replaceable> &key <replaceable>as</replaceable> <replaceable>column-list</replaceable> <replaceable>with-check-option</replaceable> <replaceable>database</replaceable> => <returnvalue></returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>name</parameter></term> + <listitem> + <para> + The name of the view as a string, symbol or SQL expression. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>database</parameter></term> + <listitem> + <para> + A database object which defaults to + <symbol>*default-database*</symbol>. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>as</parameter></term> + <listitem> + <para> + A symbolic SQL query expression. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>column-list</parameter></term> + <listitem> + <para> + A list. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>with-check-option</parameter></term> + <listitem> + <para> + A Boolean. + </para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para>Creates a view called <parameter>name</parameter> in + <parameter>database</parameter> which defaults to + <symbol>*default-database*</symbol>. The view is created using + the query <parameter>as</parameter> and the columns of the view + may be specified using the <parameter>column-list</parameter> + parameter. The <parameter>with-check-option</parameter> is &nil; + by default but if it has a non-&nil; value, then all + insert/update commands on the view are checked to ensure that + the new data satisfy the query <parameter>as</parameter>. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(create-view [lenins-group] + :as [select [first-name] [last-name] [email] + :from [employee] + :where [= [managerid] 1]]) +=> + +(select [*] :from [lenins-group]) +=> (("Josef" "Stalin" "stalin@soviet.org") + ("Leon" "Trotsky" "trotsky@soviet.org") + ("Nikita" "Kruschev" "kruschev@soviet.org") + ("Leonid" "Brezhnev" "brezhnev@soviet.org") + ("Yuri" "Andropov" "andropov@soviet.org") + ("Konstantin" "Chernenko" "chernenko@soviet.org") + ("Mikhail" "Gorbachev" "gorbachev@soviet.org") + ("Boris" "Yeltsin" "yeltsin@soviet.org") + ("Vladimir" "Putin" "putin@soviet.org")), + ("first_name" "last_name" "email") + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para> + A view is created in <parameter>database</parameter>. + </para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para> + <symbol>*default-database*</symbol> + </para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para> + An error is signalled if <parameter>name</parameter> is not a + string, symbol or SQL expression. An error of type + <symbol>sql-database-data-error</symbol> is signalled if a + relation called <parameter>name</parameter> already exists. + </para> + </refsect1> + <refsect1> + <title>See Also</title> + <simplelist> + <member><link linkend="drop-view"><function>drop-view</function></link></member> + <member><link linkend="list-views"><function>list-views</function></link></member> + <member><link linkend="view-exists-p"><function>view-exists-p</function></link></member> + </simplelist> + </refsect1> + <refsect1> + <title>Notes</title> + <para> + None. + </para> + </refsect1> + </refentry> + + <refentry id="drop-view"> + <refmeta> + <refentrytitle>DROP-VIEW</refentrytitle> + </refmeta> + <refnamediv> + <refname>DROP-VIEW</refname> + <refpurpose>Drops a database view.</refpurpose> + <refclass>Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis> + <function>drop-view</function> <replaceable>name</replaceable> &key <replaceable>if-does-not-exist</replaceable> <replaceable>database</replaceable> => <returnvalue></returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>name</parameter></term> + <listitem> + <para> + The name of the view as a string, symbol or SQL expression. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>database</parameter></term> + <listitem> + <para> + A database object which defaults to + <symbol>*default-database*</symbol>. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>if-does-not-exist</parameter></term> + <listitem> + <para> + A symbol. Meaningful values are <symbol>:ignore</symbol> + or <symbol>:error</symbol> (the default). + </para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para>Drops the view called <parameter>name</parameter> from + <parameter>database</parameter> which defaults to + <symbol>*default-database*</symbol>. If the view does not exist + and <parameter>if-does-not-exist</parameter> is + <symbol>:ignore</symbol> then <function>drop-view</function> + returns &nil; whereas an error is signalled if + <parameter>if-does-not-exist</parameter> is + <symbol>:error</symbol>. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(view-exists-p [foo]) +=> T +(drop-view [foo] :if-does-not-exist :ignore) +=> +(view-exists-p [foo]) +=> NIL + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para> + A view is dropped <parameter>database</parameter>. + </para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para> + <symbol>*default-database*</symbol> + </para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para> + An error is signalled if <parameter>name</parameter> is not a + string, symbol or SQL expression. An error of type + <symbol>sql-database-data-error</symbol> is signalled if + <parameter>name</parameter> doesn't exist and + <parameter>if-does-not-exist</parameter> has a value of + <symbol>:error</symbol>. + </para> + </refsect1> + <refsect1> + <title>See Also</title> + <simplelist> + <member><link linkend="create-view"><function>create-view</function></link></member> + <member><link linkend="list-views"><function>list-views</function></link></member> + <member><link linkend="view-exists-p"><function>view-exists-p</function></link></member> + </simplelist> + </refsect1> + <refsect1> + <title>Notes</title> + <para> + The <parameter>if-does-not-exist</parameter> keyword argument + to <function>drop-view</function> is a &clsql; extension. + </para> + </refsect1> + </refentry> + + <refentry id="list-views"> + <refmeta> + <refentrytitle>LIST-VIEWS</refentrytitle> + </refmeta> + <refnamediv> + <refname>LIST-VIEWS</refname> + <refpurpose>Returns a list of database views.</refpurpose> + <refclass>Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis> + <function>list-views</function> &key <replaceable>owner</replaceable> <replaceable>database</replaceable> => <returnvalue>result</returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>owner</parameter></term> + <listitem> + <para> + A string, &nil; or <symbol>:all</symbol>. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>database</parameter></term> + <listitem> + <para> + A database object which defaults to + <symbol>*default-database*</symbol>. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>result</parameter></term> + <listitem> + <para> + A list of strings. + </para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para>Returns a list of strings representing view names in + <parameter>database</parameter> which defaults to + <symbol>*default-database*</symbol>. <parameter>owner</parameter> + is &nil; by default which means that only views owned by users + are listed. If <parameter>owner</parameter> is a string denoting + a user name, only views owned by <parameter>owner</parameter> + are listed. If <parameter>owner</parameter> is + <symbol>:all</symbol> then all views are listed. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(list-views :owner "fred") +=> ("lenins_group") + +(list-views :owner :all) +=> ("pg_user" "pg_rules" "pg_views" "pg_tables" "pg_indexes" "pg_stats" + "pg_stat_all_tables" "pg_stat_sys_tables" "pg_stat_user_tables" + "pg_statio_all_tables" "pg_statio_sys_tables" "pg_statio_user_tables" + "pg_stat_all_indexes" "pg_stat_sys_indexes" "pg_stat_user_indexes" + "pg_statio_all_indexes" "pg_statio_sys_indexes" "pg_statio_user_indexes" + "pg_statio_all_sequences" "pg_statio_sys_sequences" + "pg_statio_user_sequences" "pg_stat_activity" "pg_stat_database" + "pg_locks" "pg_settings" "lenins_group") + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para> + None. + </para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para> + <symbol>*default-database*</symbol> + </para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para> + None. + </para> + </refsect1> + <refsect1> + <title>See Also</title> + <simplelist> + <member><link linkend="create-view"><function>create-view</function></link></member> + <member><link linkend="drop-view"><function>drop-view</function></link></member> + <member><link linkend="view-exists-p"><function>view-exists-p</function></link></member> + </simplelist> + </refsect1> + <refsect1> + <title>Notes</title> + <para> + <function>list-views</function> is a &clsql; extension. + </para> + </refsect1> + </refentry> + + <refentry id="view-exists-p"> + <refmeta> + <refentrytitle>VIEW-EXISTS-P</refentrytitle> + </refmeta> + <refnamediv> + <refname>VIEW-EXISTS-P</refname> + <refpurpose>Tests for the existence of a database view.</refpurpose> + <refclass>Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis> + <function>view-exists-p</function> <replaceable>name</replaceable> &key <replaceable>owner</replaceable> <replaceable>database</replaceable> => <returnvalue>result</returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>name</parameter></term> + <listitem> + <para> + The name of the view as a string, symbol or SQL expression. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>owner</parameter></term> + <listitem> + <para> + A string, &nil; or <symbol>:all</symbol>. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>database</parameter></term> + <listitem> + <para> + A database object which defaults to + <symbol>*default-database*</symbol>. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>result</parameter></term> + <listitem> + <para> + A Boolean. + </para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para>Tests for the existence of an SQL view called + <parameter>name</parameter> in <parameter>database</parameter> + which defaults to <symbol>*default-database*</symbol>. + <parameter>owner</parameter> is &nil; by default which means + that only views owned by users are examined. If + <parameter>owner</parameter> is a string denoting a user name, + only views owned by <parameter>owner</parameter> are + examined. If <parameter>owner</parameter> is + <symbol>:all</symbol> then all views are examined. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(view-exists-p [lenins-group]) +=> T + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para> + None. + </para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para> + <symbol>*default-database*</symbol> + </para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para> + None. + </para> + </refsect1> + <refsect1> + <title>See Also</title> + <simplelist> + <member><link linkend="create-view"><function>create-view</function></link></member> + <member><link linkend="drop-view"><function>drop-view</function></link></member> + <member><link linkend="list-views"><function>list-views</function></link></member> + </simplelist> + </refsect1> + <refsect1> + <title>Notes</title> + <para> + <function>view-exists-p</function> is a &clsql; extension. + </para> + </refsect1> + </refentry> + + <refentry id="create-index"> + <refmeta> + <refentrytitle>CREATE-INDEX</refentrytitle> + </refmeta> + <refnamediv> + <refname>CREATE-INDEX</refname> + <refpurpose>Create a database index.</refpurpose> + <refclass>Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis> + <function>create-index</function> <replaceable>name</replaceable> &key <replaceable>on</replaceable> <replaceable>unique</replaceable> <replaceable>attributes</replaceable> <replaceable>database</replaceable> => <returnvalue></returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>name</parameter></term> + <listitem> + <para> + The name of the index as a string, symbol or SQL expression. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>on</parameter></term> + <listitem> + <para> + The name of a table as a string, symbol or SQL expression. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>unique</parameter></term> + <listitem> + <para> + A Boolean. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>attributes</parameter></term> + <listitem> + <para> + A list of attribute names. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>database</parameter></term> + <listitem> + <para> + A database object which defaults to + <symbol>*default-database*</symbol>. + </para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para>Creates an index called <parameter>name</parameter> on the + table specified by <parameter>on</parameter> in + <parameter>database</parameter> which default to + <symbol>*default-database*</symbol>. The table attributes to use + in constructing the index <parameter>name</parameter> are + specified by <parameter>attributes</parameter>. The + <parameter>unique</parameter> argument is &nil; by default but + if it has a non-&nil; value then the indexed attributes must + have unique values. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(create-index [bar] :on [employee] + :attributes '([first-name] [last-name] [email]) + :unique t) +=> + +(index-exists-p [bar]) +=> T + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para> + An index is created in <parameter>database</parameter>. + </para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para> + <symbol>*default-database*</symbol> + </para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para> + An error is signalled if <parameter>name</parameter> is not a + string, symbol or SQL expression. An error of type + <symbol>sql-database-data-error</symbol> is signalled if a + relation called <parameter>name</parameter> already exists. + </para> + </refsect1> + <refsect1> + <title>See Also</title> + <simplelist> + <member><link linkend="drop-index"><function>drop-index</function></link></member> + <member><link linkend="list-indexes"><function>list-indexes</function></link></member> + <member><link linkend="index-exists-p"><function>index-exists-p</function></link></member> + </simplelist> + </refsect1> + <refsect1> + <title>Notes</title> + <para> + None. + </para> + </refsect1> + </refentry> + + <refentry id="drop-index"> + <refmeta> + <refentrytitle>DROP-INDEX</refentrytitle> + </refmeta> + <refnamediv> + <refname>DROP-INDEX</refname> + <refpurpose>Drop a database index.</refpurpose> + <refclass>Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis> + <function>drop-index</function> <replaceable>name</replaceable> &key <replaceable>if-does-not-exist</replaceable> <replaceable>on</replaceable> <replaceable>database</replaceable> => <returnvalue></returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>name</parameter></term> + <listitem> + <para> + The name of the index as a string, symbol or SQL expression. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>on</parameter></term> + <listitem> + <para> + The name of a table as a string, symbol or SQL + expression. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>database</parameter></term> + <listitem> + <para> + A database object which defaults to + <symbol>*default-database*</symbol>. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>if-does-not-exist</parameter></term> + <listitem> + <para> + A symbol. Meaningful values are <symbol>:ignore</symbol> + or <symbol>:error</symbol> (the default). + </para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para>Drops the index called <parameter>name</parameter> in + <parameter>database</parameter> which defaults to + <symbol>*default-database*</symbol>. If the index does not exist + and <parameter>if-does-not-exist</parameter> is + <symbol>:ignore</symbol> then <parameter>drop-index</parameter> + returns &nil; whereas an error is signalled if + <parameter>if-does-not-exist</parameter> is + <symbol>:error</symbol>. + </para> + <para> + The argument <parameter>on</parameter> allows the optional + specification of a table to drop the index from. This is + required for compatability with MySQL. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(index-exists-p [foo]) +=> T +(drop-index [foo] :if-does-not-exist :ignore) +=> +(index-exists-p [foo]) +=> NIL + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para> + An index is dropped in <parameter>database</parameter>. + </para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para> + <symbol>*default-database*</symbol> + </para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para> + An error is signalled if <parameter>name</parameter> is not a + string, symbol or SQL expression. An error of type + <symbol>sql-database-data-error</symbol> is signalled if + <parameter>name</parameter> doesn't exist and + <parameter>if-does-not-exist</parameter> has a value of + <symbol>:error</symbol>. + </para> + </refsect1> + <refsect1> + <title>See Also</title> + <simplelist> + <member><link linkend="create-index"><function>create-index</function></link></member> + <member><link linkend="list-indexes"><function>list-indexes</function></link></member> + <member><link linkend="index-exists-p"><function>index-exists-p</function></link></member> + </simplelist> + </refsect1> + <refsect1> + <title>Notes</title> + <para> + The <parameter>if-does-not-exist</parameter> and + <parameter>on</parameter> keyword arguments to + <function>drop-index</function> are &clsql; extensions. The + keyword argument <parameter>on</parameter> is provided for + compatibility with MySQL. + </para> + </refsect1> + </refentry> + + <refentry id="list-indexes"> + <refmeta> + <refentrytitle>LIST-INDEXES</refentrytitle> + </refmeta> + <refnamediv> + <refname>LIST-INDEXES</refname> + <refpurpose>Returns a list of database indexes.</refpurpose> + <refclass>Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis> + <function>list-indexes</function> &key <replaceable>on</replaceable><replaceable>owner</replaceable> <replaceable>database</replaceable> => <returnvalue>result</returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>owner</parameter></term> + <listitem> + <para> + A string, &nil; or <symbol>:all</symbol>. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>database</parameter></term> + <listitem> + <para> + A database object which defaults to + <symbol>*default-database*</symbol>. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>on</parameter></term> + <listitem> + <para> + The name of a table as a string, symbol or SQL + expression, a list of such names or &nil;. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>result</parameter></term> + <listitem> + <para> + A list of strings. + </para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para>Returns a list of strings representing index names in + <parameter>database</parameter> which defaults to + <symbol>*default-database*</symbol>. <parameter>owner</parameter> + is &nil; by default which means that only indexes owned by users + are listed. If <parameter>owner</parameter> is a string denoting + a user name, only indexes owned by <parameter>owner</parameter> + are listed. If <parameter>owner</parameter> is + <symbol>:all</symbol> then all indexes are listed. + </para> + <para> + The keyword argument <parameter>on</parameter> limits the + results to indexes on the specified tables. Meaningful values + for <parameter>on</parameter> are &nil; (the default) which + means that all tables are considered, a string, symbol or SQL + expression representing a table name in + <parameter>database</parameter> or a list of such table + identifiers. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(list-indexes) +=> ("employeepk" "companypk" "addrpk" "bar") + +(list-indexes :on '([addr] [company])) +=> ("addrpk" "companypk") + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para> + None. + </para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para> + <symbol>*default-database*</symbol> + </para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para> + None. + </para> + </refsect1> + <refsect1> + <title>See Also</title> + <simplelist> + <member><link linkend="create-index"><function>create-index</function></link></member> + <member><link linkend="drop-index"><function>drop-index</function></link></member> + <member><link linkend="index-exists-p"><function>index-exists-p</function></link></member> + </simplelist> + </refsect1> + <refsect1> + <title>Notes</title> + <para> + <function>list-indexes</function> is a &clsql; extension. + </para> + </refsect1> + </refentry> + + <refentry id="index-exists-p"> + <refmeta> + <refentrytitle>INDEX-EXISTS-P</refentrytitle> + </refmeta> + <refnamediv> + <refname>INDEX-EXISTS-</refname> + <refpurpose>Tests for the existence of a database index.</refpurpose> + <refclass>Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis> + <function>index-exists-p</function> <replaceable>name</replaceable> &key <replaceable>owner</replaceable> <replaceable>database</replaceable> => <returnvalue>result</returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>name</parameter></term> + <listitem> + <para> + The name of the index as a string, symbol or SQL expression. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>owner</parameter></term> + <listitem> + <para> + A string, &nil; or <symbol>:all</symbol>. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>database</parameter></term> + <listitem> + <para> + A database object which defaults to + <symbol>*default-database*</symbol>. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>result</parameter></term> + <listitem> + <para> + A Boolean. + </para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para>Tests for the existence of an SQL index called + <parameter>name</parameter> in <parameter>database</parameter> + which defaults to + <symbol>*default-database*</symbol>. <parameter>owner</parameter> + is &nil; by default which means that only indexes owned by users + are examined. If <parameter>owner</parameter> is a string + denoting a user name, only indexes owned by + <parameter>owner</parameter> are examined. If + <parameter>owner</parameter> is <symbol>:all</symbol> then all + indexes are examined. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(index-exists-p [bar]) +=> T + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para> + None. + </para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para> + <symbol>*default-database*</symbol> + </para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para> + None. + </para> + </refsect1> + <refsect1> + <title>See Also</title> + <simplelist> + <member><link linkend="create-index"><function>create-index</function></link></member> + <member><link linkend="drop-index"><function>drop-index</function></link></member> + <member><link linkend="list-indexes"><function>list-indexes</function></link></member> + </simplelist> + </refsect1> + <refsect1> + <title>Notes</title> + <para> + <function>index-exists-p</function> is a &clsql; extension. + </para> + </refsect1> + </refentry> + + <refentry id="attribute-type"> + <refmeta> + <refentrytitle>ATTRIBUTE-TYPE</refentrytitle> + </refmeta> + <refnamediv> + <refname>ATTRIBUTE-TYPE</refname> + <refpurpose>Returns the type of the supplied attribute.</refpurpose> + <refclass>Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis> + <function>attribute-type attribute</function> <replaceable>table</replaceable> &key <replaceable>owner</replaceable> <replaceable>database</replaceable> => <returnvalue>type</returnvalue>, <returnvalue>precision</returnvalue>, <returnvalue>scale</returnvalue>, <returnvalue>nulls-accepted</returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>attribute</parameter></term> + <listitem> + <para> + The name of the index as a string, symbol or SQL expression. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>table</parameter></term> + <listitem> + <para> + The name of a table as a string, symbol or SQL expression. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>owner</parameter></term> + <listitem> + <para> + A string, &nil; or <symbol>:all</symbol>. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>database</parameter></term> + <listitem> + <para> + A database object which defaults to + <symbol>*default-database*</symbol>. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>type</parameter></term> + <listitem> + <para> + A keyword symbol denoting a vendor-specific SQL type. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>precision</parameter></term> + <listitem> + <para> + An integer denoting the precision of the attribute type + or &nil;. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>scale</parameter></term> + <listitem> + <para> + An integer denoting the scale of the attribute type + or &nil;. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>nulls-accepted</parameter></term> + <listitem> + <para> + 0 or 1. + </para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para>Returns a keyword symbol representing the vendor-specific + field type of the supplied attribute + <parameter>attribute</parameter> in the table specified by + <parameter>table</parameter> in <parameter>database</parameter> + which defaults to + <symbol>*default-database*</symbol>. <parameter>owner</parameter> + is &nil; by default which means that the attribute specified by + <parameter>attribute</parameter>, if it exists, must be user + owned else &nil; is returned. If <parameter>owner</parameter> is + a string denoting a user name, the attribute, if it exists, must + be owned by <parameter>owner</parameter> else &nil; is returned, + whereas if <parameter>owner</parameter> is <symbol>:all</symbol> + then the attribute, if it exists, will be returned regardless of + its owner. + </para> + + <para>Other information is also returned. The second value is + the type precision, the third is the scale and the fourth + represents whether or not the attribute accepts null values (a + value of 0) or not (a value of 1). + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(attribute-type [emplid] [employee]) +=> :INT4, 4, NIL, 0 + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para> + None. + </para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para> + <symbol>*default-database*</symbol> + </para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para> + None. + </para> + </refsect1> + <refsect1> + <title>See Also</title> + <simplelist> + <member><link linkend="list-attributes"><function>list-attributes</function></link></member> + <member><link linkend="list-attribute-types"><function>list-attribute-types</function></link></member> + </simplelist> + </refsect1> + <refsect1> + <title>Notes</title> + <para> + None. + </para> + </refsect1> + </refentry> + + <refentry id="list-attribute-types"> + <refmeta> + <refentrytitle>LIST-ATTRIBUTE-TYPES</refentrytitle> + </refmeta> + <refnamediv> + <refname>LIST-ATTRIBUTE-TYPES</refname> + <refpurpose>Returns information about the attribute types of a table.</refpurpose> + <refclass>Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis> + <function>list-attribute-types</function> <replaceable>table</replaceable> &key <replaceable>owner</replaceable> <replaceable>database</replaceable> => <returnvalue>result</returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>table</parameter></term> + <listitem> + <para> + The name of a table as a string, symbol or SQL expression. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>owner</parameter></term> + <listitem> + <para> + A string, &nil; or <symbol>:all</symbol>. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>database</parameter></term> + <listitem> + <para> + A database object which defaults to + <symbol>*default-database*</symbol>. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>result</parameter></term> + <listitem> + <para> + A list. + </para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para>Returns a list containing information about the SQL types + of each of the attributes in the table specified by + <parameter>table</parameter> in <parameter>database</parameter> + which has a default value of + <symbol>*default-database*</symbol>. <parameter>owner</parameter> + is &nil; by default which means that only attributes owned by + users are listed. If <parameter>owner</parameter> is a string + denoting a user name, only attributes owned by + <parameter>owner</parameter> are listed. If + <parameter>owner</parameter> is <symbol>:all</symbol> then all + attributes are listed. The elements of the returned list are + lists where the first element is the name of the attribute, the + second element is its SQL type, the third is the type precision, + the fourth is the scale of the attribute and the fifth is 1 if + the attribute accepts null values and otherwise 0. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(list-attribute-types [employee]) +=> (("emplid" :INT4 4 NIL 0) ("groupid" :INT4 4 NIL 0) + ("first_name" :VARCHAR 30 NIL 1) ("last_name" :VARCHAR 30 NIL 1) + ("email" :VARCHAR 100 NIL 1) ("ecompanyid" :INT4 4 NIL 1) + ("managerid" :INT4 4 NIL 1) ("height" :FLOAT8 8 NIL 1) + ("married" :BOOL 1 NIL 1) ("birthday" :TIMESTAMP 8 NIL 1) + ("bd_utime" :INT8 8 NIL 1)) + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para> + None. + </para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para> + <symbol>*default-database*</symbol> + </para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para> + None. + </para> + </refsect1> + <refsect1> + <title>See Also</title> + <simplelist> + <member><link linkend="attribute-type"><function>attribute-type</function></link></member> + <member><link linkend="list-attribute-types"><function>list-attribute-types</function></link></member> + </simplelist> + </refsect1> + <refsect1> + <title>Notes</title> + <para> + None. + </para> + </refsect1> + </refentry> + + <refentry id="list-attributes"> + <refmeta> + <refentrytitle>LIST-ATTRIBUTES</refentrytitle> + </refmeta> + <refnamediv> + <refname>LIST-ATTRIBUTES</refname> + <refpurpose>Returns the attributes of a table as a list.</refpurpose> + <refclass>Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis> + <function>list-attributes</function> <replaceable>name</replaceable> &key <replaceable>owner</replaceable> <replaceable>database</replaceable> => <returnvalue>result</returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>name</parameter></term> + <listitem> + <para> + The name of a table as a string, symbol or SQL expression. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>owner</parameter></term> + <listitem> + <para> + A string, &nil; or <symbol>:all</symbol>. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>database</parameter></term> + <listitem> + <para> + A database object which defaults to + <symbol>*default-database*</symbol>. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>result</parameter></term> + <listitem> + <para> + A list. + </para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para>Returns a list of strings representing the attributes of + table <parameter>name</parameter> in + <parameter>database</parameter> which defaults to + <symbol>*default-database*</symbol>. <parameter>owner</parameter> + is &nil; by default which means that only attributes owned by + users are listed. If <parameter>owner</parameter> is a string + denoting a user name, only attributes owned by + <parameter>owner</parameter> are listed. If + <parameter>owner</parameter> is <symbol>:all</symbol> then all + attributes are listed. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(list-attributes [employee]) +=> ("emplid" "groupid" "first_name" "last_name" "email" "ecompanyid" "managerid" + "height" "married" "birthday" "bd_utime") + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para> + None. + </para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para> + <symbol>*default-database*</symbol> + </para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para> + None. + </para> + </refsect1> + <refsect1> + <title>See Also</title> + <simplelist> + <member><link linkend="attribute-type"><function>attribute-type</function></link></member> + <member><link linkend="list-attribute-types"><function>list-attribute-types</function></link></member> + </simplelist> + </refsect1> + <refsect1> + <title>Notes</title> + <para> + None. + </para> + </refsect1> + </refentry> + + <refentry id="create-sequence"> + <refmeta> + <refentrytitle>CREATE-SEQUENCE</refentrytitle> + </refmeta> + <refnamediv> + <refname>CREATE-SEQUENCE</refname> + <refpurpose>Create a database sequence.</refpurpose> + <refclass>Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis> + <function>create-sequence</function> <replaceable>name</replaceable> &key <replaceable>database</replaceable> => <returnvalue></returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>name</parameter></term> + <listitem> + <para> + The name of the sequence as a string, symbol or SQL expression. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>database</parameter></term> + <listitem> + <para> + A database object which defaults to + <symbol>*default-database*</symbol>. + </para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para>Creates a sequence called <parameter>name</parameter> in + <parameter>database</parameter> which defaults to + <symbol>*default-database*</symbol>. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(create-sequence [foo]) +=> +(sequence-exists-p [foo]) +=> T + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para> + A sequence is created in <parameter>database</parameter>. + </para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para> + <symbol>*default-database*</symbol> + </para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para> + An error is signalled if <parameter>name</parameter> is not a + string, symbol or SQL expression. An error of type + <symbol>sql-database-data-error</symbol> is signalled if a + relation called <parameter>name</parameter> already exists. + </para> + </refsect1> + <refsect1> + <title>See Also</title> + <simplelist> + <member><link linkend="drop-sequence"><function>drop-sequence</function></link></member> + <member><link linkend="list-sequences"><function>list-sequences</function></link></member> + <member><link linkend="sequence-exists-p"><function>sequence-exists-p</function></link></member> + <member><link linkend="sequence-last"><function>sequence-last</function></link></member> + <member><link linkend="sequence-next"><function>sequence-next</function></link></member> + <member><link linkend="set-sequence-position"><function>set-sequence-position</function></link></member> + </simplelist> + </refsect1> + <refsect1> + <title>Notes</title> + <para> + <function>create-sequence</function> is a &clsql; extension. + </para> + </refsect1> + </refentry> + + <refentry id="drop-sequence"> + <refmeta> + <refentrytitle>DROP-SEQUENCE</refentrytitle> + </refmeta> + <refnamediv> + <refname>DROP-SEQUENCE</refname> + <refpurpose>Drop a database sequence.</refpurpose> + <refclass>Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis> + <function>drop-sequence</function> <replaceable>name</replaceable> &key <replaceable>if-does-not-exist</replaceable> <replaceable>database</replaceable> => <returnvalue></returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>name</parameter></term> + <listitem> + <para> + The name of the sequence as a string, symbol or SQL expression. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>database</parameter></term> + <listitem> + <para> + A database object which defaults to + <symbol>*default-database*</symbol>. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>if-does-not-exist</parameter></term> + <listitem> + <para> + A symbol. Meaningful values are <symbol>:ignore</symbol> + or <symbol>:error</symbol> (the default). + </para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para>Drops the sequence called <parameter>name</parameter> from + <parameter>database</parameter> which defaults to + <symbol>*default-database*</symbol>. If the sequence does not + exist and <parameter>if-does-not-exist</parameter> is + <symbol>:ignore</symbol> then + <parameter>drop-sequence</parameter> returns &nil; whereas an + error is signalled if <parameter>if-does-not-exist</parameter> + is <symbol>:error</symbol>. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(sequence-exists-p [foo]) +=> T +(drop-sequence [foo] :if-does-not-exist :ignore) +=> +(sequence-exists-p [foo]) +=> NIL + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para> + A sequence is dropped from <parameter>database</parameter>. + </para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para> + <symbol>*default-database*</symbol> + </para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para> + An error is signalled if <parameter>name</parameter> is not a + string, symbol or SQL expression. An error of type + <symbol>sql-database-data-error</symbol> is signalled if + <parameter>name</parameter> doesn't exist and + <parameter>if-does-not-exist</parameter> has a value of + <symbol>:error</symbol>. + </para> + </refsect1> + <refsect1> + <title>See Also</title> + <simplelist> + <member><link linkend="create-sequence"><function>create-sequence</function></link></member> + <member><link linkend="list-sequences"><function>list-sequences</function></link></member> + <member><link linkend="sequence-exists-p"><function>sequence-exists-p</function></link></member> + <member><link linkend="sequence-last"><function>sequence-last</function></link></member> + <member><link linkend="sequence-next"><function>sequence-next</function></link></member> + <member><link linkend="set-sequence-position"><function>set-sequence-position</function></link></member> + </simplelist> + </refsect1> + <refsect1> + <title>Notes</title> + <para> + <function>drop-sequence</function> is a &clsql; extension. + </para> + </refsect1> + </refentry> + + <refentry id="list-sequences"> + <refmeta> + <refentrytitle>LIST-SEQUENCES</refentrytitle> + </refmeta> + <refnamediv> + <refname>LIST-SEQUENCES</refname> + <refpurpose>Returns a list of database sequences.</refpurpose> + <refclass>Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis> + <function>list-sequences</function> &key <replaceable>owner</replaceable> <replaceable>database</replaceable> => <returnvalue>result</returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>owner</parameter></term> + <listitem> + <para> + A string, &nil; or <symbol>:all</symbol>. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>database</parameter></term> + <listitem> + <para> + A database object which defaults to + <symbol>*default-database*</symbol>. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>result</parameter></term> + <listitem> + <para> + A list of strings. + </para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para>Returns a list of strings representing sequence names in + <parameter>database</parameter> which defaults to + <symbol>*default-database*</symbol>. <parameter>owner</parameter> + is &nil; by default which means that only sequences owned by + users are listed. If <parameter>owner</parameter> is a string + denoting a user name, only sequences owned by + <parameter>owner</parameter> are listed. If + <parameter>owner</parameter> is <symbol>:all</symbol> then all + sequences are listed. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(list-sequences) +=> ("foo") + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para> + None. + </para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para> + <symbol>*default-database*</symbol> + </para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para> + None. + </para> + </refsect1> + <refsect1> + <title>See Also</title> + <simplelist> + <member><link linkend="create-sequence"><function>create-sequence</function></link></member> + <member><link linkend="drop-sequence"><function>drop-sequence</function></link></member> + <member><link linkend="sequence-exists-p"><function>sequence-exists-p</function></link></member> + <member><link linkend="sequence-last"><function>sequence-last</function></link></member> + <member><link linkend="sequence-next"><function>sequence-next</function></link></member> + <member><link linkend="set-sequence-position"><function>set-sequence-position</function></link></member> + </simplelist> + </refsect1> + <refsect1> + <title>Notes</title> + <para> + <function>list-sequences</function> is a &clsql; extension. + </para> + </refsect1> + </refentry> + + <refentry id="sequence-exists-p"> + <refmeta> + <refentrytitle>SEQUENCE-EXISTS-P</refentrytitle> + </refmeta> + <refnamediv> + <refname>SEQUENCE-EXISTS-P</refname> + <refpurpose>Tests for the existence of a database sequence.</refpurpose> + <refclass>Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis> + <function>sequence-exists-p</function> <replaceable>name</replaceable> &key <replaceable>owner</replaceable> <replaceable>database</replaceable> => <returnvalue>result</returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>name</parameter></term> + <listitem> + <para> + The name of the sequence as a string, symbol or SQL expression. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>owner</parameter></term> + <listitem> + <para> + A string, &nil; or <symbol>:all</symbol>. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>database</parameter></term> + <listitem> + <para> + A database object which defaults to + <symbol>*default-database*</symbol>. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>result</parameter></term> + <listitem> + <para> + A Boolean. + </para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para>Tests for the existence of an SQL sequence called + <parameter>name</parameter> in <parameter>database</parameter> + which defaults to + <symbol>*default-database*</symbol>. <parameter>owner</parameter> + is &nil; by default which means that only sequences owned by + users are examined. If <parameter>owner</parameter> is a string + denoting a user name, only sequences owned by + <parameter>owner</parameter> are examined. If + <parameter>owner</parameter> is <symbol>:all</symbol> then all + sequences are examined. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(sequence-exists-p [foo]) +=> NIL + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para> + None. + </para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para> + <symbol>*default-database*</symbol> + </para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para> + None. + </para> + </refsect1> + <refsect1> + <title>See Also</title> + <simplelist> + <member><link linkend="create-sequence"><function>create-sequence</function></link></member> + <member><link linkend="drop-sequence"><function>drop-sequence</function></link></member> + <member><link linkend="list-sequences"><function>list-sequences</function></link></member> + <member><link linkend="sequence-last"><function>sequence-last</function></link></member> + <member><link linkend="sequence-next"><function>sequence-next</function></link></member> + <member><link linkend="set-sequence-position"><function>set-sequence-position</function></link></member> + </simplelist> + </refsect1> + <refsect1> + <title>Notes</title> + <para> + <function>sequence-exists-p</function> is a &clsql; extension. + </para> + </refsect1> + </refentry> + + <refentry id="sequence-last"> + <refmeta> + <refentrytitle>SEQUENCE-LAST</refentrytitle> + </refmeta> + <refnamediv> + <refname>SEQUENCE-LAST</refname> + <refpurpose>Return the last element in a database sequence.</refpurpose> + <refclass>Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis> + <function>sequence-last</function> <replaceable>name</replaceable> &key <replaceable>database</replaceable> => <returnvalue>result</returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>name</parameter></term> + <listitem> + <para> + The name of the sequence as a string, symbol or SQL expression. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>database</parameter></term> + <listitem> + <para> + A database object which defaults to + <symbol>*default-database*</symbol>. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>result</parameter></term> + <listitem> + <para> + An integer. + </para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para>Return the last value allocated in the sequence called + <parameter>name</parameter> in <parameter>database</parameter> + which defaults to <symbol>*default-database*</symbol>. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(sequence-last [foo]) +=> 1 + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para> + None. + </para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para> + The current value stored in database sequence + <parameter>name</parameter>. + </para> + <para> + <symbol>*default-database*</symbol> + </para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para> + Will signal an error of type + <symbol>sql-database-data-error</symbol> if a sequence called + <parameter>name</parameter> does not exist in + <parameter>database</parameter>. + </para> + </refsect1> + <refsect1> + <title>See Also</title> + <simplelist> + <member><link linkend="create-sequence"><function>create-sequence</function></link></member> + <member><link linkend="drop-sequence"><function>drop-sequence</function></link></member> + <member><link linkend="list-sequences"><function>list-sequences</function></link></member> + <member><link linkend="sequence-exists-p"><function>sequence-exists-p</function></link></member> + <member><link linkend="sequence-next"><function>sequence-next</function></link></member> + <member><link linkend="set-sequence-position"><function>set-sequence-position</function></link></member> + </simplelist> + </refsect1> + <refsect1> + <title>Notes</title> + <para> + <function>sequence-last</function> is a &clsql; extension. + </para> + </refsect1> + </refentry> + + <refentry id="sequence-next"> + <refmeta> + <refentrytitle>SEQUENCE-NEXT</refentrytitle> + </refmeta> + <refnamediv> + <refname>SEQUENCE-NEXT</refname> + <refpurpose>Increment the value of a database sequence.</refpurpose> + <refclass>Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis> + <function>sequence-next</function> <replaceable>name</replaceable> &key <replaceable>database</replaceable> => <returnvalue>result</returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>name</parameter></term> + <listitem> + <para> + The name of the sequence as a string, symbol or SQL expression. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>database</parameter></term> + <listitem> + <para> + A database object which defaults to + <symbol>*default-database*</symbol>. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>result</parameter></term> + <listitem> + <para> + An integer. + </para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para>Increment and return the value of the sequence called + <parameter>name</parameter> in <parameter>database</parameter> + which defaults to <symbol>*default-database*</symbol>. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(sequence-last [foo]) +=> 3 +(sequence-next [foo]) +=> 4 +(sequence-next [foo]) +=> 5 +(sequence-next [foo]) +=> 6 + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para> + Modifies the value of the sequence <parameter>name</parameter> + in <parameter>database</parameter>. + </para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para> + The current value stored in database sequence + <parameter>name</parameter>. + </para> + <para> + <symbol>*default-database*</symbol> + </para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para> + Will signal an error of type + <symbol>sql-database-data-error</symbol> if a sequence called + <parameter>name</parameter> does not exist in + <parameter>database</parameter>. + </para> + </refsect1> + <refsect1> + <title>See Also</title> + <simplelist> + <member><link linkend="create-sequence"><function>create-sequence</function></link></member> + <member><link linkend="drop-sequence"><function>drop-sequence</function></link></member> + <member><link linkend="list-sequences"><function>list-sequences</function></link></member> + <member><link linkend="sequence-exists-p"><function>sequence-exists-p</function></link></member> + <member><link linkend="sequence-last"><function>sequence-last</function></link></member> + <member><link linkend="set-sequence-position"><function>set-sequence-position</function></link></member> + </simplelist> + </refsect1> + <refsect1> + <title>Notes</title> + <para> + <function>sequence-next</function> is a &clsql; extension. + </para> + </refsect1> + </refentry> + + <refentry id="set-sequence-position"> + <refmeta> + <refentrytitle>SET-SEQUENCE-POSITION</refentrytitle> + </refmeta> + <refnamediv> + <refname>SET-SEQUENCE-POSITION</refname> + <refpurpose>Sets the position of a database sequence.</refpurpose> + <refclass>Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis> + <function>set-sequence-position</function> <replaceable>name</replaceable> <replaceable>position</replaceable> &key <replaceable>database</replaceable> => <returnvalue>result</returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>name</parameter></term> + <listitem> + <para> + The name of the sequence as a string, symbol or SQL expression. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>position</parameter></term> + <listitem> + <para> + An integer. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>database</parameter></term> + <listitem> + <para> + A database object which defaults to + <symbol>*default-database*</symbol>. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>result</parameter></term> + <listitem> + <para> + An integer. + </para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para>Explicitly set the position of the sequence called + <parameter>name</parameter> in <parameter>database</parameter>, + which defaults to <symbol>*default-database*</symbol>, to + <parameter>position</parameter> which is returned. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(sequence-last [foo]) +=> 4 +(set-sequence-position [foo] 50) +=> 50 +(sequence-next [foo]) +=> 51 + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para> + Modifies the value of the sequence <parameter>name</parameter> + in <parameter>database</parameter>. + </para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para> + <symbol>*default-database*</symbol> + </para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para> + Will signal an error of type + <symbol>sql-database-data-error</symbol> if a sequence called + <parameter>name</parameter> does not exist in + <parameter>database</parameter>. + </para> + </refsect1> + <refsect1> + <title>See Also</title> + <simplelist> + <member><link linkend="create-sequence"><function>create-sequence</function></link></member> + <member><link linkend="drop-sequence"><function>drop-sequence</function></link></member> + <member><link linkend="list-sequences"><function>list-sequences</function></link></member> + <member><link linkend="sequence-exists-p"><function>sequence-exists-p</function></link></member> + <member><link linkend="sequence-last"><function>sequence-last</function></link></member> + <member><link linkend="sequence-next"><function>sequence-next</function></link></member> + </simplelist> + </refsect1> + <refsect1> + <title>Notes</title> + <para> + <function>set-sequence-position</function> is a &clsql; extension. + </para> + </refsect1> + </refentry> + + <refentry id="truncate-database"> + <refmeta> + <refentrytitle>TRUNCATE-DATABASE</refentrytitle> + </refmeta> + <refnamediv> + <refname>TRUNCATE-DATABASE</refname> + <refpurpose>Drop all tables, views, indexes and sequences in a database.</refpurpose> + <refclass>Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis> + <function>truncate-database</function> &key <replaceable>database</replaceable> => <returnvalue></returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>database</parameter></term> + <listitem> + <para>A + <glossterm linkend="gloss-database-object">database + object</glossterm>. This will default to the value + of <symbol>*default-database*</symbol>.</para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para> + Drop all tables, views, indexes and sequences in + <parameter>database</parameter> which defaults to + <symbol>*default-database*</symbol>. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(list-tables) +=> ("type_table" "type_bigint" "employee" "company" "addr" "ea_join" "big") +(list-indexes) +=> ("employeepk" "companypk" "addrpk") +(list-views) +=> ("lenins_group") +(list-sequences) +=> ("foo" "bar") +(truncate-database) +=> +(list-tables) +=> NIL +(list-indexes) +=> NIL +(list-views) +=> NIL +(list-sequences) +=> NIL + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para> + Modifications are made to the underlying database. + </para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para> + None. + </para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para> + Signals an error of type <symbol>sql-database-error</symbol> if + <parameter>database</parameter> is not a database object. + </para> + </refsect1> + <refsect1> + <title>See Also</title> + <para> + <simplelist> + <member><link linkend="drop-table"><function>drop-table</function></link></member> + <member><link linkend="drop-view"><function>drop-view</function></link></member> + <member><link linkend="drop-index"><function>drop-index</function></link></member> + <member><link linkend="drop-sequence"><function>drop-sequence</function></link></member> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Notes</title> + <para> + <function>truncate-database</function> is a &clsql; extension. + </para> + </refsect1> + </refentry> + +</reference> diff --git a/doc/ref-fdml.xml b/doc/ref-fdml.xml new file mode 100644 index 0000000..7113b6a --- /dev/null +++ b/doc/ref-fdml.xml @@ -0,0 +1,2116 @@ +<?xml version='1.0' ?> +<!DOCTYPE book PUBLIC "-//OASIS//DTD DocBook XML V4.2//EN" +"http://www.oasis-open.org/docbook/xml/4.2/docbookx.dtd" [ +<!ENTITY % myents SYSTEM "entities.inc"> +%myents; +]> + +<!-- Functional Data Manipulation Language --> +<reference id="ref-fdml"> + <title>Functional Data Manipulation Language (FDML)</title> + <partintro> + <para> + The functional data manipulation interface provided by &clsql; + includes functions for inserting, updating and deleting records + in existing database tables and executing SQL queries and + statements with the results of queries returned as Lisp types. + SQL statements expressed as strings may be executed with the + <link linkend="query"><function>query</function></link> and + <link + linkend="execute-command"><function>execute-command</function></link> + functions. The <link + linkend="select"><function>select</function></link> function, on + the other hand, allows for the construction of queries in Lisp + using the symbolic SQL syntax. Finally, iterative manipulation + of query results is supported by <link + linkend="do-query"><function>do-query</function></link>, <link + linkend="map-query"><function>map-query</function></link> and an + extended clause for the <link + linkend="loop-tuples"><function>loop</function></link> macro. + </para> + </partintro> + + <!-- Caching table queries --> + + <refentry id="cache-table-queries-default"> + <refmeta> + <refentrytitle>*CACHE-TABLE-QUERIES-DEFAULT*</refentrytitle> + </refmeta> + <refnamediv> + <refname>*CACHE-TABLE-QUERIES-DEFAULT*</refname> + <refpurpose>Specifies the default behaviour for caching of + attribute types.</refpurpose> + <refclass>Variable</refclass> + </refnamediv> + <refsect1> + <title>Value Type</title> + <para> + A valid argument to the <parameter>action</parameter> + parameter of <function>cache-table-queries</function>, + i.e. one of + <simplelist type="inline"> + <member>&t;</member> + <member>&nil;</member> + <member><symbol>:flush</symbol></member> + </simplelist>. + </para> + </refsect1> + <refsect1> + <title>Initial Value</title> + <para><symbol>nil</symbol></para> + </refsect1> + <refsect1> + <title>Description</title> + <para> + Specifies the default behaivour for caching of attribute + types. Meaningful values are &t;, &nil; and + <symbol>:flush</symbol> as described for the + <parameter>action</parameter> argument to + <function>cache-table-queries</function>. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>Affected By</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>See Also</title> + <simplelist> + <member><link linkend="cache-table-queries"><function>cache-table-queries</function></link></member> + </simplelist> + </refsect1> + <refsect1> + <title>Notes</title> + <para>None.</para> + </refsect1> + </refentry> + + <refentry id="cache-table-queries"> + <refmeta> + <refentrytitle>CACHE-TABLE-QUERIES</refentrytitle> + </refmeta> + <refnamediv> + <refname>CACHE-TABLE-QUERIES</refname> + <refpurpose>Control the caching of table attribute types.</refpurpose> + <refclass>Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis> + <function>cache-table-queries</function> <replaceable>table</replaceable> &key <replaceable>action</replaceable> <replaceable>database</replaceable> => <returnvalue></returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>table</parameter></term> + <listitem> + <para> + A string representing a database table, &t; or + <symbol>:default</symbol>. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>action</parameter></term> + <listitem> + <para> + &t;, &nil; or <symbol>:flush</symbol>. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>database</parameter></term> + <listitem> + <para>A + <glossterm linkend="gloss-database-object">database + object</glossterm>. This will default to the value + of <symbol>*default-database*</symbol>.</para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para>Controls the caching of attribute type information on the + table specified by <parameter>table</parameter> in + <parameter>database</parameter> which defaults to + <symbol>*default-database*</symbol>. <parameter>action</parameter> + specifies the caching behaviour to adopt. If its value is &t; + then attribute type information is cached whereas if its value + is &nil; then attribute type information is not cached. If + <parameter>action</parameter> is <symbol>:flush</symbol> then + all existing type information in the cache for + <parameter>table</parameter> is removed, but caching is still + enabled. <parameter>table</parameter> may be a string + representing a table for which the caching action is to be taken + while the caching action is applied to all tables if + <parameter>table</parameter> is &t;. Alternatively, when + <parameter>table</parameter> is <symbol>:default</symbol>, the + default caching action specified by + <symbol>*cache-table-queries-default*</symbol> is applied to all + tables for which a caching action has not been explicitly set. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(setf *cache-table-queries-default* t) +=> T +(create-table [foo] + '(([id] integer) + ([height] float) + ([name] (string 24)) + ([comments] varchar))) +=> +(cache-table-queries "foo") +=> +(list-attribute-types "foo") +=> (("id" :INT4 4 NIL 1) ("height" :FLOAT8 8 NIL 1) ("name" :BPCHAR 24 NIL 1) + ("comments" :VARCHAR 255 NIL 1)) +(drop-table "foo") +=> +(create-table [foo] + '(([id] integer) + ([height] float) + ([name] (string 36)) + ([comments] (string 100)))) +=> +(cache-table-queries "foo" :action :flush) +=> +(list-attribute-types "foo") +=> (("id" :INT4 4 NIL 1) ("height" :FLOAT8 8 NIL 1) ("name" :BPCHAR 36 NIL 1) + ("comments" :BPCHAR 100 NIL 1)) + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para> + The internal attribute cache for + <parameter>database</parameter> is modified. + </para> + </refsect1> + <refsect1> + <title>Affected by</title> + <simplelist> + <member><link linkend="cache-table-queries-default"><symbol>*cache-table-queries-default*</symbol></link></member> + </simplelist> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para> + None. + </para> + </refsect1> + <refsect1> + <title>See Also</title> + <simplelist> + <member><link linkend="cache-table-queries-default"><symbol>*cache-table-queries-default*</symbol></link></member> + </simplelist> + </refsect1> + <refsect1> + <title>Notes</title> + <para> + None. + </para> + </refsect1> + </refentry> + + <refentry id="insert-records"> + <refmeta> + <refentrytitle>INSERT-RECORDS</refentrytitle> + </refmeta> + <refnamediv> + <refname>INSERT-RECORDS</refname> + <refpurpose>Insert tuples of data into a database table.</refpurpose> + <refclass>Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis> + <function>insert-records</function> &key <replaceable>into</replaceable> <replaceable>attributes</replaceable> <replaceable>values</replaceable> <replaceable>av-pairs</replaceable> <replaceable>query</replaceable> <replaceable>database</replaceable> => <returnvalue></returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>into</parameter></term> + <listitem> + <para> + A string, symbol or symbolic SQL expression representing + the name of a table existing in + <parameter>database</parameter>. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>attributes</parameter></term> + <listitem> + <para> + A list of attribute identifiers or &nil;. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>values</parameter></term> + <listitem> + <para> + A list of attribute values or &nil;. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>av-pairs</parameter></term> + <listitem> + <para> + A list of attribute identifier/value pairs or &nil;. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>query</parameter></term> + <listitem> + <para> + A query expression or &nil;. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>database</parameter></term> + <listitem> + <para>A + <glossterm linkend="gloss-database-object">database + object</glossterm>. This will default to the value + of <symbol>*default-database*</symbol>.</para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para> + Inserts records into the table specified by + <parameter>into</parameter> in <parameter>database</parameter> + which defaults to <symbol>*default-database*</symbol>. + </para> + <para> + There are five ways of specifying the values inserted into + each row. In the first <parameter>values</parameter> contains + a list of values to insert and + <parameter>attributes</parameter>, + <parameter>av-pairs</parameter> and + <parameter>query</parameter> are &nil;. This can be used when + values are supplied for all attributes in + <parameter>into</parameter>. In the second, + <parameter>attributes</parameter> is a list of column names, + <parameter>values</parameter> is a corresponding list of + values and <parameter>av-pairs</parameter> and + <parameter>query</parameter> are &nil;. In the third, + <parameter>attributes</parameter>, + <parameter>values</parameter> and <parameter>query</parameter> + are &nil; and <parameter>av-pairs</parameter> is an alist of + (attribute value) pairs. In the fourth, + <parameter>values</parameter>, <parameter>av-pairs</parameter> + and <parameter>attributes</parameter> are &nil; and + <parameter>query</parameter> is a symbolic SQL query + expression in which the selected columns also exist in + <parameter>into</parameter>. In the fifth method, + <parameter>values</parameter> and + <parameter>av-pairs</parameter> are nil and + <parameter>attributes</parameter> is a list of column names + and <parameter>query</parameter> is a symbolic SQL query + expression which returns values for the specified columns. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(select [first-name] [last-name] [email] + :from [employee] + :where [= [emplid] 11] + :field-names nil) +=> NIL +(insert-records :into [employee] + :attributes '(emplid groupid first_name last_name email + ecompanyid managerid) + :values '(11 1 "Yuri" "Gagarin" "gagarin@soviet.org" + 1 1)) +=> +(select [first-name] [last-name] [email] + :from [employee] + :where [= [emplid] 11] + :field-names nil) +=> (("Yuri" "Gagarin" "gagarin@soviet.org")) + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para> + Modifications are made to the underlying database. + </para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para> + None. + </para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para> + An error of type <symbol>sql-database-data-error</symbol> is + signalled if <parameter>table</parameter> is not an existing + table in <parameter>database</parameter> or if the specified + attributes are not found. + </para> + </refsect1> + <refsect1> + <title>See Also</title> + <simplelist> + <member><link linkend="update-records"><function>update-records</function></link></member> + <member><link linkend="delete-records"><function>delete-records</function></link></member> + </simplelist> + </refsect1> + <refsect1> + <title>Notes</title> + <para> + None. + </para> + </refsect1> + </refentry> + + <refentry id="update-records"> + <refmeta> + <refentrytitle>UPDATE-RECORDS</refentrytitle> + </refmeta> + <refnamediv> + <refname>UPDATE-RECORDS</refname> + <refpurpose>Updates the values of existing records.</refpurpose> + <refclass>Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis> + <function>update-records</function> <replaceable>table</replaceable> &key <replaceable>attributes</replaceable> <replaceable>values</replaceable> <replaceable>av-pairs</replaceable> <replaceable>where</replaceable> <replaceable>database</replaceable> => <returnvalue></returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>table</parameter></term> + <listitem> + <para> + A string, symbol or symbolic SQL expression representing + the name of a table existing in + <parameter>database</parameter>. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>attributes</parameter></term> + <listitem> + <para> + A list of attribute identifiers or &nil;. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>values</parameter></term> + <listitem> + <para> + A list of attribute values or &nil;. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>av-pairs</parameter></term> + <listitem> + <para> + A list of attribute identifier/value pairs or &nil;. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>where</parameter></term> + <listitem> + <para> + A symbolic SQL expression. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>database</parameter></term> + <listitem> + <para>A + <glossterm linkend="gloss-database-object">database + object</glossterm>. This will default to the value + of <symbol>*default-database*</symbol>.</para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para> + Updates the attribute values of existing records satsifying + the SQL expression <parameter>where</parameter> in the table + specified by <parameter>table</parameter> in + <parameter>database</parameter> which defaults to + <symbol>*default-database*</symbol>. + </para> + <para> + There are three ways of specifying the values to update for + each row. In the first, <parameter>values</parameter> contains + a list of values to use in the update and + <parameter>attributes</parameter> and + <parameter>av-pairs</parameter> are &nil;. This can be used + when values are supplied for all attributes in + <parameter>table</parameter>. In the second, + <parameter>attributes</parameter> is a list of column names, + <parameter>values</parameter> is a corresponding list of + values and <parameter>av-pairs</parameter> is &nil;. In the + third, <parameter>attributes</parameter> and + <parameter>values</parameter> are &nil; and + <parameter>av-pairs</parameter> is an alist of (attribute + value) pairs. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(select [first-name] [last-name] [email] + :from [employee] + :where [= [emplid] 1] + :field-names nil) +=> (("Vladimir" "Lenin" "lenin@soviet.org")) +(update-records [employee] + :av-pairs'((first_name "Yuri") + (last_name "Gagarin") + (email "gagarin@soviet.org")) + :where [= [emplid] 1]) +=> +(select [first-name] [last-name] [email] + :from [employee] + :where [= [emplid] 1] + :field-names nil) +=> (("Yuri" "Gagarin" "gagarin@soviet.org")) + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para> + Modifications are made to the underlying database. + </para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para> + None. + </para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para> + An error of type <symbol>sql-database-data-error</symbol> is + signalled if <parameter>table</parameter> is not an existing + table in <parameter>database</parameter>, if the specified + attributes are not found or if the SQL statement resulting + from the symbolic expression <parameter>where</parameter> does + not return a Boolean value. + </para> + <para>If the execution of the SQL query leads to any errors, an + error of type <errortype>sql-database-error</errortype> is + signalled.</para> + </refsect1> + <refsect1> + <title>See Also</title> + <para> + <simplelist> + <member><link linkend="insert-records"><function>insert-records</function></link></member> + <member><link linkend="delete-records"><function>delete-records</function></link></member> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Notes</title> + <para> + None. + </para> + </refsect1> + </refentry> + + <refentry id="delete-records"> + <refmeta> + <refentrytitle>DELETE-RECORDS</refentrytitle> + </refmeta> + <refnamediv> + <refname>DELETE-RECORDS</refname> + <refpurpose>Delete records from a database table.</refpurpose> + <refclass>Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis> + <function>delete-records</function> &key <replaceable>from</replaceable> <replaceable>where</replaceable> <replaceable>database</replaceable> => <returnvalue></returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>from</parameter></term> + <listitem> + <para> + A string, symbol or symbolic SQL expression representing + the name of a table existing in + <parameter>database</parameter>. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>where</parameter></term> + <listitem> + <para> + A symbolic SQL expression. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>database</parameter></term> + <listitem> + <para>A + <glossterm linkend="gloss-database-object">database + object</glossterm>. This will default to the value + of <symbol>*default-database*</symbol>.</para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para>Deletes records satisfying the SQL expression + <parameter>where</parameter> from the table specified by + <parameter>from</parameter> in <parameter>database</parameter> + specifies a database which defaults to + <symbol>*default-database*</symbol>. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(select [first-name] [last-name] [email] + :from [employee] + :where [= [emplid] 11] + :field-names nil) +=> (("Yuri" "Gagarin" "gagarin@soviet.org")) +(delete-records :from [employee] :where [= [emplid] 11]) +=> +(select [first-name] [last-name] [email] + :from [employee] + :where [= [emplid] 11] + :field-names nil) +=> NIL + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para> + Modifications are made to the underlying database. + </para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para> + None. + </para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para> + An error of type <symbol>sql-database-data-error</symbol> is + signalled if <parameter>from</parameter> is not an existing + table in <parameter>database</parameter> or if the SQL + statement resulting from the symbolic expression + <parameter>where</parameter> does not return a Boolean value. + </para> + </refsect1> + <refsect1> + <title>See Also</title> + <para> + <simplelist> + <member><link linkend="insert-records"><function>insert-records</function></link></member> + <member><link linkend="update-records"><function>update-records</function></link></member> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Notes</title> + <para> + None. + </para> + </refsect1> + </refentry> + + + <!-- executing SQL commands and queries --> + + <refentry id="execute-command"> + <refmeta> + <refentrytitle>EXECUTE-COMMAND</refentrytitle> + </refmeta> + <refnamediv> + <refname>EXECUTE-COMMAND</refname> + <refpurpose>Execute an SQL command which returns no values.</refpurpose> + <refclass>Generic Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis> + <function>execute-command</function> <replaceable>sql-expression</replaceable> &key <replaceable>database</replaceable> => <returnvalue></returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>sql-expression</parameter></term> + <listitem> + <para>An <glossterm linkend="gloss-sql-expression">sql + expression</glossterm> that represents an SQL + statement which will return no values.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>database</parameter></term> + <listitem> + <para>A + <glossterm linkend="gloss-database-object">database + object</glossterm>. This will default to the value + of <symbol>*default-database*</symbol>.</para> + </listitem> + </varlistentry></variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para>Executes the SQL command + <parameter>sql-expression</parameter>, which may be a symbolic + SQL expression or a string representing any SQL statement apart + from a query, on the supplied <parameter>database</parameter> + which defaults to <symbol>*default-database*</symbol>. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> + (execute-command "create table eventlog (time char(30),event char(70))") + => + + (execute-command "create table eventlog (time char(30),event char(70))") + >> + >> While accessing database #<CLSQL-POSTGRESQL:POSTGRESQL-DATABASE {480B2B6D}> + >> with expression "create table eventlog (time char(30),event char(70))": + >> Error NIL: ERROR: amcreate: eventlog relation already exists + >> has occurred. + >> + >> Restarts: + >> 0: [ABORT] Return to Top-Level. + >> + >> Debug (type H for help) + >> + >> (CLSQL-POSTGRESQL::|(PCL::FAST-METHOD DATABASE-EXECUTE-COMMAND (T POSTGRESQL-DATABASE))| + >> #<unused-arg> + >> #<unused-arg> + >> #<unavailable-arg> + >> #<unavailable-arg>) + >> Source: (ERROR 'SQL-DATABASE-ERROR :DATABASE DATABASE :EXPRESSION ...) + >> 0] 0 + + (execute-command "drop table eventlog") + => + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para>Whatever effects the execution of the SQL statement has + on the underlying database, if any.</para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para>If the execution of the SQL statement leads to any errors, + an error of type <errortype>sql-database-error</errortype> is + signalled.</para> + </refsect1> + <refsect1> + <title>See Also</title> + <para> + <simplelist> + <member><link linkend="query"><function>query</function></link></member> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Notes</title> + <para>None.</para> + </refsect1> + </refentry> + + + <refentry id="query"> + <refmeta> + <refentrytitle>QUERY</refentrytitle> + </refmeta> + <refnamediv> + <refname>QUERY</refname> + <refpurpose>Execute an SQL query and return the tuples as a + list.</refpurpose> + <refclass>Generic Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis> + <function>query</function> <replaceable>query-expression</replaceable> &key <replaceable>database</replaceable> <replaceable>result-types</replaceable> <replaceable>flatp</replaceable> <replaceable>field-names</replaceable> => <returnvalue>result</returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>query-expression</parameter></term> + <listitem> + <para>An <glossterm linkend="gloss-sql-expression">sql + expression</glossterm> that represents an SQL + query which is expected to return a (possibly empty) + result set.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>database</parameter></term> + <listitem> + <para>A + <glossterm linkend="gloss-database-object">database + object</glossterm>. This will default to the value + of <symbol>*default-database*</symbol>.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>flatp</parameter></term> + <listitem> + <para>A Boolean whose default value is &nil;.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>result-types</parameter></term> + <listitem> + <para>A + <glossterm linkend="gloss-field-types">field type + specifier</glossterm>. The default is <symbol>:auto</symbol>;. + </para> + <para> + The purpose of this argument is cause &clsql; to + import SQL numeric fields into numeric Lisp objects + rather than strings. This reduces the cost of + allocating a temporary string and the &clsql; users' + inconvenience of converting number strings into number + objects. + </para> + <para> + A value of <symbol>:auto</symbol> causes &clsql; + to automatically convert SQL fields into a + numeric format where applicable. The default value of + &nil; causes all fields to be returned as strings + regardless of the SQL type. Otherwise a list is expected + which has a element for each field that specifies the + conversion. Valid type identifiers are: + <simplelist type="vert"> + <member><symbol>:int</symbol> Field is imported as a + signed integer, from 8-bits to 64-bits depending + upon the field type. + </member> + <member><symbol>:double</symbol> Field is imported as a + double-float number. + </member> + <member><symbol>t</symbol> Field is imported as a + string. + </member> + </simplelist> + If the list is shorter than the number of fields, the a + value of <symbol>t</symbol> is assumed for the field. + If the list is longer than the number of fields, the + extra elements are ignored. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>field-names</parameter></term> + <listitem> + <para> + A boolean with a default value of &t;. When &t;, this + function returns a second value of a list of field + names. When &nil;, this function only returns one value - + the list of rows. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><returnvalue>result</returnvalue></term> + <listitem> + <para>A list representing the result set obtained. For + each tuple in the result set, there is an element in + this list, which is itself a list of all the attribute + values in the tuple.</para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para> + Executes the SQL query expression + <parameter>query-expression</parameter>, which may be an SQL + expression or a string, on the supplied + <parameter>database</parameter> which defaults to + <symbol>*default-database*</symbol>. <parameter>result-types</parameter> + is a list of symbols which specifies the lisp type for each + field returned by <parameter>query-expression</parameter>. + </para> + <para> + If <parameter>result-types</parameter> is &nil; all results + are returned as strings whereas the default value of + <symbol>:auto</symbol> means that the lisp types are + automatically computed for each field. + </para> + <para> + <parameter>field-names</parameter> is &t; by default which + means that the second value returned is a list of strings + representing the columns selected by + <parameter>query-expression</parameter>. If + <parameter>field-names</parameter> is &nil;, the list of column + names is not returned as a second value. + </para> + <para> + <parameter>flatp</parameter> has a default value of &nil; + which means that the results are returned as a list of + lists.If FLATP is &t; and only one result is returned for each + record selected by <parameter>query-expression</parameter>, + the results are returned as elements of a list. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(query "select emplid,first_name,last_name,height from employee where emplid = 1") +=> ((1 "Vladimir" "Lenin" 1.5564661d0)), + ("emplid" "first_name" "last_name" "height") + +(query "select emplid,first_name,last_name,height from employee where emplid = 1" + :field-names nil) +=> ((1 "Vladimir" "Lenin" 1.5564661d0)) + +(query "select emplid,first_name,last_name,height from employee where emplid = 1" + :field-names nil + :result-types nil) +=> (("1" "Vladimir" "Lenin" "1.5564661")) + +(query "select emplid,first_name,last_name,height from employee where emplid = 1" + :field-names nil + :result-types '(:int t t :double)) +=> ((1 "Vladimir" "Lenin" 1.5564661)) + +(query "select last_name from employee where emplid > 5" :flatp t) +=> ("Andropov" "Chernenko" "Gorbachev" "Yeltsin" "Putin"), + ("last_name") + +(query "select last_name from employee where emplid > 10" + :flatp t + :field-names nil) +=> NIL + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para>Whatever effects the execution of the SQL query has + on the underlying database, if any.</para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para>If the execution of the SQL query leads to any errors, an + error of type <errortype>sql-database-error</errortype> is + signalled.</para> + </refsect1> + <refsect1> + <title>See Also</title> + <simplelist> + <member><link linkend="execute-command"><function>execute-command</function></link></member> + <member><link linkend="print-query"><function>print-query</function></link></member> + <member><link linkend="do-query"><function>do-query</function></link></member> + <member><link linkend="map-query"><function>map-query</function></link></member> + <member><link linkend="loop-tuples"><function>loop</function></link></member> + <member><link linkend="select"><function>select</function></link></member> + </simplelist> + </refsect1> + <refsect1> + <title>Notes</title> + <para>The <parameter>field-names</parameter> and + <parameter>result-types</parameter> keyword arguments are a + &clsql; extension.</para> + </refsect1> + </refentry> + + <refentry id="print-query"> + <refmeta> + <refentrytitle>PRINT-QUERY</refentrytitle> + </refmeta> + <refnamediv> + <refname>PRINT-QUERY</refname> + <refpurpose>Prints a tabular report of query results.</refpurpose> + <refclass>Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis> + <function>print-query</function> <replaceable>query-expression</replaceable> &key <replaceable>titles</replaceable> <replaceable>formats</replaceable> <replaceable>sizes</replaceable> <replaceable>stream</replaceable> <replaceable>database</replaceable> => <returnvalue></returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>query-expression</parameter></term> + <listitem> + <para>An <glossterm linkend="gloss-sql-expression">sql + expression</glossterm> that represents an SQL + query which is expected to return a (possibly empty) + result set.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>database</parameter></term> + <listitem> + <para>A + <glossterm linkend="gloss-database-object">database + object</glossterm>. This will default to the value + of <symbol>*default-database*</symbol>.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>titles</parameter></term> + <listitem> + <para> + A list of strings or &nil; which is the default value. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>formats</parameter></term> + <listitem> + <para> + A list of strings, &nil; or &t; which is the default value. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>sizes</parameter></term> + <listitem> + <para> + A list of numbers, &nil; or &t; which is the default value. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>stream</parameter></term> + <listitem> + <para> + An output stream or &t; which is the default value. + </para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para>Prints a tabular report of the results returned by the SQL + query <parameter>query-expression</parameter>, which may be a + symbolic SQL expression or a string, in + <parameter>database</parameter> which defaults to + <symbol>*default-database*</symbol>. The report is printed onto + <parameter>stream</parameter> which has a default value of &t; + which means that <symbol>*standard-output*</symbol> is used. The + <parameter>title</parameter> argument, which defaults to &nil;, + allows the specification of a list of strings to use as column + titles in the tabular output. <parameter>sizes</parameter> + accepts a list of column sizes, one for each column selected by + <parameter>query-expression</parameter>, to use in formatting + the tabular report. The default value of &t; means that minimum + sizes are computed. <parameter>formats</parameter> is a list of + format strings to be used for printing each column selected by + <parameter>query-expression</parameter>. The default value of + <parameter>formats</parameter> is &t; meaning that + <symbol>~A</symbol> is used to format all columns or + <symbol>~VA</symbol> if column sizes are used. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(print-query [select [emplid] [first-name] [last-name] [email] + :from [employee] + :where [< [emplid] 5]] + :titles '("ID" "FORENAME" "SURNAME" "EMAIL")) +ID FORENAME SURNAME EMAIL +1 Vladimir Lenin lenin@soviet.org +2 Josef Stalin stalin@soviet.org +3 Leon Trotsky trotsky@soviet.org +4 Nikita Kruschev kruschev@soviet.org +=> + +(print-query "select emplid,first_name,last_name,email from employee where emplid >= 5" + :titles '("ID" "FORENAME" "SURNAME" "EMAIL")) +ID FORENAME SURNAME EMAIL +5 Leonid Brezhnev brezhnev@soviet.org +6 Yuri Andropov andropov@soviet.org +7 Konstantin Chernenko chernenko@soviet.org +8 Mikhail Gorbachev gorbachev@soviet.org +9 Boris Yeltsin yeltsin@soviet.org +10 Vladimir Putin putin@soviet.org +=> +</screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para> + None. + </para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para> + None. + </para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para> + If the execution of the SQL query leads to any errors, an + error of type <errortype>sql-database-error</errortype> is + signalled. + </para> + </refsect1> + <refsect1> + <title>See Also</title> + <simplelist> + <member><link linkend="query"><function>query</function></link></member> + <member><link linkend="do-query"><function>do-query</function></link></member> + <member><link linkend="map-query"><function>map-query</function></link></member> + <member><link linkend="loop-tuples"><function>loop</function></link></member> + <member><link linkend="select"><function>select</function></link></member> + </simplelist> + </refsect1> + <refsect1> + <title>Notes</title> + <para> + None. + </para> + </refsect1> + </refentry> + + <refentry id="select"> + <refmeta> + <refentrytitle>SELECT</refentrytitle> + </refmeta> + <refnamediv> + <refname>SELECT</refname> + <refpurpose>Executes a query given the supplied constraints.</refpurpose> + <refclass>Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis> + <function>select</function> &rest <replaceable>identifiers</replaceable> &key <replaceable>all</replaceable> <replaceable>distinct</replaceable> <replaceable>from</replaceable> <replaceable>group-by</replaceable> <replaceable>having</replaceable> <replaceable>limit</replaceable> <replaceable>offset</replaceable> <replaceable>order-by</replaceable> <replaceable>set-operation</replaceable> <replaceable>where</replaceable> <replaceable>result-types</replaceable> <replaceable>field-names</replaceable> <replaceable>flatp</replaceable> <replaceable>refresh</replaceable> <replaceable>caching</replaceable> <replaceable>database</replaceable> => <returnvalue>result</returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>identifiers</parameter></term> + <listitem> + <para> + A set of <glossterm linkend="gloss-sql-expression">sql + expressions</glossterm> each of which indicates a column + to query. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>all</parameter></term> + <listitem> + <para> + A Boolean. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>distinct</parameter></term> + <listitem> + <para> + A Boolean. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>from</parameter></term> + <listitem> + <para> + One or more SQL expression representing tables. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>group-by</parameter></term> + <listitem> + <para> + An SQL expression. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>having</parameter></term> + <listitem> + <para> + An SQL expression. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>limit</parameter></term> + <listitem> + <para> + A non-negative integer. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>offset</parameter></term> + <listitem> + <para> + A non-negative integer. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>order-by</parameter></term> + <listitem> + <para> + An SQL expression. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>set-operation</parameter></term> + <listitem> + <para> + An SQL expression. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>where</parameter></term> + <listitem> + <para> + An SQL expression. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>database</parameter></term> + <listitem> + <para>A + <glossterm linkend="gloss-database-object">database + object</glossterm>. This will default to the value + of <symbol>*default-database*</symbol>.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>flatp</parameter></term> + <listitem> + <para>A Boolean whose default value is &nil;.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>result-types</parameter></term> + <listitem> + <para>A + <glossterm linkend="gloss-field-types">field type + specifier</glossterm>. The default is <symbol>:auto</symbol>. + </para> + <para> + The purpose of this argument is cause &clsql; to + import SQL numeric fields into numeric Lisp objects + rather than strings. This reduces the cost of + allocating a temporary string and the &clsql; users' + inconvenience of converting number strings into number + objects. + </para> + <para> + A value of <symbol>:auto</symbol> causes &clsql; + to automatically convert SQL fields into a + numeric format where applicable. The default value of + &nil; causes all fields to be returned as strings + regardless of the SQL type. Otherwise a list is expected + which has a element for each field that specifies the + conversion. Valid type identifiers are: + <simplelist type="vert"> + <member><symbol>:int</symbol> Field is imported as a + signed integer, from 8-bits to 64-bits depending + upon the field type. + </member> + <member><symbol>:double</symbol> Field is imported as a + double-float number. + </member> + <member><symbol>t</symbol> Field is imported as a + string. + </member> + </simplelist> + If the list is shorter than the number of fields, the a + value of <symbol>t</symbol> is assumed for the field. + If the list is longer than the number of fields, the + extra elements are ignored. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>field-names</parameter></term> + <listitem> + <para> + A boolean with a default value of &t;. When &t;, this + function returns a second value of a list of field + names. When &nil;, this function only returns one value - + the list of rows. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>refresh</parameter></term> + <listitem> + <para> + This value is only considered when CLOS objects are being + selected. A boolean with a default value of &nil;. When + the value of the <varname>caching</varname> keyword is + &t;, a second equivalent <function>select</function> call + will return the same view class instance objects. When + <varname>refresh</varname> is &t;, then slots of the + existing instances are updated as necessary. In such + cases, you may wish to override the hook + <function>instance-refresh</function>. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>caching</parameter></term> + <listitem> + <para> + This value is only considered when CLOS objects are being + selected. A boolean with a default value of + <varname>*default-caching*</varname>. &clsql; caches + objects in accordance with the &commonsql; interface: a + second equivalent <function>select</function> call will + return the same view class instance objects. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>result</parameter></term> + <listitem> + <para> + A list representing the result set obtained. For each + tuple in the result set, there is an element in this + list, which is itself a list of all the attribute values + in the tuple. + </para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para> + Executes a query on <parameter>database</parameter>, which has + a default value of <symbol>*default-database*</symbol>, + specified by the SQL expressions supplied using the remaining + arguments in <parameter>args</parameter>. The + <function>select</function> function can be used to generate + queries in both functional and object oriented contexts. + </para> + <para> + In the functional case, the required arguments specify the + columns selected by the query and may be symbolic SQL + expressions or strings representing attribute + identifiers. Type modified identifiers indicate that the + values selected from the specified column are converted to the + specified lisp type. The keyword arguments + <parameter>all</parameter>, <parameter>distinct</parameter>, + <parameter>from</parameter>, <parameter>group-by</parameter>, + <parameter>having</parameter>, <parameter>limit</parameter>, + <parameter>offset</parameter>, <parameter>order-by</parameter>, + <parameter>set-operation</parameter> and + <parameter>where</parameter> are used to specify, using the + symbolic SQL syntax, the corresponding components of the SQL + query generated by the call to + <function>select</function>. + </para> + <para> + <parameter>result-types</parameter> is a list of symbols which + specifies the lisp type for each field returned by the + query. If <parameter>result-types</parameter> is &nil; all + results are returned as strings whereas the default value of + <symbol>:auto</symbol> means that the lisp types are + automatically computed for each + field. <parameter>field-names</parameter> is &t; by default + which means that the second value returned is a list of + strings representing the columns selected by the query. If + <parameter>field-names</parameter> is &nil;, the list of + column names is not returned as a second value. + </para> + <para> + In the object oriented case, the required arguments to + <function>select</function> are symbols denoting View Classes + which specify the database tables to query. In this case, + <function>select</function> returns a list of View Class + instances whose slots are set from the attribute values of the + records in the specified table. <symbol>Slot-value</symbol> is + a legal operator which can be employed as part of the symbolic + SQL syntax used in the <parameter>where</parameter> keyword + argument to <function>select</function>. + <parameter>refresh</parameter> is &nil; by default which means + that the View Class instances returned are retrieved from a + cache if an equivalent call to <function>select</function> has + previously been issued. If <parameter>refresh</parameter> is + true, the View Class instances returned are updated as + necessary from the database and the generic function + <function>instance-refreshed</function> is called to perform + any necessary operations on the updated instances. + </para> + <para> + In both object oriented and functional contexts, + <parameter>flatp</parameter> has a default value of &nil; + which means that the results are returned as a list of + lists. If <parameter>flatp</parameter> is t and only one + result is returned for each record selected in the query, the + results are returned as elements of a list. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(select [first-name] :from [employee] :flatp t :distinct t + :field-names nil + :result-types nil + :order-by [first-name]) +=> ("Boris" "Josef" "Konstantin" "Leon" "Leonid" "Mikhail" "Nikita" "Vladimir" + "Yuri") + +(select [first-name] [count [*]] :from [employee] + :result-types nil + :group-by [first-name] + :order-by [first-name] + :field-names nil) +=> (("Boris" "1") ("Josef" "1") ("Konstantin" "1") ("Leon" "1") ("Leonid" "1") + ("Mikhail" "1") ("Nikita" "1") ("Vladimir" "2") ("Yuri" "1")) + +(select [last-name] :from [employee] + :where [like [email] "%org"] + :order-by [last-name] + :field-names nil + :result-types nil + :flatp t) +=> ("Andropov" "Brezhnev" "Chernenko" "Gorbachev" "Kruschev" "Lenin" "Putin" + "Stalin" "Trotsky" "Yeltsin") + +(select [max [emplid]] :from [employee] + :flatp t + :field-names nil + :result-types :auto) +=> (10) + +(select [avg [height]] :from [employee] :flatp t :field-names nil) +=> (1.58999584d0) + +(select [emplid] [last-name] :from [employee] :where [= [emplid] 1]) +=> ((1 "Lenin")), + ("emplid" "last_name") + +(select [emplid :string] :from [employee] + :where [= 1 [emplid]] + :field-names nil + :flatp t) +=> ("1") + +(select [emplid] :from [employee] :order-by [emplid] + :where [not [between [* [emplid] 10] [* 5 10] [* 10 10]]] + :field-names nil + :flatp t) +=> (1 2 3 4) + +(select [emplid] :from [employee] + :where [in [emplid] '(1 2 3 4)] + :flatp t + :order-by [emplid] + :field-names nil) +=> (1 2 3 4) + +(select [emplid] :from [employee] + :order-by [emplid] + :limit 5 + :offset 3 + :field-names nil + :flatp t) +=> (4 5 6 7 8) + +(select [first-name] [last-name] :from [employee] + :field-names nil + :order-by '(([first-name] :asc) ([last-name] :desc))) +=> (("Boris" "Yeltsin") ("Josef" "Stalin") ("Konstantin" "Chernenko") + ("Leon" "Trotsky") ("Leonid" "Brezhnev") ("Mikhail" "Gorbachev") + ("Nikita" "Kruschev") ("Vladimir" "Putin") ("Vladimir" "Lenin") + ("Yuri" "Andropov")) + +(select [last-name] :from [employee] + :set-operation [union [select [first-name] :from [employee] + :order-by [last-name]]] + :flatp t + :result-types nil + :field-names nil) +=> ("Andropov" "Boris" "Brezhnev" "Chernenko" "Gorbachev" "Josef" "Konstantin" + "Kruschev" "Lenin" "Leon" "Leonid" "Mikhail" "Nikita" "Putin" "Stalin" + "Trotsky" "Vladimir" "Yeltsin" "Yuri") + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para>Whatever effects the execution of the SQL query has on + the underlying database, if any.</para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para> + None. + </para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para> + If the execution of the SQL query leads to any errors, an + error of type <errortype>sql-database-error</errortype> is + signalled. + </para> + </refsect1> + <refsect1> + <title>See Also</title> + <simplelist> + <member><link linkend="query"><function>query</function></link></member> + <member><link linkend="print-query"><function>print-query</function></link></member> + <member><link linkend="do-query"><function>do-query</function></link></member> + <member><link linkend="map-query"><function>map-query</function></link></member> + <member><link linkend="loop-tuples"><function>loop</function></link></member> + <member><link linkend="instance-refreshed"><function>instance-refreshed</function></link></member> + </simplelist> + </refsect1> + <refsect1> + <title>Notes</title> + <para> + The <function>select</function> function is actually + implemented in &clsql; with a single + <symbol>&rest</symbol> parameter (which is subsequently + destructured) rather than the keyword parameters presented + here for the purposes of exposition. This means that incorrect + or missing keywords or values may not trigger errors in the + way that they would if <function>select</function> had been + defined using keyword arguments. + </para> + <para> + The <parameter>field-names</parameter> and + <parameter>result-types</parameter> keyword arguments are a + &clsql; extension. + </para> + <para> + <parameter>select</parameter> is common across the functional + and object-oriented data manipulation languages. + </para> + </refsect1> + </refentry> + + + <!-- iteration and mapping --> + + <refentry id="do-query"> + <refmeta> + <refentrytitle>DO-QUERY</refentrytitle> + </refmeta> + <refnamediv> + <refname>DO-QUERY</refname> + <refpurpose>Iterate over all the tuples of a query.</refpurpose> + <refclass>Macro</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis> + <function>do-query</function> ((&rest <replaceable>args</replaceable>) <replaceable>query-expression</replaceable> &key <replaceable>database</replaceable> <replaceable>result-types</replaceable> &body <replaceable>body</replaceable> => <returnvalue>result</returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>args</parameter></term> + <listitem> + <para>A list of variable names.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>query-expression</parameter></term> + <listitem> + <para>An <glossterm linkend="gloss-sql-expression">sql + expression</glossterm> that represents an SQL + query which is expected to return a (possibly empty) + result set, where each tuple has as many attributes as + <parameter>function</parameter> takes arguments.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>database</parameter></term> + <listitem> + <para>A + <glossterm linkend="gloss-database-object">database + object</glossterm>. This will default to + <symbol>*default-database*</symbol>.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>result-types</parameter></term> + <listitem> + <para> + A <glossterm linkend="gloss-field-types">field type + specifier</glossterm>. The default is &nil;. See <link + linkend="query"><function>query</function></link> for + the semantics of this argument. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>body</parameter></term> + <listitem> + <para>A body of Lisp code, like in a + <function>destructuring-bind</function> form.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>result</parameter></term> + <listitem> + <para>The result of executing <parameter>body</parameter>.</para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para> + Repeatedly executes <parameter>body</parameter> within a + binding of <parameter>args</parameter> on the fields of each + row selected by the SQL query + <parameter>query-expression</parameter>, which may be a string + or a symbolic SQL expression, in + <parameter>database</parameter> which defaults to + <symbol>*default-database*</symbol>. + </para> + <para> + The body of code is executed in a block named + <symbol>nil</symbol> which may be returned from prematurely + via <function>return</function> or + <function>return-from</function>. In this case the result of + evaluating the <function>do-query</function> form will be the + one supplied to <function>return</function> or + <function>return-from</function>. Otherwise the result will + be <symbol>nil</symbol>. + </para> + <para> + The body of code appears also is if wrapped in a + <function>destructuring-bind</function> form, thus allowing + declarations at the start of the body, especially those + pertaining to the bindings of the variables named in + <parameter>args</parameter>. + </para> + <para> + <parameter>result-types</parameter> is a list of symbols which + specifies the lisp type for each field returned by + <parameter>query-expression</parameter>. If + <parameter>result-types</parameter> is &nil; all results are + returned as strings whereas the default value of + <symbol>:auto</symbol> means that the lisp types are + automatically computed for each field. + </para> + <para> + <parameter>query-expression</parameter> may be an object query + (i.e., the selection arguments refer to View Classes), in + which case <parameter>args</parameter> are bound to the tuples + of View Class instances returned by the object oriented query. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(do-query ((salary name) "select salary,name from simple") + (format t "~30A gets $~2,5$~%" name (read-from-string salary))) +>> Mai, Pierre gets $10000.00 +>> Hacker, Random J. gets $08000.50 +=> NIL + +(do-query ((salary name) "select salary,name from simple") + (return (cons salary name))) +=> ("10000.00" . "Mai, Pierre") + +(let ((result '())) + (do-query ((name) [select [last-name] :from [employee] + :order-by [last-name]]) + (push name result)) + result) +=> ("Yeltsin" "Trotsky" "Stalin" "Putin" "Lenin" "Kruschev" "Gorbachev" + "Chernenko" "Brezhnev" "Andropov") + +(let ((result '())) + (do-query ((e) [select 'employee :order-by [last-name]]) + (push (slot-value e 'last-name) result)) + result) +=> ("Yeltsin" "Trotsky" "Stalin" "Putin" "Lenin" "Kruschev" "Gorbachev" + "Chernenko" "Brezhnev" "Andropov") + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para>Whatever effects the execution of the SQL query has + on the underlying database, if any.</para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para>If the execution of the SQL query leads to any + errors, an error of type + <errortype>sql-database-error</errortype> is signalled.</para> + <para>If the number of variable names in + <parameter>args</parameter> and the number of attributes in + the tuples in the result set don't match up, an error is + signalled.</para> + </refsect1> + <refsect1> + <title>See Also</title> + <simplelist> + <member><link linkend="query"><function>query</function></link></member> + <member><link linkend="map-query"><function>map-query</function></link></member> + <member><link linkend="print-query"><function>print-query</function></link></member> + <member><link linkend="loop-tuples"><function>loop</function></link></member> + <member><link linkend="select"><function>select</function></link></member> + </simplelist> + </refsect1> + <refsect1> + <title>Notes</title> + <para>The <parameter>result-types</parameter> keyword argument + is a &clsql; extension.</para> + <para> + <parameter>do-query</parameter> is common across the functional + and object-oriented data manipulation languages. + </para> + </refsect1> + </refentry> + + <refentry id="loop-tuples"> + <refmeta> + <refentrytitle>LOOP</refentrytitle> + </refmeta> + <refnamediv> + <refname>LOOP</refname> + <refpurpose>Extension to Common Lisp + <computeroutput>Loop</computeroutput> to iterate over all the + tuples of a query via a loop clause.</refpurpose> + <refclass>Loop Clause</refclass> + </refnamediv> + <!-- refsect1> + <title>Compatibility</title> + <caution><para><function>loop-for-as-tuples</function> only works with &cmucl;.</para></caution> + </refsect1 --> + <refsect1> + <title>Syntax</title> + <synopsis>{as | for} <replaceable>var</replaceable> [<replaceable>type-spec</replaceable>] being {each | the} {record | records | tuple | tuples} {in | of} <replaceable>query</replaceable> [from <replaceable>database</replaceable>]</synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>var</parameter></term> + <listitem> + <para>A <literal>d-var-spec</literal>, as defined in the + grammar for <function>loop</function>-clauses in the ANSI + Standard for Common Lisp. This allows for the usual + loop-style destructuring.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>type-spec</parameter></term> + <listitem> + <para>An optional <literal>type-spec</literal> either + simple or destructured, as defined in the grammar for + <function>loop</function>-clauses in the ANSI Standard for + Common Lisp.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>query</parameter></term> + <listitem> + <para>An <glossterm linkend="gloss-sql-expression">sql + expression</glossterm> that represents an SQL + query which is expected to return a (possibly empty) + result set, where each tuple has as many attributes as + <parameter>function</parameter> takes arguments.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>database</parameter></term> + <listitem> + <para>An optional + <glossterm linkend="gloss-database-object">database + object</glossterm>. This will default to the value + of <symbol>*default-database*</symbol>.</para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para>This clause is an iteration driver for + <function>loop</function>, that binds the given variable + (possibly destructured) to the consecutive tuples (which are + represented as lists of attribute values) in the result set + returned by executing the SQL <parameter>query</parameter> + expression on the <parameter>database</parameter> + specified.</para> + <para> + <parameter>query</parameter> may be an object query (i.e., the + selection arguments refer to View Classes), in which case the + supplied variable is bound to the tuples of View Class + instances returned by the object oriented query. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(defvar *my-db* (connect '("dent" "newesim" "dent" "dent")) +"My database" +=> *MY-DB* +(loop with time-graph = (make-hash-table :test #'equal) + with event-graph = (make-hash-table :test #'equal) + for (time event) being the tuples of "select time,event from log" + from *my-db* + do + (incf (gethash time time-graph 0)) + (incf (gethash event event-graph 0)) + finally + (flet ((show-graph (k v) (format t "~40A => ~5D~%" k v))) + (format t "~&Time-Graph:~%===========~%") + (maphash #'show-graph time-graph) + (format t "~&~%Event-Graph:~%============~%") + (maphash #'show-graph event-graph)) + (return (values time-graph event-graph))) +>> Time-Graph: +>> =========== +>> D => 53000 +>> X => 3 +>> test-me => 3000 +>> +>> Event-Graph: +>> ============ +>> CLOS Benchmark entry. => 9000 +>> Demo Text... => 3 +>> doit-text => 3000 +>> C Benchmark entry. => 12000 +>> CLOS Benchmark entry => 32000 +=> #<EQUAL hash table, 3 entries {48350A1D}> +=> #<EQUAL hash table, 5 entries {48350FCD}> + +(loop for (forename surname) + being each tuple in + [select [first-name] [last-name] :from [employee] + :order-by [last-name]] + collect (concatenate 'string forename " " surname)) +=> ("Yuri Andropov" "Leonid Brezhnev" "Konstantin Chernenko" "Mikhail Gorbachev" + "Nikita Kruschev" "Vladimir Lenin" "Vladimir Putin" "Josef Stalin" + "Leon Trotsky" "Boris Yeltsin") + +(loop for (e) being the records in + [select 'employee :where [< [emplid] 4] :order-by [emplid]] + collect (slot-value e 'last-name)) +=> ("Lenin" "Stalin" "Trotsky") + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para>Whatever effects the execution of the SQL query has + on the underlying database, if any.</para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para>If the execution of the SQL query leads to any + errors, an error of type + <errortype>sql-database-error</errortype> is signalled.</para> + <para>Otherwise, any of the exceptional situations of + <function>loop</function> applies.</para> + </refsect1> + <refsect1> + <title>See Also</title> + <para> + <simplelist> + <member><link linkend="query"><function>query</function></link></member> + <member><link linkend="map-query"><function>map-query</function></link></member> + <member><link linkend="do-query"><function>do-query</function></link></member> + <member><link linkend="print-query"><function>print-query</function></link></member> + <member><link linkend="select"><function>select</function></link></member> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Notes</title> + <para>The <parameter>database</parameter> loop keyword is a + &clsql; extension.</para> + <para> + The extended <function>loop</function> syntax is common across + the functional and object-oriented data manipulation + languages. + </para> + </refsect1> + </refentry> + + <refentry id="map-query"> + <refmeta> + <refentrytitle>MAP-QUERY</refentrytitle> + </refmeta> + <refnamediv> + <refname>MAP-QUERY</refname> + <refpurpose>Map a function over all the tuples from a + query</refpurpose> + <refclass>Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis><function>map-query</function> <replaceable>output-type-spec</replaceable> <replaceable>function</replaceable> <replaceable>query-expression</replaceable> &key <replaceable>database</replaceable> <replaceable>result-types</replaceable> => <returnvalue>result</returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>output-type-spec</parameter></term> + <listitem> + <para>A sequence type specifier or <symbol>nil</symbol>.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>function</parameter></term> + <listitem> + <para>A function designator. + <parameter>function</parameter> takes a single argument which + is the atom value for a query single with a single column + or is a list of values for a multi-column query.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>query-expression</parameter></term> + <listitem> + <para>An <glossterm linkend="gloss-sql-expression">sql + expression</glossterm> that represents an SQL + query which is expected to return a (possibly empty) + result set.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>database</parameter></term> + <listitem> + <para>A + <glossterm linkend="gloss-database-object">database + object</glossterm>. This will default to the value + of <symbol>*default-database*</symbol>.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>result-types</parameter></term> + <listitem> + <para> + A <glossterm linkend="gloss-field-types">field type + specifier</glossterm>. The default is &nil;. See <link + linkend="query"><function>query</function></link> for + the semantics of this argument. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><returnvalue>result</returnvalue></term> + <listitem> + <para>If <parameter>output-type-spec</parameter> is a + type specifier other than <symbol>nil</symbol>, then a + sequence of the type it denotes. Otherwise + <symbol>nil</symbol> is returned.</para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para> + Applies <parameter>function</parameter> to the successive + tuples in the result set returned by executing the SQL + <parameter>query-expression</parameter>. If the + <parameter>output-type-spec</parameter> is + <symbol>nil</symbol>, then the result of each application of + <parameter>function</parameter> is discarded, and + <function>map-query</function> returns <symbol>nil</symbol>. + Otherwise the result of each successive application of + <parameter>function</parameter> is collected in a sequence of + type <parameter>output-type-spec</parameter>, where the jths + element is the result of applying + <parameter>function</parameter> to the attributes of the jths + tuple in the result set. The collected sequence is the result + of the call to <function>map-query</function>. + </para> + <para> + If the <parameter>output-type-spec</parameter> is a subtype of + <type>list</type>, the result will be a <type>list</type>. + </para> + <para> + If the <parameter>result-type</parameter> is a subtype of + <type>vector</type>, then if the implementation can determine + the element type specified for the + <parameter>result-type</parameter>, the element type of the + resulting array is the result of + <emphasis>upgrading</emphasis> that element type; or, if the + implementation can determine that the element type is + unspecified (or <symbol>*</symbol>), the element type of the + resulting array is <type>t</type>; otherwise, an error is + signaled. + </para> + <para> + If <parameter>result-types</parameter> is &nil; all results + are returned as strings whereas the default value of + <symbol>:auto</symbol> means that the lisp types are + automatically computed for each field.</para> + <para> + <parameter>query-expression</parameter> may be an object query + (i.e., the selection arguments refer to View Classes), in + which case the supplied function is applied to the tuples of + View Class instances returned by the object oriented query. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(map-query 'list #'(lambda (tuple) + (multiple-value-bind (salary name) tuple + (declare (ignorable name)) + (read-from-string salary))) + "select salary,name from simple where salary > 8000") +=> (10000.0 8000.5) + +(map-query '(vector double-float) + #'(lambda (tuple) + (multiple-value-bind (salary name) tuple + (declare (ignorable name)) + (let ((*read-default-float-format* 'double-float)) + (coerce (read-from-string salary) 'double-float)) + "select salary,name from simple where salary > 8000"))) +=> #(10000.0d0 8000.5d0) +(type-of *) +=> (SIMPLE-ARRAY DOUBLE-FLOAT (2)) + +(let (list) + (values (map-query nil #'(lambda (tuple) + (multiple-value-bind (salary name) tuple + (push (cons name (read-from-string salary)) list)) + "select salary,name from simple where salary > 8000")) + list)) +=> NIL +=> (("Hacker, Random J." . 8000.5) ("Mai, Pierre" . 10000.0)) + +(map-query 'vector #'identity + [select [last-name] :from [employee] :flatp t + :order-by [last-name]]) +=> #("Andropov" "Brezhnev" "Chernenko" "Gorbachev" "Kruschev" "Lenin" "Putin" + "Stalin" "Trotsky" "Yeltsin") + +(map-query 'list #'identity + [select [first-name] [last-name] :from [employee] + :order-by [last-name]]) +=> (("Yuri" "Andropov") ("Leonid" "Brezhnev") ("Konstantin" "Chernenko") + ("Mikhail" "Gorbachev") ("Nikita" "Kruschev") ("Vladimir" "Lenin") + ("Vladimir" "Putin") ("Josef" "Stalin") ("Leon" "Trotsky") + ("Boris" "Yeltsin")) + +(map-query 'list #'last-name [select 'employee :order-by [emplid]]) +=> ("Lenin" "Stalin" "Trotsky" "Kruschev" "Brezhnev" "Andropov" "Chernenko" + "Gorbachev" "Yeltsin" "Putin") + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para>Whatever effects the execution of the SQL query has + on the underlying database, if any.</para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para>If the execution of the SQL query leads to any + errors, an error of type + <errortype>sql-database-error</errortype> is signalled.</para> + <para>An error of type <errortype>type-error</errortype> must + be signaled if the <parameter>output-type-spec</parameter> is + not a recognizable subtype of <type>list</type>, not a + recognizable subtype of <type>vector</type>, and not + <symbol>nil</symbol>.</para> + <para>An error of type <errortype>type-error</errortype> + should be signaled if + <parameter>output-type-spec</parameter> specifies the number + of elements and the size of the result set is different from + that number.</para> + </refsect1> + <refsect1> + <title>See Also</title> + <simplelist> + <member><link linkend="query"><function>query</function></link></member> + <member><link linkend="do-query"><function>do-query</function></link></member> + <member><link linkend="print-query"><function>print-query</function></link></member> + <member><link linkend="loop-tuples"><function>loop</function></link></member> + <member><link linkend="select"><function>select</function></link></member> + </simplelist> + </refsect1> + <refsect1> + <title>Notes</title> + <para>The <parameter>result-types</parameter> keyword argument + is a &clsql; extension.</para> + <para> + <parameter>map-query</parameter> is common across the + functional and object-oriented data manipulation languages. + </para> + </refsect1> + </refentry> + +</reference> + diff --git a/doc/ref-lob.xml b/doc/ref-lob.xml new file mode 100644 index 0000000..4ca04ff --- /dev/null +++ b/doc/ref-lob.xml @@ -0,0 +1,273 @@ +<?xml version='1.0' ?> +<!DOCTYPE book PUBLIC "-//OASIS//DTD DocBook XML V4.2//EN" +"http://www.oasis-open.org/docbook/xml/4.2/docbookx.dtd" [ +<!ENTITY % myents SYSTEM "entities.inc"> +%myents; +]> + +<reference id="ref-lob"> + <title>Large Object Support</title> + <partintro> + <para> + <!-- introduction --> + </para> + </partintro> + + <refentry id="create-large-object"> + <refnamediv> + <refname>CREATE-LARGE-OBJECT</refname> + <refpurpose><!-- purpose --></refpurpose> + <refclass>Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis> + <function> (CREATE-LARGE-OBJECT &KEY (DATABASE *DEFAULT-DATABASE*)) [function]</function> => <returnvalue><!-- result --></returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <!-- arguments and values --> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para>Creates a new large object in the database and returns + the object identifier + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> + <!-- examples --> + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para> + <!-- side effects --> + </para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para> + <simplelist> + <!-- affected by --> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para> + <!-- execeptional situations --> + </para> + </refsect1> + <refsect1> + <title>See Also</title> + <para> + <simplelist> + <!-- see also --> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Notes</title> + <para> + <!-- notes --> + </para> + </refsect1> + </refentry> + + <refentry id="delete-large-object"> + <refnamediv> + <refname>DELETE-LARGE-OBJECT</refname> + <refpurpose><!-- purpose --></refpurpose> + <refclass>Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis> + <function> (DELETE-LARGE-OBJECT OBJECT-ID &KEY (DATABASE *DEFAULT-DATABASE*)) [function]</function> => <returnvalue><!-- result --></returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <!-- arguments and values --> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para>Deletes the large object in the database + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> + <!-- examples --> + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para> + <!-- side effects --> + </para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para> + <simplelist> + <!-- affected by --> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para> + <!-- execeptional situations --> + </para> + </refsect1> + <refsect1> + <title>See Also</title> + <para> + <simplelist> + <!-- see also --> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Notes</title> + <para> + <!-- notes --> + </para> + </refsect1> + </refentry> + + <refentry id="read-large-object"> + <refnamediv> + <refname>READ-LARGE-OBJECT</refname> + <refpurpose><!-- purpose --></refpurpose> + <refclass>Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis> + <function> (READ-LARGE-OBJECT OBJECT-ID &KEY (DATABASE *DEFAULT-DATABASE*)) [function]</function> => <returnvalue><!-- result --></returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <!-- arguments and values --> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para>Reads the large object content + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> + <!-- examples --> + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para> + <!-- side effects --> + </para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para> + <simplelist> + <!-- affected by --> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para> + <!-- execeptional situations --> + </para> + </refsect1> + <refsect1> + <title>See Also</title> + <para> + <simplelist> + <!-- see also --> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Notes</title> + <para> + <!-- notes --> + </para> + </refsect1> + </refentry> + + <refentry id="write-large-object"> + <refnamediv> + <refname>WRITE-LARGE-OBJECT</refname> + <refpurpose><!-- purpose --></refpurpose> + <refclass>Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis> + <function> (WRITE-LARGE-OBJECT OBJECT-ID DATA &KEY (DATABASE *DEFAULT-DATABASE*)) [function]</function> => <returnvalue><!-- result --></returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <!-- arguments and values --> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para>Writes data to the large object + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> + <!-- examples --> + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para> + <!-- side effects --> + </para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para> + <simplelist> + <!-- affected by --> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para> + <!-- execeptional situations --> + </para> + </refsect1> + <refsect1> + <title>See Also</title> + <para> + <simplelist> + <!-- see also --> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Notes</title> + <para> + <!-- notes --> + </para> + </refsect1> + </refentry> + +</reference> diff --git a/doc/ref-ooddl.xml b/doc/ref-ooddl.xml new file mode 100644 index 0000000..4a2cffa --- /dev/null +++ b/doc/ref-ooddl.xml @@ -0,0 +1,1149 @@ +<?xml version='1.0' ?> +<!DOCTYPE book PUBLIC "-//OASIS//DTD DocBook XML V4.2//EN" +"http://www.oasis-open.org/docbook/xml/4.2/docbookx.dtd" [ +<!ENTITY % myents SYSTEM "entities.inc"> +%myents; +]> + +<!-- Object Oriented Data Definition Language --> +<reference id="ref-ooddl"> + <title>Object Oriented Data Definition Language (OODDL)</title> + <partintro> + <para> + The Object Oriented Data Definition Language (OODDL) provides + access to relational SQL tables using Common Lisp Object System + (CLOS) objects. SQL tables are mapped to CLOS objects with the + SQL columns being mapped to slots of the CLOS object. + </para> + <para> + The mapping between SQL tables and CLOS objects is defined with + the macro <link + linkend="def-view-class"><function>def-view-class</function></link>. SQL + tables are created with <link + linkend="create-view-from-class"><function>create-view-from-class</function></link> + and SQL tables can be deleted with <link + linkend="drop-view-from-class"><function>drop-view-from-class</function></link>. + </para> + <note> + <para>The above functions refer to the Lisp + <emphasis>view</emphasis> of the SQL table. This Lisp view + should not be confused with SQL <function>VIEW</function> + statement.</para> + </note> + </partintro> + + <refentry id="standard-db-object"> + <refnamediv> + <refname>STANDARD-DB-OBJECT</refname> + <refpurpose>Superclass for all &clsql; View Classes.</refpurpose> + <refclass>Class</refclass> + </refnamediv> + <refsect1> + <title>Class Precedence List</title> + <para> + <simplelist type="inline"> + <member><type>standard-db-object</type></member> + <member><type>standard-object</type></member> + <member><type>t</type></member> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Description</title> <para>This class is the superclass + of all &clsql; View Classes.</para> + </refsect1> + <refsect1> + <title>Class details</title> + <programlisting>(defclass STANDARD-DB-OBJECT ()(...))</programlisting> + </refsect1> + <refsect1> + <title>Slots</title> + <para> + <simplelist> + <member>slot VIEW-DATABASE is of type (OR NULL DATABASE) + which stores the associated database for the + instance.</member> + </simplelist> + </para> + </refsect1> + </refentry> + + <refentry id="default-string-length"> + <refnamediv> + <refname>*DEFAULT-STRING-LENGTH*</refname> + <refpurpose>Default length of SQL strings.</refpurpose> + <refclass>Variable</refclass> + </refnamediv> + <refsect1> + <title>Value Type</title> + <para> + Fixnum + </para> + </refsect1> + <refsect1> + <title>Initial Value</title> + <para><parameter>255</parameter></para> + </refsect1> + <refsect1> + <title>Description</title> + <para> + If a slot of a class defined by + <function>def-view-class</function> is of the type + <parameter>string</parameter> or + <parameter>varchar</parameter> and does not have a length + specified, then the value of this variable is used as SQL + length. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(let ((*default-string-length* 80)) + (def-view-class s80 () + ((a :type string) + (b :type (string 80)) + (c :type varchar)))) +=> #<Standard-Db-Class S80 {480A431D}> + +(create-view-from-class 's80) +=> +(table-exists-p [s80]) +=> T + </screen> + <para> + The above code causes a SQL table to be created with the SQL command + </para> + <screen>CREATE TABLE (A VARCHAR(80), B CHAR(80), C VARCHAR(80))</screen> + </refsect1> + <refsect1> + <title>Affected By</title> + <para> + Some SQL backends do not support + <parameter>varchar</parameter> lengths greater than 255. + </para> + </refsect1> + <refsect1> + <title>See Also</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>Notes</title> + <para>This is a CLSQL extension to the CommonSQL API.</para> + </refsect1> + </refentry> + + <refentry id="create-view-from-class"> + <refnamediv> + <refname>CREATE-VIEW-FROM-CLASS</refname> + <refpurpose>Create a SQL table from a <glossterm linkend="gloss-view-class">View Class</glossterm>.</refpurpose> + <refclass>Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis> + <function>create-view-from-class</function> <replaceable>view-class-name</replaceable> &key <replaceable>database</replaceable> <replaceable>transactions</replaceable> => <returnvalue><!-- no values --></returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>view-class-name</parameter></term> + <listitem> + <para> + The name of a <glossterm linkend="gloss-view-class">View + Class</glossterm> that has been defined with <link + linkend="def-view-class"><function>def-view-class</function></link>. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>database</parameter></term> + <listitem> + <para> + The <glossterm + linkend="gloss-database-object">database</glossterm> in + which to create the SQL table. This will default to the + value of <symbol>*default-database*</symbol>. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>transactions</parameter></term> + <listitem> + <para> + When &nil; specifies that a table type which does not + support transactions should be used. + </para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para> + Creates a table as defined by the <glossterm + linkend="gloss-view-class">View Class</glossterm> + <parameter>view-class-name</parameter> in + <parameter>database</parameter>. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(def-view-class foo () ((a :type (string 80)))) +=> #<Standard-Db-Class FOO {4807F7CD}> +(create-view-from-class 'foo) +=> +(list-tables) +=> ("FOO") + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para> + Causes a table to be created in the SQL database. + </para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para> + Most SQL database systems will signal an error if a table + creation is attempted when a table with the same name already + exists. The SQL user, as specified in the database connection, + must have sufficient permission for table creation. + </para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para> + A condition will be signaled if the table can not be created + in the SQL database. + </para> + </refsect1> + <refsect1> + <title>See Also</title> + <para> + <simplelist> + <member><link linkend="def-view-class"><function>def-view-class</function></link></member> + <member><link linkend="drop-view-from-class"><function>drop-view-from-class</function></link></member> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Notes</title> + <para> + Currently, only &mysql; supports transactionless + tables. &clsql; provides the ability to create such tables for + applications which would benefit from faster table access and + do not require transaction support. + </para> + <para> + The case of the table name is determined by the type of the + database. &mysql;, for example, creates databases in upper-case + while &postgresql; uses lowercase. + </para> + </refsect1> + </refentry> + + <refentry id="def-view-class"> + <refnamediv> + <refname>DEF-VIEW-CLASS</refname> + <refpurpose>Defines CLOS classes with mapping to SQL database.</refpurpose> + <refclass>Macro</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis> + <function>def-view-class</function> <replaceable>name</replaceable> <replaceable>superclasses</replaceable> <replaceable>slots</replaceable> &rest <replaceable>class-options</replaceable> => <returnvalue>class</returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>name</parameter></term> + <listitem> + <para> + The class name. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>superclasses</parameter></term> + <listitem> + <para> + The superclasses for the defined class. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>slots</parameter></term> + <listitem> + <para> + The class slot definitions. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>class options</parameter></term> + <listitem> + <para> + The class options. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>class</parameter></term> + <listitem> + <para> + The defined class. + </para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Slot Options</title> + <itemizedlist> + <listitem> + <para> + <parameter>:db-kind</parameter> - specifies the kind of + database mapping which is performed for this slot and + defaults to <parameter>:base</parameter> which indicates + that the slot maps to an ordinary column of the database + table. A <parameter>:db-kind</parameter> value of + <parameter>:key</parameter> indicates that this slot is a + special kind of <parameter>:base</parameter> slot which + maps onto a column which is one of the unique keys for the + database table, the value <parameter>:join</parameter> + indicates this slot represents a join onto another + <glossterm linkend="gloss-view-class">View Class</glossterm> + which contains View Class objects, and the value + <parameter>:virtual</parameter> indicates a standard CLOS + slot which does not map onto columns of the database + table. + </para> + </listitem> + <listitem> + <para> + <parameter>:db-info</parameter> - if a slot is specified + with <parameter>:db-kind</parameter> + <parameter>:join</parameter>, the slot option + <parameter>:db-info</parameter> contains a property list + which specifies the nature of the join. The valid members + of the list are: + </para> + <itemizedlist> + <listitem> + <para> + <parameter>:join-class</parameter> + <emphasis>class-name</emphasis> - the name of the + class to join on. + </para> + </listitem> + <listitem> + <para> + <parameter>:home-key</parameter> + <emphasis>slot-name</emphasis> - the name of the slot + of this class for joining + </para> + </listitem> + <listitem> + <para> + <parameter>:foreign-key</parameter> + <emphasis>slot-name</emphasis> - the name of the slot + of the <parameter>:join-class</parameter> for joining + </para> + </listitem> + <listitem> + <para> + <parameter>:target-slot</parameter> + <emphasis>target-slot</emphasis> - this is an optional + parameter. If specified, then the join slot of the + defining class will contain instances of this target + slot rather than of the join class. This can be useful + when the <parameter>:join-class</parameter> is an + intermediate class in a + <emphasis>many-to-many</emphasis> relationship and the + application is actually interested in the + <parameter>:target-slot</parameter>. + </para> + </listitem> + <listitem> + <para> + <parameter>:retrieval</parameter> + <emphasis>time</emphasis> - The default value is + <parameter>:deferred</parameter>, which defers filling + this slot until the value is accessed. The other valid + value is <parameter>:immediate</parameter> which + performs the SQL query when the instance of the class + is created. In this case, the + <parameter>:set</parameter> is automatically set to + &nil; + </para> + </listitem> + <listitem> + <para> + <parameter>:set</parameter> <emphasis>set</emphasis> - + This controls what is stored in the join slot. The + default value is &t;. When <emphasis>set</emphasis> is + &t; and <emphasis>target-slot</emphasis> is undefined, + the join slot will contain a list of instances of the + join class. Whereas, if + <emphasis>target-slot</emphasis> is defined, then the + join slot will contain a list of pairs of + <emphasis>(target-value join-instance)</emphasis>. + When <emphasis>set</emphasis> is &nil;, the join slot + will contain a single instances. + </para> + </listitem> + </itemizedlist> + </listitem> + <listitem> + <para> + <parameter>:type</parameter> - for slots of + <parameter>:db-kind</parameter> <parameter>:base</parameter> or + <parameter>:key</parameter>, the <parameter>:type</parameter> slot + option has a special interpretation such that Lisp + types, such as string, integer and float are + automatically converted into appropriate SQL types for + the column onto which the slot maps. This behaviour may + be overridden using the <parameter>:db-type</parameter> slot + option. The valid values are: + <simplelist> + <member> + <parameter>string</parameter> - a variable length + character field up to <link + linkend="default-string-length">*default-string-length*</link> + characters. + </member> + <member> + <parameter>(string n)</parameter> - a fixed length + character field <parameter>n</parameter> characters + long. + </member> + <member> + <parameter>varchar</parameter> - a variable length + character field up to <link + linkend="default-string-length">*default-string-length*</link> + characters. + </member> + <member> + <parameter>(varchar n)</parameter> - a variable length + character field up to <parameter>n</parameter> + characters in length. + </member> + <member> + <parameter>char</parameter> - a single character field + </member> + <member><parameter>integer</parameter> - signed integer + at least 32-bits wide</member> + <member><parameter>(integer n)</parameter></member> + <member><parameter>float</parameter></member> + <member><parameter>(float n)</parameter></member> + <member><parameter>long-float</parameter></member> + <member><parameter>number</parameter></member> + <member><parameter>(number n)</parameter></member> + <member><parameter>(number n p)</parameter></member> + <member> + <parameter>tinyint</parameter> - An integer column 8-bits + wide. [not supported by all database backends] + </member> + <member> + <parameter>smallint</parameter> - An integer column 16-bits + wide. [not supported by all database backends] + </member> + <member> + <parameter>bigint</parameter> - An integer column + 64-bits wide. [not supported by all database backends] + </member> + <member> + <parameter>universal-time</parameter> - an integer + field sufficiently wide to store a + universal-time. On most databases, a slot of this + type assigned a SQL type of + <parameter>BIGINT</parameter> + </member> + <member> + <parameter>wall-time</parameter> - a slot which stores + a date and time in a SQL timestamp column. &clsql; + provides a number of time manipulation functions to + support objects of type <type>wall-time</type>. + </member> + <member> + <parameter>date</parameter> - a slot which stores the + date (without any time of day resolution) in a + column. &clsql; provides a number of time + manipulation functions that operate on date values. + </member> + <member> + <parameter>duration</parameter> - stores a + <type>duration</type> structure. &clsql; provides + routines for <type>wall-time</type> and + <type>duration</type> processing. + </member> + <member><parameter>boolean</parameter> - stores a &t; or + &nil; value.</member> + <member> + <parameter>generalized-boolean</parameter> - similar + to a <parameter>boolean</parameter> in that either a + &t; or &nil; value is stored in the SQL + database. However, any Lisp object can be stored in + the Lisp object. A Lisp value of &nil; is stored as + <constant>FALSE</constant> in the database, any + other Lisp value is stored as + <constant>TRUE</constant>. + </member> + <member> + <parameter>keyword</parameter> - stores a keyword + </member> + <member><parameter>symbol</parameter> - stores a symbol</member> + <member> + <parameter>list</parameter> - stores a list by writing + it to a string. The items in the list must be able to + be readable written. + </member> + <member><parameter>vector</parameter> - stores a vector + similarly to <parameter>list</parameter></member> + <member><parameter>array</parameter> - stores a array + similarly to <parameter>list</parameter></member> + </simplelist> + </para> + + </listitem> + <listitem> + <para> + <parameter>:column</parameter> - specifies the name of + the SQL column which the slot maps onto, if + <parameter>:db-kind</parameter> is not + <parameter>:virtual</parameter>, and defaults to the + slot name. If the slot name is used for the SQL column + name, any hypens in the slot name are converted + to underscore characters. + </para> + </listitem> + <listitem> + <para> + <parameter>:void-value</parameter> - specifies the value + to store in the Lisp instance if the SQL value is NULL and + defaults to NIL. + </para> + </listitem> + <listitem> + <para> + <parameter>:db-constraints</parameter> - is a keyword + symbol representing an SQL column constraint expression or + a list of such symbols. The following column constraints + are supported: <symbol>:not-null</symbol>, + <symbol>:primary-key</symbol>, <symbol>:unique</symbol>, + <symbol>:unsigned</symbol> (&mysql; specific), + <symbol>:zerofill</symbol> (&mysql; specific) and + <symbol>:auto-increment</symbol> (&mysql; specific). + </para> + </listitem> + <listitem> + <para> + <parameter>:db-type</parameter> - a string to specify the SQL + column type. If specified, this string overrides the SQL + column type as computed from the <parameter>:type</parameter> + slot value. + </para> + </listitem> + <listitem> + <para> + <parameter>:db-reader</parameter> - If a string, then when + reading values from the database, the string will be used + for a format string, with the only value being the value + from the database. The resulting string will be used as + the slot value. If a function then it will take one + argument, the value from the database, and return the + value that should be put into the slot. If a symbol, then + the symbol-function of the symbol will be used. + </para> + </listitem> + <listitem> + <para> + <parameter>:db-writer</parameter> - If a string, then when + reading values from the slot for the database, the string + will be used for a format string, with the only value + being the value of the slot. The resulting string will be + used as the column value in the database. If a function + then it will take one argument, the value of the slot, and + return the value that should be put into the database. If + a symbol, then the symbol-function of the symbol will be + used. + </para> + </listitem> + </itemizedlist> + </refsect1> + <refsect1> + <title>Class Options</title> + <para> + <itemizedlist> + <listitem> + <para> + <parameter>:base-table</parameter> - specifies the name + of the SQL database table. The default value is the + class name. Like slot names, hypens in the class name + are converted to underscore characters. + </para> + </listitem> + <listitem> + <para> + <parameter>:normalizedp</parameter> - specifies whether + this class uses normalized inheritance from parent classes. + Defaults to nil, i.e. non-normalized schemas. When true, + SQL database tables that map to this class and parent + classes are joined on their primary keys to get the full + set of database columns for this class. This means that + the primary key of the base class will be copied to all + subclasses as we insert so that all parent classes of an + instance will have the same value in their primary key slots + (see tests/ds-nodes.lisp and oodml.lisp) + </para> + </listitem> + </itemizedlist> + </para> + </refsect1> + <refsect1> + <title>Description</title> + <para> + Creates a <glossterm linkend="gloss-view-class">View + Class</glossterm> called <parameter>name</parameter> whose + slots <parameter>slots</parameter> can map onto the attributes + of a table in a database. If + <parameter>superclasses</parameter> is &nil; then the + superclass of <parameter>class</parameter> will be + <parameter>standard-db-object</parameter>, otherwise + <parameter>superclasses</parameter> is a list of superclasses + for <parameter>class</parameter> which must include + <parameter>standard-db-object</parameter> or a descendent of + this class. + </para> + + <refsect2> + <title>Normalized inheritance schemas</title> + <para> + Specifying that <symbol>:normalizedp</symbol> is <symbol>T</symbol> + tells &clsql; to normalize the database schema for inheritance. + What this means is shown in the examples below. + </para> + + <para> + With <symbol>:normalizedp</symbol> equal to <symbol>NIL</symbol> + (the default) the class inheritance would result in the following: + </para> + <screen> +(def-view-class node () + ((title :accessor title :initarg :title :type (varchar 240)))) + +SQL table NODE: ++-------+--------------+------+-----+---------+-------+ +| Field | Type | Null | Key | Default | Extra | ++-------+--------------+------+-----+---------+-------+ +| TITLE | varchar(240) | YES | | NULL | | ++-------+--------------+------+-----+---------+-------+ + +(def-view-class user (node) + ((user-id :accessor user-id :initarg :user-id + :type integer :db-kind :key :db-constraints (:not-null)) + (nick :accessor nick :initarg :nick :type (varchar 64)))) + +SQL table USER: ++---------+--------------+------+-----+---------+-------+ +| Field | Type | Null | Key | Default | Extra | ++---------+--------------+------+-----+---------+-------+ +| USER_ID | int(11) | NO | PRI | | | +| NICK | varchar(64) | YES | | NULL | | +| TITLE | varchar(240) | YES | | NULL | | ++---------+--------------+------+-----+---------+-------+ + </screen> + + <para> + Using <symbol>:normalizedp</symbol> <symbol>T</symbol>, both + view-classes need a primary key to join them on: + </para> + <screen> +(def-view-class node () + ((node-id :accessor node-id :initarg :node-id + :type integer :db-kind :key + :db-constraints (:not-null)) + (title :accessor title :initarg :title :type (varchar 240)))) + +SQL table NODE: ++---------+--------------+------+-----+---------+-------+ +| Field | Type | Null | Key | Default | Extra | ++---------+--------------+------+-----+---------+-------+ +| NODE_ID | int(11) | NO | PRI | | | +| TITLE | varchar(240) | YES | | NULL | | ++---------+--------------+------+-----+---------+-------+ + +(def-view-class user (node) + ((user-id :accessor user-id :initarg :user-id + :type integer :db-kind :key :db-constraints (:not-null)) + (nick :accessor nick :initarg :nick :type (varchar 64))) + (:normalizedp t)) + +SQL table USER: ++---------+-------------+------+-----+---------+-------+ +| Field | Type | Null | Key | Default | Extra | ++---------+-------------+------+-----+---------+-------+ +| USER_ID | int(11) | NO | PRI | | | +| NICK | varchar(64) | YES | | NULL | | ++---------+-------------+------+-----+---------+-------+ + </screen> + + <para> + In this second case, all slots of the view-class 'node + are also available in view-class 'user, and can be used + as one would expect. For example, with the above normalized + view-classes 'node and 'user, and SQL tracing turned on: + </para> + <screen> +CLSQL> (setq test-user (make-instance 'user :node-id 1 :nick "test-user" + :title "This is a test user")) +<![CDATA[#<USER {1003B392E1}>]]> + +CLSQL> (update-records-from-instance test-user :database db) +<![CDATA[ +;; .. => INSERT INTO NODE (NODE_ID,TITLE) VALUES (1,'This is a test user') +;; .. <= T +;; .. => INSERT INTO USER (USER_ID,NICK) VALUES (1,'test-user') +;; .. <= T +1 +]]> + +CLSQL> (node-id test-user) +1 + +CLSQL> (title test-user) +"This is a test user" + +CLSQL> (nick test-user) +"test-user" + </screen> + <para> + Notes from a refactor of this code. + + There are many assumptions that need to be met for normalized classes to work + + * The each of the classes should have its own single key column (of a different name) + that will contain an identical value. EG: node has a node-id, setting which + is a node has a node-id and a setting-id which must be equal. You cannot use + node-id as the primary key on both tables (as I would have expected). The exception + to this seems to be if your class has no slots at all, then you dont need to have a + single key column, because your class is fully represented in the db by its parent(s) + + * more than one parent class per normalized class should be considered experimental + and untested (vaya con Dios) + + * There are a few code paths that just dont pay any attention to normalized classes + eg: delete-records-for-instance + + </para> + </refsect2> + </refsect1> + <refsect1> + <title>Examples</title> + <para> + The following examples are from the &clsql; test suite. + </para> + <screen> +(def-view-class person (thing) + ((height :db-kind :base :accessor height :type float + :initarg :height) + (married :db-kind :base :accessor married :type boolean + :initarg :married) + (birthday :type clsql:wall-time :initarg :birthday) + (bd-utime :type clsql:universal-time :initarg :bd-utime) + (hobby :db-kind :virtual :initarg :hobby :initform nil))) + +(def-view-class employee (person) + ((emplid + :db-kind :key + :db-constraints :not-null + :type integer + :initarg :emplid) + (groupid + :db-kind :key + :db-constraints :not-null + :type integer + :initarg :groupid) + (first-name + :accessor first-name + :type (varchar 30) + :initarg :first-name) + (last-name + :accessor last-name + :type (varchar 30) + :initarg :last-name) + (email + :accessor employee-email + :type (varchar 100) + :initarg :email) + (ecompanyid + :type integer + :initarg :companyid) + (company + :accessor employee-company + :db-kind :join + :db-info (:join-class company + :home-key ecompanyid + :foreign-key companyid + :set nil)) + (managerid + :type integer + :initarg :managerid) + (manager + :accessor employee-manager + :db-kind :join + :db-info (:join-class employee + :home-key managerid + :foreign-key emplid + :set nil)) + (addresses + :accessor employee-addresses + :db-kind :join + :db-info (:join-class employee-address + :home-key emplid + :foreign-key aemplid + :target-slot address + :set t))) + (:base-table employee)) + +(def-view-class company () + ((companyid + :db-kind :key + :db-constraints :not-null + :type integer + :initarg :companyid) + (groupid + :db-kind :key + :db-constraints :not-null + :type integer + :initarg :groupid) + (name + :type (varchar 100) + :initarg :name) + (presidentid + :type integer + :initarg :presidentid) + (president + :reader president + :db-kind :join + :db-info (:join-class employee + :home-key presidentid + :foreign-key emplid + :set nil)) + (employees + :reader company-employees + :db-kind :join + :db-info (:join-class employee + :home-key (companyid groupid) + :foreign-key (ecompanyid groupid) + :set t)))) + +(def-view-class address () + ((addressid + :db-kind :key + :db-constraints :not-null + :type integer + :initarg :addressid) + (street-number + :type integer + :initarg :street-number) + (street-name + :type (varchar 30) + :void-value "" + :initarg :street-name) + (city + :column "city_field" + :void-value "no city" + :type (varchar 30) + :initarg :city) + (postal-code + :column zip + :type integer + :void-value 0 + :initarg :postal-code)) + (:base-table addr)) + +;; many employees can reside at many addressess +(def-view-class employee-address () + ((aemplid :type integer :initarg :emplid) + (aaddressid :type integer :initarg :addressid) + (verified :type boolean :initarg :verified) + (address :db-kind :join + :db-info (:join-class address + :home-key aaddressid + :foreign-key addressid + :retrieval :immediate))) + (:base-table "ea_join")) + +(def-view-class deferred-employee-address () + ((aemplid :type integer :initarg :emplid) + (aaddressid :type integer :initarg :addressid) + (verified :type boolean :initarg :verified) + (address :db-kind :join + :db-info (:join-class address + :home-key aaddressid + :foreign-key addressid + :retrieval :deferred + :set nil))) + (:base-table "ea_join")) + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para>Creates a new CLOS class.</para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para> + Nothing. + </para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para> + None. + </para> + </refsect1> + <refsect1> + <title>See Also</title> + <para> + <simplelist> + <member><link linkend="create-view-from-class"><function>create-view-from-class</function></link></member> + <member><link linkend="standard-db-object"><parameter>standard-db-object</parameter></link></member> + <member><link linkend="drop-view-from-class"><function>drop-view-from-class</function></link></member> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Notes</title> + <para> + The actual SQL type for a column depends up the database type + in which the SQL table is stored. As an example, the view + class type <parameter>(varchar 100)</parameter> specifies a + SQL column type <parameter>VARCHAR(100)</parameter> in &mysql; + and a column type <parameter>VARCHAR2(100)</parameter> in + &oracle; + </para> + <para> + The actual lisp type for a slot may be different than the + value specified by the <parameter>:type</parameter> attribute. + For example, a slot declared with "<parameter>:type (string + 30)</parameter>" actually sets the slots Lisp type as + <parameter>(or null string)</parameter>. This is to allow a + &nil; value or a string shorter than 30 characters to be + stored in the slot. + </para> + </refsect1> + </refentry> + + <refentry id="drop-view-from-class"> + <refnamediv> + <refname>DROP-VIEW-FROM-CLASS</refname> + <refpurpose>Delete table from SQL database.</refpurpose> + <refclass>Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis> + <function>drop-view-from-class</function> <replaceable>view-class-name</replaceable> &key <replaceable>database</replaceable> => <returnvalue><!-- result --></returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>view-class-name</parameter></term> + <listitem> + <para> + The name of the <glossterm linkend="gloss-view-class">View + Class</glossterm>. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>database</parameter></term> + <listitem> + <para> + <glossterm linkend="gloss-database-object">database + object</glossterm>. This will default to the value of + <symbol>*default-database*</symbol>. + </para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para>Removes a table defined by the <glossterm + linkend="gloss-view-class">View Class</glossterm> + <parameter>view-class-name</parameter> from + <parameter>database</parameter> which defaults to + <parameter>*default-database*</parameter>. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(list-tables) +=> ("FOO" "BAR") +(drop-view-from-class 'foo) +=> +(list-tables) +=> ("BAR") + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para> + Deletes a table from the SQL database. + </para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para> + Whether the specified table exists in the SQL database. + </para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para> + A condition may be signalled if the table does not exist in + the SQL database or if the SQL connection does not have + sufficient permissions to delete tables. + </para> + </refsect1> + <refsect1> + <title>See Also</title> + <para> + <simplelist> + <member><link linkend="create-view-from-class"><function>create-view-from-class</function></link></member> + <member><link linkend="def-view-class"><function>def-view-class</function></link></member> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Notes</title> + <para> + None. + </para> + </refsect1> + </refentry> + + <refentry id="list-classes"> + <refnamediv> + <refname>LIST-CLASSES</refname> + <refpurpose>List classes for tables in SQL database.</refpurpose> + <refclass>Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis> + <function>list-classes</function> &key <replaceable>test</replaceable> <replaceable>root-class</replaceable> <replaceable>database</replaceable> => <returnvalue>classes</returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>test</parameter></term> + <listitem> + <para> + a function used to filter the search. By default, <parameter>identity</parameter> is used which + will return all classes. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>root-class</parameter></term> + <listitem> + <para> + specifies the root class to the search. By default, + <parameter>standard-db-object</parameter> is used which + is the root for all view classes. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>database</parameter></term> + <listitem> + <para> + The <glossterm + linkend="gloss-database-object">database</glossterm> to + search for view classes. This will default to the value + of <symbol>*default-database*</symbol>. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>classes</parameter></term> + <listitem> + <para> + List of view classes. + </para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para>Returns a list of all the View Classes which have been + defined in the Lisp session and are connected to + <parameter>database</parameter> and which descended from the + class <parameter>root-class</parameter> and which satisfy the + function <parameter>test</parameter>. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(list-classes) +=> (#<clsql-sys::standard-db-class big> #<clsql-sys::standard-db-class employee-address> + #<clsql-sys::standard-db-class address> #<clsql-sys::standard-db-class company> + #<clsql-sys::standard-db-class employee>) + +(list-classes :test #'(lambda (c) (> (length (symbol-name (class-name c))) 3))) +=> (#<clsql-sys::standard-db-class employee-address> #<clsql-sys::standard-db-class address> + #<clsql-sys::standard-db-class company> #<clsql-sys::standard-db-class employee>) + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para> + None. + </para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para> + <simplelist> + <member>Which view classes have been defined in the Lisp + session.</member> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para> + None. + </para> + </refsect1> + <refsect1> + <title>See Also</title> + <para> + <simplelist> + <member><link linkend="def-view-class"><function>def-view-class</function></link></member> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Notes</title> + <para> + None. + </para> + </refsect1> + </refentry> + + +</reference> diff --git a/doc/ref-oodml.xml b/doc/ref-oodml.xml new file mode 100644 index 0000000..8a34235 --- /dev/null +++ b/doc/ref-oodml.xml @@ -0,0 +1,1078 @@ +<?xml version='1.0' ?> +<!DOCTYPE book PUBLIC "-//OASIS//DTD DocBook XML V4.2//EN" +"http://www.oasis-open.org/docbook/xml/4.2/docbookx.dtd" [ +<!ENTITY % myents SYSTEM "entities.inc"> +%myents; +]> + +<!-- Object Oriented Data Manipulation Language --> +<reference id="ref-oodml"> + <title>Object Oriented Data Manipulation Language (OODML)</title> + <partintro> + <para> + Object Oriented Data Manipulation Language (OODML) provides a + Common Lisp Object System (CLOS) interface to SQL + databases. View classes are defined with the <link + linkend="ref-ooddl">OODDL</link> interface and objects are read + and written with the OODML. + </para> + <para> + The main function for reading data with the OODML is the <link + linkend="select"><function>select</function></link> + function. The <function>select</function> is also used in the + FDML. However, when <function>select</function> is given a view + class name, it returns a list of instances of view classes. + </para> + <para> + View class instances can be updated to reflect any changes in + the database with the functions <link + linkend="update-slot-from-record"><function>update-slot-from-record</function></link> + and <link + linkend="update-instance-from-records"><function>update-instance-from-records</function></link>. + </para> + <para>To update the database to reflect changes made to instances of view classes, use the functions <link + linkend="update-records-from-instance"><function>update-records-from-instance</function></link>, + <link + linkend="update-record-from-slot"><function>update-record-from-slot</function></link>, and + <link + linkend="update-record-from-slots"><function>update-record-from-slots</function></link>. + </para> + <para> + The function <link + linkend="delete-instance-records"><function>delete-instance-records</function></link> + deletes the records corresponding to an instance of a view + class. + </para> + </partintro> + + <refentry id="db-auto-sync"> + <refnamediv> + <refname>*DB-AUTO-SYNC*</refname> + <refpurpose>Enables SQL storage during Lisp object creation.</refpurpose> + <refclass>Variable</refclass> + </refnamediv> + <refsect1> + <title>Value Type</title> + <para> + Boolean + </para> + </refsect1> + <refsect1> + <title>Initial Value</title> + <para>&nil;</para> + </refsect1> + <refsect1> + <title>Description</title> + <para> + When this variable is &t; an instance is stored in the SQL + database when the instance is created by + <function>make-instance</function>. Furthermore, the + appropriate database records are updated whenever the slots of + a <glossterm linkend="gloss-view-class">View Class</glossterm> + instance are modified. + </para> + <para> + When this variable is &nil;, which is the default value, + &clsql; behaves like &commonsql;: instances of view classes + are stored or updated in the SQL database only when <link + linkend="update-records-from-instance"><function>update-record-from-instance</function></link>, + <link + linkend="update-record-from-slot"><function>update-record-from-slot</function></link> + or <link + linkend="update-record-from-slots"><function>update-record-from-slots</function></link> + are called. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> + (let ((instance (make-instance 'foo))) + (update-records-from-instance instance)) + + ;; is equivalent to + + (let ((*db-auto-sync* t)) + (make-instance 'foo)) + + ;; and + + (progn + (setf (slot-value instance 'bar) "baz") + (update-record-from-slot instance 'bar)) + + ;; is equivalent to + + (let ((*db-auto-sync* t)) + (setf (slot-value instance 'bar) "baz")) + </screen> + </refsect1> + <refsect1> + <title>Affected By</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>See Also</title> + <simplelist> + <member><link linkend="update-records-from-instance"><function>update-records-from-instance</function></link></member> + <member><link linkend="update-record-from-slot"><function>update-record-from-slot</function></link></member> + <member><link linkend="update-record-from-slots"><function>update-record-from-slots</function></link></member> + </simplelist> + </refsect1> + <refsect1> + <title>Notes</title> + <para>This is a CLSQL extension to the CommonSQL API.</para> + </refsect1> + </refentry> + + <refentry id="default-caching"> + <refnamediv> + <refname>*DEFAULT-CACHING*</refname> + <refpurpose>Controls the default caching behavior.</refpurpose> + <refclass>Variable</refclass> + </refnamediv> + <refsect1> + <title>Value Type</title> + <para> + Boolean + </para> + </refsect1> + <refsect1> + <title>Initial Value</title> + <para>&t;</para> + </refsect1> + <refsect1> + <title>Description</title> + <para> + This variable stores the default value of the + <varname>CACHING</varname> keyword for the <link + linkend="select"><function>select</function></link>. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> + (let ((*default-caching* nil))) + (select 'foo)) + + ;; is equivalent to + + (select 'foo :caching nil) + </screen> + </refsect1> + <refsect1> + <title>Affected By</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>See Also</title> + <simplelist> + <member><link linkend="select"><function>select</function></link></member> + </simplelist> + </refsect1> + <refsect1> + <title>Notes</title> <para>This is a CLSQL extension to the + &commonsql; API. &commonsql; has caching on at all times.</para> + </refsect1> + </refentry> + + <refentry id="default-update-objects-max-len"> + <refnamediv> + <refname>*DEFAULT-UPDATE-OBJECTS-MAX-LEN*</refname> + <refpurpose>The default maximum number of objects each query to perform a join</refpurpose> + <refclass>Variable</refclass> + </refnamediv> + <refsect1> + <title>Value Type</title> + <para> + (or null integer) + </para> + </refsect1> + <refsect1> + <title>Initial Value</title> + <para>&nil;</para> + </refsect1> + <refsect1> + <title>Description</title> + <para> + This special variable provides the default value for the + <parameter>max-len</parameter> argument of the function <link + linkend="update-objects-joins"><function>update-object-joins</function></link>. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> + (setq *default-update-objects-max-len* 100) + </screen> + </refsect1> + <refsect1> + <title>Affected By</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>See Also</title> + <simplelist> + <member><link linkend="update-objects-joins"><function>update-object-joins</function></link></member> + </simplelist> + </refsect1> + <refsect1> + <title>Notes</title> + <para>None.</para> + </refsect1> + </refentry> + + <refentry id="instance-refreshed"> + <refnamediv> + <refname>INSTANCE-REFRESHED</refname> + <refpurpose>User hook to call on object refresh.</refpurpose> + <refclass>Generic function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis> + <function>instance-refreshed</function> <replaceable>object</replaceable> => <returnvalue><!-- no result --></returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>object</parameter></term> + <listitem> + <para> + The <glossterm linkend="gloss-view-class">View Class</glossterm> object which is being refreshed. + </para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para>Provides a hook which is called within an object oriented + call to <function>select</function> with a non-nil value of + <parameter>refresh</parameter> when the <glossterm + linkend="gloss-view-class">View Class</glossterm> instance + <parameter>object</parameter> has been updated from the + database. A method specialised on + <type>standard-db-object</type> is provided which has no + effects. Methods specialised on particular View Classes can be + used to specify any operations that need to be made on View + Classes instances which have been updated in calls to + <function>select</function>. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(slot-value employee1 'email) +=> "lenin@soviet.org" +(defmethod instance-refreshed ((e employee)) + (format t "~&Details for ~A ~A have been updated from the database." + (slot-value e 'first-name) + (slot-value e 'last-name))) +=> #<Standard-Method INSTANCE-REFRESHED (EMPLOYEE) {48174D9D}> +(select 'employee :where [= [slot-value 'employee 'emplid] 1] :flatp t) +=> (#<EMPLOYEE {48149995}>) +(slot-value (car *) 'email) +=> "lenin@soviet.org" +(update-records [employee] :av-pairs '(([email] "v.lenin@soviet.org")) + :where [= [emplid] 1]) +=> +(select 'employee :where [= [slot-value 'employee 'emplid] 1] :flatp t) +=> (#<EMPLOYEE {48149995}>) +(slot-value (car *) 'email) +=> "lenin@soviet.org" +(select 'employee :where [= [slot-value 'employee 'emplid] 1] :flatp t :refresh t) +Details for Vladimir Lenin have been updated from the database. +=> (#<EMPLOYEE {48149995}>) +(slot-value (car *) 'email) +=> "v.lenin@soviet.org" + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para> + The user hook function may cause side effects. + </para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para> + None. + </para> + </refsect1> + <refsect1> + <title>See Also</title> + <para> + <simplelist> + <member><link linkend="select"><function>select</function></link></member> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Notes</title> + <para> + None. + </para> + </refsect1> + </refentry> + + <refentry id="delete-instance-records"> + <refnamediv> + <refname>DELETE-INSTANCE-RECORDS</refname> + <refpurpose>Delete SQL records represented by a <glossterm linkend="gloss-view-class">View Class</glossterm> + object.</refpurpose> + <refclass>Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis> + <function>delete-instance-records</function> <replaceable>object</replaceable> => <returnvalue><!-- no result --></returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>object</parameter></term> + <listitem> + <para> + An instance of a <glossterm linkend="gloss-view-class">View + Class</glossterm>. + </para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para>Deletes the records represented by + <parameter>object</parameter> in the appropriate table of the + database associated with <parameter>object</parameter>. If + <parameter>object</parameter> is not yet associated with a + database, an error is signalled. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(def-view-class tab () + ((a :initarg :a :type integer :db-kind :key) + (b :initarg :b :type string))) +=> #<Standard-Db-Class TAB {49B01845}> +(create-view-from-class 'tab) +=> +(defvar obj (let ((*db-auto-sync* t)) + (make-instance 'tab :a 5 :b "the string"))) +=> OBJ +(start-sql-recording :type :both) +=> +(delete-instance-records obj) +;; 2004-07-17 11:07:19 foo/bar/baz => DELETE FROM tab WHERE tab.a = 5 +;; 2004-07-17 11:07:19 foo/bar/baz <= T +=> + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para> + Deletes data from the SQL database. + </para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para> + Permissions granted by the SQL database to the user in the + database connection. + </para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para> + An exception may be signaled if the database connection user + does not have sufficient privileges to modify the database. An + error of type <type>sql-database-error</type> is signalled if + <replaceable>object</replaceable> is not associated with an + active database. + </para> + </refsect1> + <refsect1> + <title>See Also</title> + <simplelist> + <member><link linkend="update-records"><function>update-records</function></link></member> + <member><link linkend="delete-records"><function>delete-records</function></link></member> + <member><link linkend="update-records-from-instance"><function>update-records-from-instance</function></link></member> + </simplelist> + </refsect1> + <refsect1> + <title>Notes</title> + <para> + Instances are referenced in the database by values stored in + the key slots. If + <function>delete-records-from-instance</function> is called + with an instance of a class that does not contain any keys, + then all records in that table will be deleted. + </para> + </refsect1> + </refentry> + + <refentry id="update-records-from-instance"> + <refnamediv> + <refname>UPDATE-RECORDS-FROM-INSTANCE</refname> + <refpurpose>Update database from view class object.</refpurpose> + <refclass>Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis> + <function>update-records-from-instance</function> <replaceable>object</replaceable> &key <replaceable>database</replaceable> => <returnvalue><!-- no result --></returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>object</parameter></term> + <listitem> + <para> + An instance of a <glossterm linkend="gloss-view-class">View + Class</glossterm>. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>database</parameter></term> + <listitem> + <para> + <glossterm linkend="gloss-database-object">database + object</glossterm>. This will default to the value of + <symbol>*default-database*</symbol>. + </para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para>Using an instance of a <glossterm + linkend="gloss-view-class">View Class</glossterm>, + <parameter>object</parameter>, update the table that stores its + instance data. <parameter>database</parameter> specifies the + database in which the update is made only if + <parameter>object</parameter> is not associated with a + database. In this case, a record is created in the appropriate + table of <parameter>database</parameter> using values from the + slot values of <parameter>object</parameter>, and + <parameter>object</parameter> becomes associated with + <parameter>database</parameter>. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(select [email] :from [employee] :where [= [emplid] 1] :field-names nil :flatp t) +=> ("lenin@soviet.org") +(defvar *e1* (car (select 'employee :where [= [slot-value 'employee 'emplid] 1] :flatp t))) +=> *E1* +(slot-value *e1* 'email) +=> "lenin@soviet.org" +(setf (slot-value *e1* 'email) "v.lenin@soviet.org") +=> "v.lenin@soviet.org" +(update-records-from-instance *e1*) +=> +(select [email] :from [employee] :where [= [emplid] 1] :field-names nil :flatp t) +=> ("v.lenin@soviet.org") + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para> + Modifies the database. + </para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para> + Nothing. + </para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para> + Database errors. + </para> + </refsect1> + <refsect1> + <title>See Also</title> + <simplelist> + <member><link linkend="update-record-from-slot"><function>update-record-from-slot</function></link></member> + <member><link linkend="update-record-from-slots"><function>update-record-from-slots</function></link></member> + <member><link linkend="update-records"><function>update-records</function></link></member> + </simplelist> + </refsect1> + <refsect1> + <title>Notes</title> + <para> + None. + </para> + </refsect1> + </refentry> + + <refentry id="update-record-from-slot"> + <refnamediv> + <refname>UPDATE-RECORD-FROM-SLOT</refname> + <refpurpose>Updates database from slot value.</refpurpose> + <refclass>Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis> + <function>update-record-from-slot</function> <replaceable>object</replaceable> <replaceable>slot</replaceable> &key <replaceable>database</replaceable> => <returnvalue><!-- no result --></returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>object</parameter></term> + <listitem> + <para> + An instance of a <glossterm linkend="gloss-view-class">View Class</glossterm>. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>slot</parameter></term> + <listitem> + <para> + The name of a slot in <parameter>object</parameter>. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>database</parameter></term> + <listitem> + <para> + A <glossterm linkend="gloss-database-object">database + object</glossterm>. This will default to the value of + <symbol>*default-database*</symbol>. + </para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para>Updates the value stored in the column represented by the + slot, specified by the CLOS slot name + <parameter>slot</parameter>, of <glossterm linkend="gloss-view-class">View Class</glossterm> instance + <parameter>object</parameter>. <parameter>database</parameter> + specifies the database in which the update is made only if + <parameter>object</parameter> is not associated with a + database. In this case, a record is created in + <parameter>database</parameter> and the attribute represented by + <parameter>slot</parameter> is initialised from the value of the + supplied slots with other attributes having default + values. Furthermore, <parameter>object</parameter> becomes + associated with <parameter>database</parameter>. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(select [email] :from [employee] :where [= [emplid] 1] :field-names nil :flatp t) +=> ("lenin@soviet.org") +(defvar *e1* (car (select 'employee :where [= [slot-value 'employee 'emplid] 1] :flatp t))) +=> *E1* +(slot-value *e1* 'email) +=> "lenin@soviet.org" +(setf (slot-value *e1* 'email) "v.lenin@soviet.org") +=> "v.lenin@soviet.org" +(update-record-from-slot *e1* 'email) +=> +(select [email] :from [employee] :where [= [emplid] 1] :field-names nil :flatp t) +=> ("v.lenin@soviet.org") + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para> + Modifies database. + </para> + </refsect1> + <refsect1> + <title>Affected By</title> + <para> + Nothing. + </para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para> + Database errors. + </para> + </refsect1> + <refsect1> + <title>See Also</title> + <simplelist> + <member><link linkend="update-record-from-slots"><function>update-record-from-slots</function></link></member> + <member><link linkend="update-records-from-instance"><function>update-records-from-instance</function></link></member> + </simplelist> + </refsect1> + <refsect1> + <title>Notes</title> + <para> + None. + </para> + </refsect1> + </refentry> + + <refentry id="update-record-from-slots"> + <refnamediv> + <refname>UPDATE-RECORD-FROM-SLOTS</refname> + <refpurpose>Update database from slots of view class object.</refpurpose> + <refclass>function</refclass> + </refnamediv> + <refsect1> + <title>syntax</title> + <synopsis> + <function>update-record-from-slots</function> <replaceable>object</replaceable> <replaceable>slots</replaceable> &key <replaceable>database</replaceable> => <returnvalue><!-- no result --></returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>object</parameter></term> + <listitem> + <para> + An instance of a <glossterm linkend="gloss-view-class">View Class</glossterm>. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>slots</parameter></term> + <listitem> + <para> + A list of slot names in <parameter>object</parameter>. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>database</parameter></term> + <listitem> + <para> + A <glossterm linkend="gloss-database-object">database + object</glossterm>. This will default to the value of + <symbol>*default-database*</symbol>. + </para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para>Updates the values stored in the columns represented by + the slots, specified by the clos slot names + <parameter>slots</parameter>, of <glossterm linkend="gloss-view-class">View Class</glossterm> instance + <parameter>object</parameter>. <parameter>database</parameter> + specifies the database in which the update is made only if + <parameter>object</parameter> is not associated with a + database. In this case, a record is created in the appropriate + table of <parameter>database</parameter> and the attributes + represented by <parameter>slots</parameter> are initialised from + the values of the supplied slots with other attributes having + default values. Furthermore, <parameter>object</parameter> + becomes associated with <parameter>database</parameter>. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(select [last-name] [email] :from [employee] :where [= [emplid] 1] :field-names nil) +=> (("Lenin" "lenin@soviet.org")) +(defvar *e1* (car (select 'employee :where [= [slot-value 'employee 'emplid] 1] :flatp t))) +=> *E1* +(slot-value *e1* 'last-name) +=> "Lenin" +(slot-value *e1* 'email) +=> "lenin@soviet.org" +(setf (slot-value *e1* 'last-name) "Ivanovich") +=> "Ivanovich" +(setf (slot-value *e1* 'email) "v.ivanovich@soviet.org") +=> "v.ivanovich@soviet.org" +(update-record-from-slots *e1* '(email last-name)) +=> +(select [last-name] [email] :from [employee] :where [= [emplid] 1] :field-names nil) +=> (("Ivanovich" "v.ivanovich@soviet.org")) + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para> + Modifies the SQL database. + </para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para> + Nothing. + </para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para> + Database errors. + </para> + </refsect1> + <refsect1> + <title>See Also</title> + <para> + <simplelist> + <member><link linkend="update-record-from-slot"><function>update-record-from-slot</function></link></member> + <member><link linkend="update-records-from-instance"><function>update-records-from-instance</function></link></member> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Notes</title> + <para> + None. + </para> + </refsect1> + </refentry> + + <refentry id="update-instance-from-records"> + <refnamediv> + <refname>UPDATE-INSTANCE-FROM-RECORDS</refname> + <refpurpose>Update slot values from database.</refpurpose> + <refclass>Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis> + <function>update-instance-from-records</function> <replaceable>object</replaceable> &key <replaceable>database</replaceable> => <returnvalue>object</returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>object</parameter></term> + <listitem> + <para> + An instance of a <glossterm linkend="gloss-view-class">View Class</glossterm>. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>database</parameter></term> + <listitem> + <para> + A <glossterm linkend="gloss-database-object">database + object</glossterm>. This will default to the value of + <symbol>*default-database*</symbol>. + </para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para>Updates the slot values of the <glossterm + linkend="gloss-view-class">View Class</glossterm> instance + <parameter>object</parameter> using the attribute values of the + appropriate table of <parameter>database</parameter> which + defaults to the database associated with + <parameter>object</parameter> or, if + <parameter>object</parameter> is not associated with a database, + <varname>*default-database*</varname>. Join slots are updated + but instances of the class on which the join is made are not + updated. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(defvar *e1* (car (select 'employee :where [= [slot-value 'employee 'emplid] 1] :flatp t))) +=> *E1* +(slot-value *e1* 'email) +=> "lenin@soviet.org" +(update-records [employee] + :av-pairs '(([email] "v.lenin@soviet.org")) + :where [= [emplid] 1]) +=> +(update-instance-from-records *e1*) +=> #<EMPLOYEE {4806B53D}> +(slot-value *e1* 'email) +=> "v.lenin@soviet.org" + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para> + Slot values of <parameter>object</parameter> may be modified. + </para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para> + <simplelist> + <member>Data in SQL database.</member> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para> + If <parameter>database</parameter> is not able to be read. + </para> + </refsect1> + <refsect1> + <title>See Also</title> + <simplelist> + <member><link linkend="update-slot-from-record"><function>update-slot-from-record</function></link></member> + <member><link linkend="update-objects-joins"><function>update-objects-joins</function></link></member> + </simplelist> + </refsect1> + <refsect1> + <title>Notes</title> + <para> + None. + </para> + </refsect1> + </refentry> + + <refentry id="update-slot-from-record"> + <refnamediv> + <refname>UPDATE-SLOT-FROM-RECORD</refname> + <refpurpose>Update objects slot from database.</refpurpose> + <refclass>Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis> + <function>update-slot-from-record</function> <replaceable>object</replaceable> <replaceable>slot</replaceable> &key <replaceable>database</replaceable> => <returnvalue>object</returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>object</parameter></term> + <listitem> + <para> + An instance of a <glossterm linkend="gloss-view-class">View Class</glossterm>. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>slot</parameter></term> + <listitem> + <para> + The name of a slot in <parameter>object</parameter>. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>database</parameter></term> + <listitem> + <para> + A <glossterm linkend="gloss-database-object">database + object</glossterm>. This will default to the value of + <symbol>*default-database*</symbol>. + </para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para>Updates the slot value, specified by the CLOS slot name + <parameter>slot</parameter>, of the <glossterm + linkend="gloss-view-class">View Class</glossterm> instance + <parameter>object</parameter> using the attribute values of the + appropriate table of <parameter>database</parameter> which + defaults to the database associated with + <parameter>object</parameter> or, if + <parameter>object</parameter> is not associated with a database, + <varname>*default-database*</varname>. Join slots are updated + but instances of the class on which the join is made are not + updated. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(defvar *e1* (car (select 'employee :where [= [slot-value 'employee 'emplid] 1] :flatp t))) +=> *E1* +(slot-value *e1* 'email) +=> "lenin@soviet.org" +(update-records [employee] + :av-pairs '(([email] "v.lenin@soviet.org")) + :where [= [emplid] 1]) +=> +(update-slot-from-record *e1* 'email) +=> #<EMPLOYEE {4806B53D}> +(slot-value *e1* 'email) +=> "v.lenin@soviet.org" + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para> + Modifies the slot value of the object. + </para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para> + <simplelist> + <member>Data in SQL database.</member> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para> + Database errors. + </para> + </refsect1> + <refsect1> + <title>See Also</title> + <simplelist> + <member><link linkend="update-instance-from-records"><function>update-instance-from-records</function></link></member> + <member><link linkend="update-objects-joins"><function>update-objects-joins</function></link></member> + </simplelist> + </refsect1> + <refsect1> + <title>Notes</title> + <para> + None. + </para> + </refsect1> + </refentry> + + <refentry id="update-objects-joins"> + <refnamediv> + <refname>UPDATE-OBJECTS-JOINS</refname> + <refpurpose>Updates joined slots of objects.</refpurpose> + <refclass>Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis> + <function>update-objects-joins</function> <replaceable>objects</replaceable> &key <replaceable>slots</replaceable> <replaceable>force-p</replaceable> <replaceable>class-name</replaceable> <replaceable>max-len</replaceable> => <returnvalue><!-- no result --></returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>objects</parameter></term> + <listitem> + <para> + A list of instances of a <glossterm + linkend="gloss-view-class">View Class</glossterm>. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>slots</parameter></term> + <listitem> + <para>* :immediate (default) - refresh join slots with :retrieval :immediate</para> + <para>* :deferred - refresh join slots created with :retrieval :deferred</para> + <para>* :all,t - refresh all join slots regardless of :retrieval</para> + <para>* list of symbols - which explicit slots to refresh</para> + <para>* a single symobl - what slot to refresh</para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>force-p</parameter></term> + <listitem> + <para> + A Boolean, defaulting to &t;. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>class-name</parameter></term> + <listitem> + <para> + A list of instances of a <glossterm + linkend="gloss-view-class">View Class</glossterm>. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>max-len</parameter></term> + <listitem> + <para> + A non-negative integer or &nil; defaulting to + <symbol>*default-update-objects-max-len*</symbol>. + When non-nil this is essentially a batch size for the max number of objects + to query from the database at a time. If we need more than max-len + we loop till we have all the objects + </para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para> + Updates from the records of the appropriate database tables the join slots + specified by SLOTS in the supplied list of + <glossterm linkend="gloss-view-class">View Class</glossterm> instances OBJECTS. + + A simpler method of causing a join-slot to be requeried is to set it to + unbound, then request it again. This function has efficiency gains where + join-objects are shared among the `objects` (querying all join-objects, + then attaching them appropriately to each of the `objects`) + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(defvar *addresses* (select 'deferred-employee-address :order-by [ea_join aaddressid] :flatp t)) +=> *ADDRESSES* +(slot-boundp (car *addresses*) 'address) +=> NIL +(update-objects-joins *addresses*) +=> +(slot-boundp (car *addresses*) 'address) +=> T +(slot-value (car *addresses*) 'address) +=> #<ADDRESS {480B0F1D}> + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para> + The slot values of <parameter>objects</parameter> are modified. + </para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para> + <simplelist> + <member><link + linkend="default-update-objects-max-len"><varname>*default-update-objects-max-len*</varname></link></member> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para> + Database errors. + </para> + </refsect1> + <refsect1> + <title>See Also</title> + <simplelist> + <member><link linkend="default-update-objects-max-len"><varname>*default-update-objects-max-len*</varname></link></member> + <member><link linkend="update-instance-from-records"><function>update-instance-from-records</function></link></member> + <member><link linkend="update-slot-from-record"><function>update-slot-from-record</function></link></member> + </simplelist> + </refsect1> + <refsect1> + <title>Notes</title> + <para> + None. + </para> + </refsect1> + </refentry> + +</reference> diff --git a/doc/ref-prepared.xml b/doc/ref-prepared.xml new file mode 100644 index 0000000..ff922fa --- /dev/null +++ b/doc/ref-prepared.xml @@ -0,0 +1,298 @@ +<?xml version='1.0' ?> +<!DOCTYPE book PUBLIC "-//OASIS//DTD DocBook XML V4.2//EN" +"http://www.oasis-open.org/docbook/xml/4.2/docbookx.dtd" [ +<!ENTITY % myents SYSTEM "entities.inc"> +%myents; +]> + +<!-- prepared statements --> + +<reference id="ref-prepared"> + <title>Prepared Statements</title> + <partintro> + <para> + <!-- introduction --> + </para> + </partintro> + + <refentry id="prepare-sql"> + <refmeta> + <refentrytitle>PREPARE-SQL</refentrytitle> + </refmeta> + <refnamediv> + <refname>>PREPARE-SQL</refname> + <refpurpose>Create a prepared statement.</refpurpose> + <refclass>Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis> + <function>prepare-sql</function> <replaceable>sql-stmt types</replaceable> &key <replaceable>database</replaceable> <replaceable>result-types</replaceable> <replaceable>field-names</replaceable> => <returnvalue>result</returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <!-- arguments and values --> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para>Prepares a SQL statement <parameter>sql-stmt</parameter> + for execution. <parameter>types</parameter> contains a list of + types corresponding to the input parameters. Returns a + prepared-statement object. + + A type can be + :int + :double + :null + (:string n) + + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> + <!-- examples --> + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para> + <!-- side effects --> + </para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para> + <simplelist> + <!-- affected by --> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para> + <!-- execeptional situations --> + </para> + </refsect1> + <refsect1> + <title>See Also</title> + <para> + <simplelist> + <!-- see also --> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Notes</title> + <para> + <!-- notes --> + </para> + </refsect1> + </refentry> + + <refentry id="run-prepared-sql"> + <refmeta> + <refentrytitle>RUN-PREPARED-SQL</refentrytitle> + </refmeta> + <refnamediv> + <refname>RUN-PREPARED-SQL</refname> + <refpurpose>Execute a prepared statement.</refpurpose> + <refclass>Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis> + <function>run-prepared-sql</function> <replaceable>prepared-stmt</replaceable> => <returnvalue><!-- result --></returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <!-- arguments and values --> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para>Execute the prepared sql statment. All input + parameters must be bound. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> + <!-- examples --> + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para> + <!-- side effects --> + </para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para> + <simplelist> + <!-- affected by --> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para> + <!-- execeptional situations --> + </para> + </refsect1> + <refsect1> + <title>See Also</title> + <para> + <simplelist> + <!-- see also --> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Notes</title> + <para> + <!-- notes --> + </para> + </refsect1> + </refentry> + + <refentry id="free-prepared-sql"> + <refmeta> + <refentrytitle>FREE-PREPARED-SQL</refentrytitle> + </refmeta> + <refnamediv> + <refname>FREE-PREPARED-SQL</refname> + <refpurpose>Delete a prepared statement object.</refpurpose> + <refclass>Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis> + <function>free-prepared-sql</function> <replaceable>prepared-stmt</replaceable> => <returnvalue><!-- result --></returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <!-- arguments and values --> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para>Delete the objects associated with a prepared + statement. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> + <!-- examples --> + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para> + <!-- side effects --> + </para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para> + <simplelist> + <!-- affected by --> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para> + <!-- execeptional situations --> + </para> + </refsect1> + <refsect1> + <title>See Also</title> + <para> + <simplelist> + <!-- see also --> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Notes</title> + <para> + <!-- notes --> + </para> + </refsect1> + </refentry> + + <refentry id="bind-parameter"> + <refmeta> + <refentrytitle>BIND-PARAMETER</refentrytitle> + </refmeta> + <refnamediv> + <refname>BIND-PARAMETER</refname> + <refpurpose>Bind a parameter in a prepared statement.</refpurpose> + <refclass>Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis> + <function>bind-parameter</function> <replaceable>prepared-stmt</replaceable> <replaceable>position</replaceable> <replaceable>value</replaceable> => <returnvalue><!-- result --></returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <!-- arguments and values --> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para>Sets the value of a parameter in a prepared statement. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> + <!-- examples --> + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para> + <!-- side effects --> + </para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para> + <simplelist> + <!-- affected by --> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para> + <!-- execeptional situations --> + </para> + </refsect1> + <refsect1> + <title>See Also</title> + <para> + <simplelist> + <!-- see also --> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Notes</title> + <para> + <!-- notes --> + </para> + </refsect1> + </refentry> + +</reference> diff --git a/doc/ref-recording.xml b/doc/ref-recording.xml new file mode 100644 index 0000000..fb4fc1c --- /dev/null +++ b/doc/ref-recording.xml @@ -0,0 +1,825 @@ +<?xml version='1.0' ?> +<!DOCTYPE book PUBLIC "-//OASIS//DTD DocBook XML V4.2//EN" +"http://www.oasis-open.org/docbook/xml/4.2/docbookx.dtd" [ +<!ENTITY % myents SYSTEM "entities.inc"> +%myents; +]> + +<!-- SQL I/0 Recording --> + +<reference id="ref-recording"> + <title>SQL I/O Recording</title> + <partintro> + <para> + &clsql; provides a facility for recording SQL commands sent to + and/or results returned from the underlying RDBMS to user + sprecified streams. This is useful for monitoring &clsql; + activity and for debugging applications. + </para> + <para> + This section documents the functions provided for enabling and + disabling SQL recording as well as for manipulating the streams + on to which SQL commands and results are recorded. + </para> + </partintro> + + <refentry id="start-sql-recording"> + <refmeta> + <refentrytitle>START-SQL-RECORDING</refentrytitle> + </refmeta> + <refnamediv> + <refname>START-SQL-RECORDING</refname> + <refpurpose>Start recording SQL commands or results.</refpurpose> + <refclass>Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis> + <function>start-sql-recording</function> &key <replaceable>type</replaceable> <replaceable>database</replaceable> => <returnvalue></returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>type</parameter></term> + <listitem> + <para> + One of the following keyword symbols: + <symbol>:commands</symbol>, <symbol>:results</symbol> or + <symbol>:both</symbol>, defaulting to + <symbol>:commands</symbol>. + </para> + </listitem> + </varlistentry> <varlistentry> + <term><parameter>database</parameter></term> + <listitem> + <para>A + <glossterm linkend="gloss-database-object">database + object</glossterm>. This will default to + <symbol>*default-database*</symbol>.</para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para>Starts recording of SQL commands sent to and/or results + returned from <parameter>database</parameter> which defaults to + <symbol>*default-database*</symbol>. The SQL is output on one or + more broadcast streams, initially just + <symbol>*standard-output*</symbol>, and the functions + <function>add-sql-stream</function> and + <function>delete-sql-stream</function> may be used to add or + delete command or result recording streams. The default value of + <parameter>type</parameter> is <symbol>:commands</symbol> which + means that SQL commands sent to <parameter>database</parameter> + are recorded. If <parameter>type</parameter> is + <symbol>:results</symbol> then SQL results returned from + <parameter>database</parameter> are recorded. Both commands and + results may be recorded by passing <parameter>type</parameter> + value of <symbol>:both</symbol>. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(start-sql-recording :type :both) +=> +(select [last-name] :from [employee] + :where [= [emplid] 1] + :field-names nil + :flatp t) +;; 2004-07-02 16:42:12 dent/test/dent => SELECT last_name FROM employee WHERE (emplid = 1) +;; 2004-07-02 16:42:12 dent/test/dent <= (Lenin) +=> ("Lenin") + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para> + The command and result recording broadcast streams associated + with <parameter>database</parameter> are reinitialised with + only <symbol>*standard-output*</symbol> as their component + streams. + </para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para> + None. + </para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para> + None. + </para> + </refsect1> + <refsect1> + <title>See Also</title> + <simplelist> + <member><link linkend="stop-sql-recording"><function>stop-sql-recording</function></link></member> + <member><link linkend="sql-recording-p"><function>sql-recording-p</function></link></member> + <member><link linkend="sql-stream"><function>sql-stream</function></link></member> + <member><link linkend="add-sql-stream"><function>add-sql-stream</function></link></member> + <member><link linkend="delete-sql-stream"><function>delete-sql-stream</function></link></member> + <member><link linkend="list-sql-streams"><function>list-sql-streams</function></link></member> + </simplelist> + </refsect1> + <refsect1> + <title>Notes</title> + <para> + None. + </para> + </refsect1> + </refentry> + + <refentry id="stop-sql-recording"> + <refmeta> + <refentrytitle>STOP-SQL-RECORDING</refentrytitle> + </refmeta> + <refnamediv> + <refname>STOP-SQL-RECORDING</refname> + <refpurpose>Stop recording SQL commands or results.</refpurpose> + <refclass>Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis> + <function>stop-sql-recording</function> &key <replaceable>type</replaceable> <replaceable>database</replaceable> => <returnvalue></returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>type</parameter></term> + <listitem> + <para> + One of the following keyword symbols: + <symbol>:commands</symbol>, <symbol>:results</symbol> or + <symbol>:both</symbol>, defaulting to + <symbol>:commands</symbol>. + </para> + </listitem> + </varlistentry> <varlistentry> + <term><parameter>database</parameter></term> + <listitem> + <para>A + <glossterm linkend="gloss-database-object">database + object</glossterm>. This will default to + <symbol>*default-database*</symbol>.</para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para>Stops recording of SQL commands sent to and/or results + returned from <parameter>database</parameter> which defaults to + <symbol>*default-database*</symbol>. The default value of + <parameter>type</parameter> is <symbol>:commands</symbol> which + means that SQL commands sent to <parameter>database</parameter> + will no longer be recorded. If <parameter>type</parameter> is + <symbol>:results</symbol> then SQL results returned from + <parameter>database</parameter> will no longer be + recorded. Recording may be stopped for both commands and results + by passing <parameter>type</parameter> value of + <symbol>:both</symbol>. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(start-sql-recording :type :both) +=> +(select [last-name] :from [employee] + :where [= [emplid] 1] + :field-names nil + :flatp t) +;; 2004-07-02 16:42:12 dent/test/dent => SELECT last_name FROM employee WHERE (emplid = 1) +;; 2004-07-02 16:42:12 dent/test/dent <= (Lenin) +=> ("Lenin") +(stop-sql-recording :type :results) +=> +(select [last-name] :from [employee] + :where [= [emplid] 1] + :field-names nil + :flatp t) +;; 2004-07-02 16:44:11 dent/test/dent => SELECT last_name FROM employee WHERE (emplid = 1) +=> ("Lenin") + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para> + The command and result recording broadcast streams associated + with <parameter>database</parameter> are reinitialised to + &nil;. + </para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para> + None. + </para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para> + None. + </para> + </refsect1> + <refsect1> + <title>See Also</title> + <simplelist> + <member><link linkend="start-sql-recording"><function>start-sql-recording</function></link></member> + <member><link linkend="sql-recording-p"><function>sql-recording-p</function></link></member> + </simplelist> + </refsect1> + <refsect1> + <title>Notes</title> + <para> + None. + </para> + </refsect1> + </refentry> + + <refentry id="sql-recording-p"> + <refmeta> + <refentrytitle>SQL-RECORDING-P</refentrytitle> + </refmeta> + <refnamediv> + <refname>SQL-RECORDING-P</refname> + <refpurpose>Tests whether SQL commands or results are being recorded.</refpurpose> + <refclass>Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis> + <function>sql-recording-p</function> &key <replaceable>type</replaceable> <replaceable>database</replaceable> => <returnvalue>result</returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>type</parameter></term> + <listitem> + <para> + One of the following keyword symbols: + <symbol>:commands</symbol>, <symbol>:results</symbol>, + <symbol>:both</symbol> or <symbol>:either</symbol> + defaulting to <symbol>:commands</symbol>. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>database</parameter></term> + <listitem> + <para>A + <glossterm linkend="gloss-database-object">database + object</glossterm>. This will default to + <symbol>*default-database*</symbol>.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>result</parameter></term> + <listitem> + <para> + A Boolean. + </para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para>Predicate to test whether the SQL recording specified by + <parameter>type</parameter> is currently enabled for + <parameter>database</parameter> which defaults to + <symbol>*default-database*</symbol>. + <parameter>type</parameter> may be one of + <symbol>:commands</symbol>, <symbol>:results</symbol>, + <symbol>:both</symbol> or <symbol>:either</symbol>, defaulting + to <symbol>:commands</symbol>, otherwise &nil; is returned. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(start-sql-recording :type :commands) +=> +(sql-recording-p :type :commands) +=> T +(sql-recording-p :type :both) +=> NIL +(sql-recording-p :type :either) +=> T + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para> + None. + </para> + </refsect1> + <refsect1> + <title>Affected by</title> + <simplelist> + <member><link linkend="start-sql-recording"><function>start-sql-recording</function></link></member> + <member><link linkend="stop-sql-recording"><function>stop-sql-recording</function></link></member> + </simplelist> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para> + None. + </para> + </refsect1> + <refsect1> + <title>See Also</title> + <simplelist> + <member><link linkend="start-sql-recording"><function>start-sql-recording</function></link></member> + <member><link linkend="stop-sql-recording"><function>stop-sql-recording</function></link></member> + </simplelist> + </refsect1> + <refsect1> + <title>Notes</title> + <para> + The <symbol>:both</symbol> and <symbol>:either</symbol> values + for the <parameter>type</parameter> keyword argument are + &clsql; extensions. + </para> + </refsect1> + </refentry> + + <refentry id="sql-stream"> + <refmeta> + <refentrytitle>SQL-STREAM</refentrytitle> + </refmeta> + <refnamediv> + <refname>SQL-STREAM</refname> + <refpurpose>Returns the broadcast stream used for recording SQL commands or results.</refpurpose> + <refclass>Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis> + <function>sql-stream</function> &key <replaceable>type</replaceable> <replaceable>database</replaceable> => <returnvalue>result</returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>type</parameter></term> + <listitem> + <para> + One of the following keyword symbols: + <symbol>:commands</symbol> or <symbol>:results</symbol>, + defaulting to <symbol>:commands</symbol>. + </para> + </listitem> + </varlistentry> <varlistentry> + <term><parameter>database</parameter></term> + <listitem> + <para>A + <glossterm linkend="gloss-database-object">database + object</glossterm>. This will default to + <symbol>*default-database*</symbol>.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>result</parameter></term> + <listitem> + <para> + A broadcast stream or &nil;. + </para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para>Returns the broadcast stream used for recording SQL + commands sent to or results returned from + <parameter>database</parameter> which defaults to + <symbol>*default-database*</symbol>. <parameter>type</parameter> + must be one of <symbol>:commands</symbol> or + <symbol>:results</symbol>, defaulting to + <symbol>:commands</symbol>, and determines whether the stream + returned is that used for recording SQL commands or results. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(start-sql-recording :type :commands) +=> +(sql-stream :type :commands) +=> #<Broadcast Stream> +(sql-stream :type :results) +=> NIL + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para> + None. + </para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para> + None. + </para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para> + An error is signalled if <parameter>type</parameter> is not + one of <symbol>:commands</symbol> or + <symbol>:results</symbol>. + </para> + </refsect1> + <refsect1> + <title>See Also</title> + <simplelist> + <member><link linkend="start-sql-recording"><function>start-sql-recording</function></link></member> + <member><link linkend="add-sql-stream"><function>add-sql-stream</function></link></member> + <member><link linkend="delete-sql-stream"><function>delete-sql-stream</function></link></member> + <member><link linkend="list-sql-streams"><function>list-sql-streams</function></link></member> + </simplelist> + </refsect1> + <refsect1> + <title>Notes</title> + <para> + None. + </para> + </refsect1> + </refentry> + + <refentry id="add-sql-stream"> + <refmeta> + <refentrytitle>ADD-SQL-STREAM</refentrytitle> + </refmeta> + <refnamediv> + <refname>ADD-SQL-STREAM</refname> + <refpurpose>Add a component to the broadcast streams used for recording SQL commands or results.</refpurpose> + <refclass>Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis> + <function>add-sql-stream</function> <replaceable>stream</replaceable> &key <replaceable>type</replaceable> <replaceable>database</replaceable> => <returnvalue>result</returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>stream</parameter></term> + <listitem> + <para> + A stream or &t;. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>type</parameter></term> + <listitem> + <para> + One of the following keyword symbols: + <symbol>:commands</symbol>, <symbol>:results</symbol> or + <symbol>:both</symbol>, defaulting to + <symbol>:commands</symbol>. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>database</parameter></term> + <listitem> + <para>A + <glossterm linkend="gloss-database-object">database + object</glossterm>. This will default to + <symbol>*default-database*</symbol>.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>result</parameter></term> + <listitem> + <para> + The added stream. + </para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para>Adds the supplied stream <parameter>stream</parameter> (or + &t; for <symbol>*standard-output*</symbol>) as a component of + the recording broadcast stream for the SQL recording type + specified by <parameter>type</parameter> on + <parameter>database</parameter> which defaults to + <symbol>*default-database*</symbol>. <parameter>type</parameter> + must be one of <symbol>:commands</symbol>, + <symbol>:results</symbol>, or <symbol>:both</symbol>, defaulting + to <symbol>:commands</symbol>, depending on whether the stream + is to be added for recording SQL commands, results or both. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(start-sql-recording :type :commands) +=> +(with-output-to-string (s) + (add-sql-stream s :type :commands) + (print-query [select [emplid] [first-name] [last-name] [email] :from [employee]] + :stream s)) + +;; 2004-07-02 17:38:45 dent/test/dent => SELECT emplid,first_name,last_name,email FROM employee +=> +";; 2004-07-02 17:38:45 dent/test/dent => SELECT emplid,first_name,last_name,email FROM employee +1 Vladimir Lenin lenin@soviet.org +2 Josef Stalin stalin@soviet.org +3 Leon Trotsky trotsky@soviet.org +4 Nikita Kruschev kruschev@soviet.org +5 Leonid Brezhnev brezhnev@soviet.org +6 Yuri Andropov andropov@soviet.org +7 Konstantin Chernenko chernenko@soviet.org +8 Mikhail Gorbachev gorbachev@soviet.org +9 Boris Yeltsin yeltsin@soviet.org +10 Vladimir Putin putin@soviet.org " + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para> + The specified broadcast stream(s) associated with + <parameter>database</parameter> are modified. + </para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para> + None. + </para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para> + None. + </para> + </refsect1> + <refsect1> + <title>See Also</title> + <simplelist> + <member><link linkend="start-sql-recording"><function>start-sql-recording</function></link></member> + <member><link linkend="sql-stream"><function>sql-stream</function></link></member> + <member><link linkend="delete-sql-stream"><function>delete-sql-stream</function></link></member> + <member><link linkend="list-sql-streams"><function>list-sql-streams</function></link></member> + </simplelist> + </refsect1> + <refsect1> + <title>Notes</title> + <para> + None. + </para> + </refsect1> + </refentry> + + <refentry id="delete-sql-stream"> + <refmeta> + <refentrytitle>DELETE-SQL-STREAM</refentrytitle> + </refmeta> + <refnamediv> + <refname>DELETE-SQL-STREAM</refname> + <refpurpose>Remove a component from the broadcast streams used for recording SQL commands or results.</refpurpose> + <refclass>Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis> + <function>delete-sql-stream</function> <replaceable>stream</replaceable> &KEY <replaceable>type</replaceable> <replaceable>database</replaceable> => <returnvalue>result</returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>stream</parameter></term> + <listitem> + <para> + A stream or &t;. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>stream</parameter></term> + <listitem> + <para> + A stream or &t;. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>type</parameter></term> + <listitem> + <para> + One of the following keyword symbols: + <symbol>:commands</symbol>, <symbol>:results</symbol> or + <symbol>:both</symbol>, defaulting to + <symbol>:commands</symbol>. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>database</parameter></term> + <listitem> + <para>A + <glossterm linkend="gloss-database-object">database + object</glossterm>. This will default to + <symbol>*default-database*</symbol>.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>result</parameter></term> + <listitem> + <para> + The added stream. + </para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para>Removes the supplied stream <parameter>stream</parameter> + from the recording broadcast stream for the SQL recording type + specified by <parameter>type</parameter> on + <parameter>database</parameter> which defaults to + <symbol>*default-database*</symbol>. <parameter>type</parameter> + must be one of <symbol>:commands</symbol>, + <symbol>:results</symbol>, or <symbol>:both</symbol>, defaulting + to <symbol>:commands</symbol>, depending on whether the stream + is to be added for recording SQL commands, results or both. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(list-sql-streams :type :both) +=> (#<Stream for descriptor 7> #<Stream for descriptor 7>) +(delete-sql-stream *standard-output* :type :results) +=> #<Stream for descriptor 7> +(list-sql-streams :type :both) +=> (#<Stream for descriptor 7>) + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para> + The specified broadcast stream(s) associated with + <parameter>database</parameter> are modified. + </para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para> + None. + </para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para> + None. + </para> + </refsect1> + <refsect1> + <title>See Also</title> + <simplelist> + <member><link linkend="start-sql-recording"><function>start-sql-recording</function></link></member> + <member><link linkend="stop-sql-recording"><function>stop-sql-recording</function></link></member> + <member><link linkend="sql-recording-p"><function>sql-recording-p</function></link></member> + <member><link linkend="sql-stream"><function>sql-stream</function></link></member> + <member><link linkend="add-sql-stream"><function>add-sql-stream</function></link></member> + <member><link linkend="delete-sql-stream"><function>delete-sql-stream</function></link></member> + <member><link linkend="list-sql-streams"><function>list-sql-streams</function></link></member> + </simplelist> + </refsect1> + <refsect1> + <title>Notes</title> + <para> + None. + </para> + </refsect1> + </refentry> + + <refentry id="list-sql-streams"> + <refmeta> + <refentrytitle>LIST-SQL-STREAMS</refentrytitle> + </refmeta> + <refnamediv> + <refname>LIST-SQL-STREAMS</refname> + <refpurpose>List the components of the broadcast streams used for recording SQL commands or results.</refpurpose> + <refclass>Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis> + <function>list-sql-streams</function> &key <replaceable>type</replaceable> <replaceable>database</replaceable> => <returnvalue>result</returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>type</parameter></term> + <listitem> + <para> + One of the following keyword symbols: + <symbol>:commands</symbol>, <symbol>:results</symbol> or + <symbol>:both</symbol>, defaulting to + <symbol>:commands</symbol>. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>database</parameter></term> + <listitem> + <para>A + <glossterm linkend="gloss-database-object">database + object</glossterm>. This will default to + <symbol>*default-database*</symbol>.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>result</parameter></term> + <listitem> + <para> + A list. + </para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para>Returns the list of component streams for the broadcast + stream recording SQL commands sent to and/or results returned + from <parameter>database</parameter> which defaults to + <symbol>*default-database*</symbol>. <parameter>type</parameter> + must be one of <symbol>:commands</symbol>, + <symbol>:results</symbol>, or <symbol>:both</symbol>, defaulting + to <symbol>:commands</symbol>, and determines whether the listed + streams contain those recording SQL commands, results or both. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(list-sql-streams :type :both) +=> NIL +(start-sql-recording :type :both) +=> +(list-sql-streams :type :both) +=> (#<Stream for descriptor 7> #<Stream for descriptor 7>) + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para> + None. + </para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para> + <simplelist> + <member><link linkend="add-sql-stream"><function>add-sql-stream</function></link></member> + <member><link linkend="delete-sql-stream"><function>delete-sql-stream</function></link></member> + </simplelist> + </para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para> + An error is signalled if <parameter>type</parameter> is passed + a value other than <symbol>:commands</symbol>, + <symbol>:results</symbol> or <symbol>:both</symbol>. + </para> + </refsect1> + <refsect1> + <title>See Also</title> + <simplelist> + <member><link linkend="sql-stream"><function>sql-stream</function></link></member> + <member><link linkend="add-sql-stream"><function>add-sql-stream</function></link></member> + <member><link linkend="delete-sql-stream"><function>delete-sql-stream</function></link></member> + </simplelist> + </refsect1> + <refsect1> + <title>Notes</title> + <para> + None. + </para> + </refsect1> + </refentry> + +</reference> diff --git a/doc/ref-syntax.xml b/doc/ref-syntax.xml new file mode 100644 index 0000000..e0364fa --- /dev/null +++ b/doc/ref-syntax.xml @@ -0,0 +1,1058 @@ +<?xml version='1.0' ?> +<!DOCTYPE book PUBLIC "-//OASIS//DTD DocBook XML V4.2//EN" +"http://www.oasis-open.org/docbook/xml/4.2/docbookx.dtd" [ +<!ENTITY % myents SYSTEM "entities.inc"> +%myents; +]> + +<!-- Symbolic SQL Syntax --> +<reference id="ref-syntax"> + <title>The Symbolic SQL Syntax</title> + <partintro> + <para> + &clsql; provides a symbolic syntax allowing the construction of + SQL expressions as lists delimited by square brackets. The + syntax is turned off by default. This section describes + utilities for enabling and disabling the square bracket reader + syntax and for constructing symbolic SQL expressions. + </para> + <tip> + <title>Tip: just want it on</title> + <simpara> + <link linkend="file-enable-sql-reader-syntax"><function>file-enable-sql-reader-syntax</function></link> at the top of each file is easiest. + </simpara> + </tip> + </partintro> + + <refentry id="enable-sql-reader-syntax"> + <refmeta> + <refentrytitle>ENABLE-SQL-READER-SYNTAX</refentrytitle> + </refmeta> + <refnamediv> + <refname>ENABLE-SQL-READER-SYNTAX</refname> + <refpurpose>Globally enable square bracket reader syntax.</refpurpose> + <refclass>Macro</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis> + <function>enable-sql-reader-syntax</function> => <returnvalue></returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>Description</title> + <para>Turns on the SQL reader syntax setting the syntax state + such that if the syntax is subsequently disabled, <link + linkend="restore-sql-reader-syntax-state"> + <function>restore-sql-reader-syntax-state</function></link> will + enable it again. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para> + Sets the internal syntax state to enabled. + </para> + <para> + Modifies the default readtable. + </para> + <warning> + <para> + &clsql; tries to keep track of whether the syntax has already been enabled. This can be problematic if the syntax is somehow disabled externally to &clsql; as future attempts to enable the syntax will do nothing--the system thinks it is already enabled. This may happen if there is an enable, but no disable, in a file that is processed with load or compile-file as the lisp implementation will restore the readtable on completion. Or, even if there is a disable but a compiler-error is encountered before running the disable. If you encounter this try running <link linkend="disable-sql-reader-syntax"><function>disable-sql-reader-syntax</function></link> a couple times in the REPL. + </para> + <para>See <link linkend="file-enable-sql-reader-syntax"><function>file-enable-sql-reader-syntax</function></link> for an alternative.</para> + </warning> + </refsect1> + <refsect1> + <title>Affected by</title> + <para> + None. + </para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para> + None. + </para> + </refsect1> + <refsect1> + <title>See Also</title> + <simplelist> + <member><link linkend="disable-sql-reader-syntax"><function>disable-sql-reader-syntax</function></link></member> + <member><link linkend="locally-enable-sql-reader-syntax"><function>locally-enable-sql-reader-syntax</function></link></member> + <member><link linkend="locally-disable-sql-reader-syntax"><function>locally-disable-sql-reader-syntax</function></link></member> + <member><link linkend="restore-sql-reader-syntax-state"><function>restore-sql-reader-syntax-state</function></link></member> + <member><link linkend="file-enable-sql-reader-syntax"><function>file-enable-sql-reader-syntax</function></link></member> + </simplelist> + </refsect1> + <refsect1> + <title>Notes</title> + <para> + The symbolic SQL syntax is disabled by default. + </para> + <para> + &clsql; differs from &commonsql; in that + <function>enable-sql-reader-syntax</function> is defined as a + macro rather than a function. + </para> + </refsect1> + </refentry> + + <refentry id="disable-sql-reader-syntax"> + <refmeta> + <refentrytitle>DISABLE-SQL-READER-SYNTAX</refentrytitle> + </refmeta> + <refnamediv> + <refname>DISABLE-SQL-READER-SYNTAX</refname> + <refpurpose>Globally disable square bracket reader syntax.</refpurpose> + <refclass>Macro</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis> + <function>disable-sql-reader-syntax</function> => <returnvalue></returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>Description</title> + <para>Turns off the SQL reader syntax setting the syntax state + such that if the syntax is subsequently enabled, + <link linkend="restore-sql-reader-syntax-state"> + <function>restore-sql-reader-syntax-state</function></link> will + disable it again. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para> + Sets the internal syntax state to disabled. + </para> + <para> + Modifies the default readtable. + </para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para> + None. + </para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para> + None. + </para> + </refsect1> + <refsect1> + <title>See Also</title> + <simplelist> + <member><link linkend="enable-sql-reader-syntax"><function>enable-sql-reader-syntax</function></link></member> + <member><link linkend="locally-enable-sql-reader-syntax"><function>locally-enable-sql-reader-syntax</function></link></member> + <member><link linkend="locally-disable-sql-reader-syntax"><function>locally-disable-sql-reader-syntax</function></link></member> + <member><link linkend="restore-sql-reader-syntax-state"><function>restore-sql-reader-syntax-state</function></link></member> + <member><link linkend="file-enable-sql-reader-syntax"><function>file-enable-sql-reader-syntax</function></link></member> + </simplelist> + </refsect1> + <refsect1> + <title>Notes</title> + <para> + The symbolic SQL syntax is disabled by default. + </para> + <para> + &clsql; differs from &commonsql; in that + <function>disable-sql-reader-syntax</function> is defined as a + macro rather than a function. + </para> + </refsect1> + </refentry> + + <refentry id="locally-enable-sql-reader-syntax"> + <refmeta> + <refentrytitle>LOCALLY-ENABLE-SQL-READER-SYNTAX</refentrytitle> + </refmeta> + <refnamediv> + <refname>LOCALLY-ENABLE-SQL-READER-SYNTAX</refname> + <refpurpose>Locally enable square bracket reader syntax.</refpurpose> + <refclass>Macro</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis> + <function>locally-enable-sql-reader-syntax</function> => <returnvalue></returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>Description</title> + <para>Turns on the SQL reader syntax without changing the syntax + state such that <link linkend="restore-sql-reader-syntax-state"> + <function>restore-sql-reader-syntax-state</function></link> will + re-establish the current syntax state. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <para>Intended to be used in a file for code which uses the + square bracket syntax without changing the global state. + </para> + <screen> + #.(locally-enable-sql-reader-syntax) + + ... CODE USING SYMBOLIC SQL SYNTAX ... + + #.(restore-sql-reader-syntax-state) + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para> + Modifies the default readtable. + </para> + <warning> + <para> + &clsql; tries to keep track of whether the syntax has already been enabled. This can be problematic if the syntax is somehow disabled externally to &clsql; as future attempts to enable the syntax will do nothing--the system thinks it is already enabled. This may happen if there is an enable, but no disable, in a file that is processed with load or compile-file as the lisp implementation will restore the readtable on completion. Or, even if there is a disable but a compiler-error is encountered before running the disable. If you encounter this try running <link linkend="disable-sql-reader-syntax"><function>disable-sql-reader-syntax</function></link> a couple times in the REPL. + </para> + <para>See <link linkend="file-enable-sql-reader-syntax"><function>file-enable-sql-reader-syntax</function></link> for an alternative.</para> + </warning> + </refsect1> + <refsect1> + <title>Affected by</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para> + None. + </para> + </refsect1> + <refsect1> + <title>See Also</title> + <simplelist> + <member><link linkend="enable-sql-reader-syntax"><function>enable-sql-reader-syntax</function></link></member> + <member><link linkend="disable-sql-reader-syntax"><function>disable-sql-reader-syntax</function></link></member> + <member><link linkend="locally-disable-sql-reader-syntax"><function>locally-disable-sql-reader-syntax</function></link></member> + <member><link linkend="restore-sql-reader-syntax-state"><function>restore-sql-reader-syntax-state</function></link></member> + <member><link linkend="file-enable-sql-reader-syntax"><function>file-enable-sql-reader-syntax</function></link></member> + </simplelist> + </refsect1> + <refsect1> + <title>Notes</title> + <para> + The symbolic SQL syntax is disabled by default. + </para> + <para> + &clsql; differs from &commonsql; in that + <function>locally-enable-sql-reader-syntax</function> is + defined as a macro rather than a function. + </para> + </refsect1> + </refentry> + + + <refentry id="locally-disable-sql-reader-syntax"> + <refmeta> + <refentrytitle>LOCALLY-DISABLE-SQL-READER-SYNTAX</refentrytitle> + </refmeta> + <refnamediv> + <refname>LOCALLY-DISABLE-SQL-READER-SYNTAX</refname> + <refpurpose>Locally disable square bracket reader syntax.</refpurpose> + <refclass>Macro</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis> + <function>locally-disable-sql-reader-syntax</function> => <returnvalue></returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>Description</title> + <para>Turns off the SQL reader syntax without changing the + syntax state such that <link + linkend="restore-sql-reader-syntax-state"> + <function>restore-sql-reader-syntax-state</function></link> will + re-establish the current syntax state. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <para>Intended to be used in a file for code in which the square + bracket syntax should be disabled without changing the global + state. + </para> + <screen> + #.(locally-disable-sql-reader-syntax) + + ... CODE NOT USING SYMBOLIC SQL SYNTAX ... + + #.(restore-sql-reader-syntax-state) + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para> + Modifies the default readtable. + </para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para> + None. + </para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para> + None. + </para> + </refsect1> + <refsect1> + <title>See Also</title> + <simplelist> + <member><link linkend="enable-sql-reader-syntax"><function>enable-sql-reader-syntax</function></link></member> + <member><link linkend="disable-sql-reader-syntax"><function>disable-sql-reader-syntax</function></link></member> + <member><link linkend="locally-enable-sql-reader-syntax"><function>locally-enable-sql-reader-syntax</function></link></member> + <member><link linkend="restore-sql-reader-syntax-state"><function>restore-sql-reader-syntax-state</function></link></member> + <member><link linkend="file-enable-sql-reader-syntax"><function>file-enable-sql-reader-syntax</function></link></member> + </simplelist> + </refsect1> + <refsect1> + <title>Notes</title> + <para> + The symbolic SQL syntax is disabled by default. + </para> + <para> + &clsql; differs from &commonsql; in that + <function>locally-disable-sql-reader-syntax</function> is + defined as a macro rather than a function. + </para> + </refsect1> + </refentry> + + <refentry id="restore-sql-reader-syntax-state"> + <refmeta> + <refentrytitle>RESTORE-SQL-READER-SYNTAX-STATE</refentrytitle> + </refmeta> + <refnamediv> + <refname>RESTORE-SQL-READER-SYNTAX-STATE</refname> + <refpurpose> + Restore square bracket reader syntax to its previous state. + </refpurpose> + <refclass>Macro</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis> + <function>restore-sql-reader-syntax-state</function> => <returnvalue></returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>Description</title> + <para>Enables the SQL reader syntax if <link + linkend="enable-sql-reader-syntax"> + <function>enable-sql-reader-syntax</function></link> has been + called more recently than <link + linkend="disable-sql-reader-syntax"> + <function>disable-sql-reader-syntax</function></link> and + otherwise disables the SQL reader syntax. By default, the SQL + reader syntax is disabled. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <para> + See <link + linkend="locally-enable-sql-reader-syntax"> + <function>locally-enable-sql-reader-syntax</function></link> and + <link + linkend="locally-disable-sql-reader-syntax"> + <function>locally-disable-sql-reader-syntax</function></link>. + </para> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para> + Reverts the internal syntax state. + </para> + <para> + Modifies the default readtable. + </para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para>The current internal syntax state.</para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para> + None. + </para> + </refsect1> + <refsect1> + <title>See Also</title> + <simplelist> + <member><link linkend="enable-sql-reader-syntax"><function>enable-sql-reader-syntax</function></link></member> + <member><link linkend="disable-sql-reader-syntax"><function>disable-sql-reader-syntax</function></link></member> + <member><link linkend="locally-enable-sql-reader-syntax"><function>locally-enable-sql-reader-syntax</function></link></member> + <member><link linkend="locally-disable-sql-reader-syntax"><function>locally-disable-sql-reader-syntax</function></link></member> + <member><link linkend="file-enable-sql-reader-syntax"><function>file-enable-sql-reader-syntax</function></link></member> + </simplelist> + </refsect1> + <refsect1> + <title>Notes</title> + <para> + The symbolic SQL syntax is disabled by default. + </para> + <para> + &clsql; differs from &commonsql; in that + <function>restore-sql-reader-syntax-state</function> is + defined as a macro rather than a function. + </para> + </refsect1> + </refentry> + + <refentry id="file-enable-sql-reader-syntax"> + <refmeta> + <refentrytitle>FILE-ENABLE-SQL-READER-SYNTAX</refentrytitle> + </refmeta> + <refnamediv> + <refname>FILE-ENABLE-SQL-READER-SYNTAX</refname> + <refpurpose> + Enable the square bracket reader syntax for the duration of the file. + </refpurpose> + <refclass>Macro</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis> + <function>file-enable-sql-reader-syntax</function> => <returnvalue></returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>Description</title> + <para>Uncoditionally enables the SQL reader syntax. Unlike <link + linkend="enable-sql-reader-syntax"> + <function>enable-sql-reader-syntax</function></link> and <link + linkend="disable-sql-reader-syntax"> + <function>disable-sql-reader-syntax</function></link> which try to keep track of whether + the syntax has been enabled or disabled and keep track of the old read-table for restoration this function just enables it unconditionally. + </para> + <para>Once enabled this way there is no corresponding disable function but instead relies on being used in a file context. The spec for <ulink url="http://www.lispworks.com/documentation/lw51/CLHS/Body/f_load.htm">load</ulink> and <ulink url="http://www.lispworks.com/documentation/lw51/CLHS/Body/f_cmp_fi.htm">compile-file</ulink> states that the *readtable* will be restored after processing the file.</para> + </refsect1> + <refsect1> + <title>Examples</title> + <para>Intended to be used at the top of a file that contains sql reader syntax.</para> + <screen> + (in-package :my-package) + (clsql:file-enable-sql-reader-syntax) + ... + ;;functions that use the square bracket syntax. + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para> + Modifies the readtable for #\[ and #\] + </para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para> + None. + </para> + </refsect1> + <refsect1> + <title>See Also</title> + <simplelist> + <member><link linkend="enable-sql-reader-syntax"><function>enable-sql-reader-syntax</function></link></member> + <member><link linkend="disable-sql-reader-syntax"><function>disable-sql-reader-syntax</function></link></member> + <member><link linkend="locally-enable-sql-reader-syntax"><function>locally-enable-sql-reader-syntax</function></link></member> + <member><link linkend="locally-disable-sql-reader-syntax"><function>locally-disable-sql-reader-syntax</function></link></member> + </simplelist> + </refsect1> + <refsect1> + <title>Notes</title> + <para> + Unique to &clsql;, not present in &commonsql;. + </para> + </refsect1> + </refentry> + + <refentry id="sql"> + <refmeta> + <refentrytitle>SQL</refentrytitle> + </refmeta> + <refnamediv> + <refname>SQL</refname> + <refpurpose>Construct an SQL string from supplied expressions.</refpurpose> + <refclass>Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis> + <function>sql &rest</function> <replaceable>args</replaceable> => <returnvalue>sql-expression</returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>args</parameter></term> + <listitem> + <para>A set of expressions.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><returnvalue>sql-expression</returnvalue></term> + <listitem> + <para>A string representing an SQL expression.</para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para>Returns an SQL string generated from the expressions + <parameter>args</parameter>. The expressions are translated into + SQL strings and then concatenated with a single space delimiting + each expression. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(sql nil) +=> "NULL" + +(sql 'foo) +=> "FOO" + +(sql "bar") + => "'bar'" + +(sql 10) +=> "10" + +(sql '(nil foo "bar" 10)) +=> "(NULL,FOO,'bar',10)" + +(sql #(nil foo "bar" 10)) +=> "NULL,FOO,'bar',10" + +(sql [select [foo] [bar] :from [baz]] 'having [= [foo id] [bar id]] + 'and [foo val] '< 5) +=> "SELECT FOO,BAR FROM BAZ HAVING (FOO.ID = BAR.ID) AND FOO.VAL < 5" + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para> + None. + </para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para>An error of type <link + linkend="sql-user-error"><function>sql-user-error</function></link> + is signalled if any element in <parameter>args</parameter> is + not of the supported types (a symbol, string, number or symbolic + SQL expression) or a list or vector containing only these + supported types. + </para> + </refsect1> + <refsect1> + <title>See Also</title> + <simplelist> + <member><link linkend="sql-expression"><function>sql-expression</function></link></member> + <member><link linkend="sql-operation"><function>sql-operation</function></link></member> + <member><link linkend="sql-operator"><function>sql-operator</function></link></member> + </simplelist> + </refsect1> + <refsect1> + <title>Notes</title> + <para>None.</para> + </refsect1> + </refentry> + + <refentry id="sql-expression"> + <refmeta> + <refentrytitle>SQL-EXPRESSION</refentrytitle> + </refmeta> + <refnamediv> + <refname>SQL-EXPRESSION</refname> + <refpurpose>Constructs an SQL expression from supplied keyword arguments.</refpurpose> + <refclass>Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis> + <function>sql-expression &key</function> <parameter>string</parameter> <parameter>table</parameter> <parameter>alias</parameter> <parameter>attribute</parameter> <parameter>type</parameter> => <returnvalue>result</returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>string</parameter></term> + <listitem> + <para>A string.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>table</parameter></term> + <listitem> + <para>A symbol representing a database table identifier.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>alias</parameter></term> + <listitem> + <para>A table alias.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>attribute</parameter></term> + <listitem> + <para>A symbol representing an attribute identifier.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>type</parameter></term> + <listitem> + <para>A type specifier.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><returnvalue>result</returnvalue></term> + <listitem> + <para>A object of type <type>sql-expression</type>.</para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para>Returns an SQL expression constructed from the supplied + arguments which may be combined as follows:</para> + <itemizedlist mark='opencircle'> + <listitem> + <para> + <parameter>attribute</parameter> and + <parameter>type</parameter>; + </para> + </listitem> + <listitem> + <para> + <parameter>attribute</parameter>; + </para> + </listitem> + <listitem> + <para> + <parameter>alias</parameter> or <parameter>table</parameter> and + <parameter>attribute</parameter> and + <parameter>type</parameter>; + </para> + </listitem> + <listitem> + <para> + <parameter>alias</parameter> or + <parameter>table</parameter> and + <parameter>attribute</parameter>; + </para> + </listitem> + <listitem> + <para> + <parameter>table</parameter>, + <parameter>attribute</parameter> and + <parameter>type</parameter>; + </para> + </listitem> + <listitem> + <para> + <parameter>table</parameter> and + <parameter>attribute</parameter>; + </para> + </listitem> + <listitem> + <para> + <parameter>table</parameter> + and <parameter>alias</parameter>; + </para> + </listitem> + <listitem> + <para> + <parameter>table</parameter>; + </para> + </listitem> + <listitem> + <para> + <parameter>string</parameter>. + </para> + </listitem> + </itemizedlist> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(sql-expression :table 'foo :attribute 'bar) +=> #<CLSQL-SYS:SQL-IDENT-ATTRIBUTE FOO.BAR> + +(sql-expression :attribute 'baz) +=> #<CLSQL-SYS:SQL-IDENT-ATTRIBUTE BAZ> + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para> + None. + </para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para>An error of type <link + linkend="sql-user-error"><function>sql-user-error</function></link> + is signalled if an unsupported combination of keyword arguments is + specified. + </para> + </refsect1> + <refsect1> + <title>See Also</title> + <simplelist> + <member><link linkend="sql"><function>sql</function></link></member> + <member><link linkend="sql-operation"><function>sql-operation</function></link></member> + <member><link linkend="sql-operator"><function>sql-operator</function></link></member> + </simplelist> + </refsect1> + <refsect1> + <title>Notes</title> + <para>None.</para> + </refsect1> + </refentry> + + <refentry id="sql-operation"> + <refmeta> + <refentrytitle>SQL-OPERATION</refentrytitle> + </refmeta> + <refnamediv> + <refname>SQL-OPERATION</refname> + <refpurpose>Constructs an SQL expression from a supplied operator and arguments.</refpurpose> + <refclass>Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis> + <function>sql-operation</function> <parameter>operator</parameter> <function>&rest</function> <parameter>args</parameter> => <returnvalue>result</returnvalue></synopsis> + <synopsis> + <function>sql-operation</function> 'function <parameter>func</parameter> <function>&rest</function> <parameter>args</parameter> => <returnvalue>result</returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>operator</parameter></term> + <listitem> + <para>A symbol denoting an SQL operator.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>func</parameter></term> + <listitem> + <para>A string denoting an SQL function.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>args</parameter></term> + <listitem> + <para>A set of arguments for the specified SQL operator or function.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><returnvalue>result</returnvalue></term> + <listitem> + <para>A object of type <function>sql-expression</function>.</para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para>Returns an SQL expression constructed from the supplied + SQL operator or function <parameter>operator</parameter> and + its arguments <parameter>args</parameter>. If + <parameter>operator</parameter> is passed the symbol 'function + then the first value in <parameter>args</parameter> is taken to + be a valid SQL function and the remaining values in + <parameter>args</parameter> its arguments. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(sql-operation 'select + (sql-expression :table 'foo :attribute 'bar) + (sql-operation 'sum (sql-expression :table 'foo :attribute 'baz)) + :from + (sql-expression :table 'foo) + :where + (sql-operation '> (sql-expression :attribute 'bar) 12) + :order-by (sql-operation 'sum (sql-expression :attribute 'baz))) +=> #<SQL-QUERY SELECT FOO.BAR,SUM(FOO.BAZ) FROM FOO WHERE (BAR > 12) ORDER BY SUM(BAZ)> + +(sql-operation 'function "strpos" "CLSQL" "SQL") +=> #<CLSQL-SYS:SQL-FUNCTION-EXP STRPOS('CLSQL','SQL')> + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para> + None. + </para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para>An error of type <link + linkend="sql-user-error"><function>sql-user-error</function></link> + is signalled if <parameter>operator</parameter> is not a symbol + representing a supported SQL operator.</para> + </refsect1> + <refsect1> + <title>See Also</title> + <simplelist> + <member><link linkend="sql"><function>sql</function></link></member> + <member><link linkend="sql-expression"><function>sql-expression</function></link></member> + <member><link linkend="sql-operator"><function>sql-operator</function></link></member> + </simplelist> + </refsect1> + <refsect1> + <title>Notes</title> + <para>None.</para> + </refsect1> + </refentry> + + <refentry id="sql-operator"> + <refmeta> + <refentrytitle>SQL-OPERATOR</refentrytitle> + </refmeta> + <refnamediv> + <refname>SQL-OPERATOR</refname> + <refpurpose>Returns the symbol for the supplied SQL operator.</refpurpose> + <refclass>Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis> + <function>sql-operator</function> <parameter>operator</parameter> => <returnvalue>result</returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>operator</parameter></term> + <listitem> + <para>A symbol denoting an SQL operator.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><returnvalue>result</returnvalue></term> + <listitem> + <para>The Lisp symbol used by &clsql; to represent the + specified operator.</para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para>Returns the Lisp symbol corresponding to the SQL operator + represented by the symbol <parameter>operator</parameter>. If + <parameter>operator</parameter> does not represent a supported + SQL operator or is not a symbol, nil is returned. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(sql-operator 'like) +=> SQL-LIKE + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para> + None. + </para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>See Also</title> + <simplelist> + <member><link linkend="sql"><function>sql</function></link></member> + <member><link linkend="sql-expression"><function>sql-expression</function></link></member> + <member><link linkend="sql-operation"><function>sql-operation</function></link></member> + </simplelist> + </refsect1> + <refsect1> + <title>Notes</title> + <para> + &clsql;'s symbolic SQL syntax currently has support for the + following &commonsql; compatible SQL operators: + </para> + <simplelist> + <!-- CommonSQL Compatible --> + <member><function>any</function></member> + <member><function>some</function></member> + <member><function>all</function></member> + <member><function>not</function></member> + <member><function>union</function></member> + <member><function>intersect</function></member> + <member><function>minus</function></member> + <member><function>except + </function></member> + <member><function>order-by + </function></member> + <member><function>null + </function></member> + <member><function>* + </function></member> + <member><function>+ + </function></member> + <member><function>/ + </function></member> + <member><function>- + </function></member> + <member><function>like + </function></member> + <member><function>and + </function></member> + <member><function>or + </function></member> + <member><function>in + </function></member> + <member><function>substr + </function></member> + <member><function>|| + </function></member> + <member><function>= + </function></member> + <member><function>< + </function></member> + <member><function>> + </function></member> + <member><function>>= + </function></member> + <member><function><= + </function></member> + <member><function><> + </function></member> + <member><function>count + </function></member> + <member><function>max + </function></member> + <member><function>min + </function></member> + <member><function>avg + </function></member> + <member><function>sum + </function></member> + <member><function>function + </function></member> + <member><function>between + </function></member> + <member><function>distinct + </function></member> + <member><function>nvl + </function></member> + <member><function>slot-value + </function></member> + <member><function>userenv + </function></member> + </simplelist> + <para> + as well as the pseudo-operator <function>function</function>. + </para> + <para> The following operators are provided as &clsql; extensions to + the &commonsql; API. + <simplelist> + <!-- CLSQL Extensions --> + <member><function>concat + </function></member> + <member><function>substring + </function></member> + <member><function>limit + </function></member> + <member><function>group-by + </function></member> + <member><function>having + </function></member> + <member><function>not-null + </function></member> + <member><function>exists + </function></member> + <member><function>uplike + </function></member> + <member><function>is + </function></member> + <member><function>== + </function></member> + <member><function>the + </function></member> + <member><function>coalesce + </function></member> + <member><function>view-class + </function></member> + </simplelist> + </para> + <para> + Note that some of these operators are not supported by all of + the RDBMS supported by &clsql; (see the <link + linkend="appendix">Appendix</link> for details). + </para> + </refsect1> + </refentry> + +</reference> diff --git a/doc/ref-transaction.xml b/doc/ref-transaction.xml new file mode 100644 index 0000000..5731c46 --- /dev/null +++ b/doc/ref-transaction.xml @@ -0,0 +1,844 @@ +<?xml version='1.0' ?> +<!DOCTYPE book PUBLIC "-//OASIS//DTD DocBook XML V4.2//EN" +"http://www.oasis-open.org/docbook/xml/4.2/docbookx.dtd" [ +<!ENTITY % myents SYSTEM "entities.inc"> +%myents; +]> + +<!-- Transaction handling --> + +<reference id="ref-transaction"> + <title>Transaction Handling</title> + <partintro> + <para> + This section describes the interface provided by &clsql; for + handling database transactions. The interface allows for opening + transaction blocks, committing or rolling back changes made and + controlling autocommit behaviour. + </para> + <note> + <para> + In contrast to &commonsql;, &clsql;, by default, starts in + transaction AUTOCOMMIT mode (see <link + linkend="set-autocommit"><function>set-autocommit</function></link>). + To begin a transaction in autocommit mode, <link + linkend="start-transaction"><function>start-transaction</function></link> + has to be called explicitly. + </para> + </note> + </partintro> + + <refentry id="start-transaction"> + <refmeta> + <refentrytitle>START-TRANSACTION</refentrytitle> + </refmeta> + <refnamediv> + <refname>START-TRANSACTION</refname> + <refpurpose>Open a transaction block.</refpurpose> + <refclass>Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis> + <function>start-transaction</function> &key <replaceable>database</replaceable> => <returnvalue>&nil;</returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>database</parameter></term> + <listitem> + <para>A + <glossterm linkend="gloss-database-object">database + object</glossterm>. This will default to the value + of <symbol>*default-database*</symbol>.</para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para>Starts a transaction block on + <parameter>database</parameter> which defaults to + <symbol>*default-database*</symbol> and which continues until + <function>rollback</function> or <function>commit</function> are + called. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(in-transaction-p) +=> NIL +(select [*] :from [foo] :field-names nil) +=> NIL +(start-transaction) +=> NIL +(in-transaction-p) +=> T +(insert-records :into [foo] :av-pairs '(([bar] 1) ([baz] "one"))) +=> +(select [*] :from [foo] :field-names nil) +=> ((1 "one")) +(rollback) +=> NIL +(in-transaction-p) +=> NIL +(select [*] :from [foo] :field-names nil) +=> NIL + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para> + Autocommit mode is disabled and if + <parameter>database</parameter> is currently within the scope + of a transaction, all commit and rollback hooks are removed + and the transaction level associated with + <parameter>database</parameter> is modified. + </para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para> + None. + </para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para> + Signals an error of type <symbol>sql-database-error</symbol> + if <parameter>database</parameter> is not a database object. + </para> + </refsect1> + <refsect1> + <title>See Also</title> + <simplelist> + <member><link linkend="commit"><function>commit</function></link></member> + <member><link linkend="rollback"><function>rollback</function></link></member> + <member><link linkend="in-transaction-p"><function>in-transaction-p</function></link></member> + <member><link linkend="set-autocommit"><function>set-autocommit</function></link></member> + <member><link linkend="with-transaction"><function>with-transaction</function></link></member> + </simplelist> + </refsect1> + <refsect1> + <title>Notes</title> + <para> + <function>start-transaction</function> is a &clsql; extension. + </para> + </refsect1> + </refentry> + + <refentry id="commit"> + <refmeta> + <refentrytitle>COMMIT</refentrytitle> + </refmeta> + <refnamediv> + <refname>COMMIT</refname> + <refpurpose>Commit modifications made in the current transaction.</refpurpose> + <refclass>Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis> + <function>commit</function> &key <replaceable>database</replaceable> => <returnvalue>&nil;</returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>database</parameter></term> + <listitem> + <para>A + <glossterm linkend="gloss-database-object">database + object</glossterm>. This will default to the value + of <symbol>*default-database*</symbol>.</para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para>If <parameter>database</parameter>, which defaults to + <symbol>*default-database*</symbol>, is currently within the + scope of a transaction, commits changes made since the + transaction began. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(in-transaction-p) +=> NIL +(select [*] :from [foo] :field-names nil) +=> NIL +(start-transaction) +=> NIL +(in-transaction-p) +=> T +(insert-records :into [foo] :av-pairs '(([bar] 1) ([baz] "one"))) +=> +(select [*] :from [foo] :field-names nil) +=> ((1 "one")) +(commit) +=> NIL +(in-transaction-p) +=> NIL +(select [*] :from [foo] :field-names nil) +=> ((1 "one")) + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para> + Changes made within the scope of the current transaction are + committed in the underlying database and the transaction level + of <parameter>database</parameter> is reset. + </para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para> + The transaction level of <parameter>database</parameter> which + indicates whether a transaction has been initiated by a call to + <function>start-transaction</function> since the last call to + <function>rollback</function> or <function>commit</function>. + </para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para> + Signals an error of type <symbol>sql-database-error</symbol> + if <parameter>database</parameter> is not a database object. A + warning of type <symbol>sql-warning</symbol> is signalled if there + is no transaction in progress. + </para> + </refsect1> + <refsect1> + <title>See Also</title> + <simplelist> + <member><link linkend="start-transaction"><function>start-transaction</function></link></member> + <member><link linkend="rollback"><function>rollback</function></link></member> + <member><link linkend="in-transaction-p"><function>in-transaction-p</function></link></member> + <member><link linkend="add-transaction-commit-hook"><function>add-transaction-commit-hook</function></link></member> + <member><link linkend="set-autocommit"><function>set-autocommit</function></link></member> + <member><link linkend="with-transaction"><function>with-transaction</function></link></member> + </simplelist> + </refsect1> + <refsect1> + <title>Notes</title> + <para> + None. + </para> + </refsect1> + </refentry> + + <refentry id="rollback"> + <refmeta> + <refentrytitle>ROLLBACK</refentrytitle> + </refmeta> + <refnamediv> + <refname>ROLLBACK</refname> + <refpurpose>Roll back modifications made in the current transaction.</refpurpose> + <refclass>Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis> + <function>rollback</function> &key <replaceable>database</replaceable> => <returnvalue>&nil;</returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>database</parameter></term> + <listitem> + <para>A + <glossterm linkend="gloss-database-object">database + object</glossterm>. This will default to the value + of <symbol>*default-database*</symbol>.</para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para>If <parameter>database</parameter>, which defaults to + <symbol>*default-database*</symbol>, is currently within the + scope of a transaction, rolls back changes made since the + transaction began. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(in-transaction-p) +=> NIL +(select [*] :from [foo] :field-names nil) +=> NIL +(start-transaction) +=> NIL +(in-transaction-p) +=> T +(insert-records :into [foo] :av-pairs '(([bar] 1) ([baz] "one"))) +=> +(select [*] :from [foo] :field-names nil) +=> ((1 "one")) +(rollback) +=> NIL +(in-transaction-p) +=> NIL +(select [*] :from [foo] :field-names nil) +=> NIL + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para> + Changes made within the scope of the current transaction are + reverted in the underlying database and the transaction level + of <parameter>database</parameter> is reset. </para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para> + The transaction level of <parameter>database</parameter> which + indicates whether a transaction has been initiated by a call to + <function>start-transaction</function> since the last call to + <function>rollback</function> or <function>commit</function>. + </para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para> + Signals an error of type <symbol>sql-database-error</symbol> + if <parameter>database</parameter> is not a database object. A + warning of type <symbol>sql-warning</symbol> is signalled if + there is no transaction in progress. + </para> + </refsect1> + <refsect1> + <title>See Also</title> + <simplelist> + <member><link linkend="start-transaction"><function>start-transaction</function></link></member> + <member><link linkend="commit"><function>commit</function></link></member> + <member><link linkend="in-transaction-p"><function>in-transaction-p</function></link></member> + <member><link linkend="add-transaction-rollback-hook"><function>add-transaction-rollback-hook</function></link></member> + <member><link linkend="set-autocommit"><function>set-autocommit</function></link></member> + <member><link linkend="with-transaction"><function>with-transaction</function></link></member> + </simplelist> + </refsect1> + <refsect1> + <title>Notes</title> + <para> + None. + </para> + </refsect1> + </refentry> + + <refentry id="in-transaction-p"> + <refmeta> + <refentrytitle>IN-TRANSACTION-P</refentrytitle> + </refmeta> + <refnamediv> + <refname>IN-TRANSACTION-P</refname> + <refpurpose>A predicate for testing whether a transaction is currently in progress.</refpurpose> + <refclass>Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis> + <function>in-transaction-p</function> &key <replaceable>database</replaceable> => <returnvalue>result</returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>database</parameter></term> + <listitem> + <para>A + <glossterm linkend="gloss-database-object">database + object</glossterm>. This will default to the value + of <symbol>*default-database*</symbol>.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>result</parameter></term> + <listitem> + <para>A Boolean.</para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para>A predicate to test whether + <parameter>database</parameter>, which defaults to + <symbol>*default-database*</symbol>, is currently within the + scope of a transaction. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(in-transaction-p) +=> NIL +(start-transaction) +=> NIL +(in-transaction-p) +=> T +(commit) +=> NIL +(in-transaction-p) +=> NIL + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para> + None. + </para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para> + None. + </para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para> + None. + </para> + </refsect1> + <refsect1> + <title>See Also</title> + <simplelist> + <member><link linkend="start-transaction"><function>start-transaction</function></link></member> + <member><link linkend="commit"><function>commit</function></link></member> + <member><link linkend="rollback"><function>rollback</function></link></member> + <member><link linkend="set-autocommit"><function>set-autocommit</function></link></member> + </simplelist> + </refsect1> + <refsect1> + <title>Notes</title> + <para> + <function>in-transaction-p</function> is a &clsql; extension. + </para> + </refsect1> + </refentry> + + <refentry id="add-transaction-commit-hook"> + <refmeta> + <refentrytitle>ADD-TRANSACTION-COMMIT-HOOK</refentrytitle> + </refmeta> + <refnamediv> + <refname>ADD-TRANSACTION-COMMIT-HOOK</refname> + <refpurpose>Specify hooks to be run when committing changes.</refpurpose> + <refclass>Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis> + <function>add-transaction-commit-hook</function> <replaceable>commit-hook</replaceable> &key <replaceable>database</replaceable> => <returnvalue>result</returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>commit-hook</parameter></term> + <listitem> + <para>A designator for a function with no required arguments.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>database</parameter></term> + <listitem> + <para>A + <glossterm linkend="gloss-database-object">database + object</glossterm>. This will default to the value + of <symbol>*default-database*</symbol>.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>result</parameter></term> + <listitem> + <para>The list of currently defined commit hooks for + <parameter>database</parameter>. + </para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para> + Adds <parameter>commit-hook</parameter>, which should a + designator for a function with no required arguments, to the + list of hooks run when <function>commit</function> is called + on <parameter>database</parameter> which defaults to + <symbol>*default-database*</symbol>. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(start-transaction) +=> NIL +(add-transaction-commit-hook #'(lambda () (print "Successfully committed."))) +=> (#<Interpreted Function (LAMBDA # #) {48E2E689}>) +(commit) +"Successfully committed." +=> NIL + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para> + <parameter>commit-hook</parameter> is added to the list of + commit hooks for <parameter>database</parameter>. + </para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para> + None. + </para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para> + If <parameter>commit-hook</parameter> has one or more required + arguments, an error will be signalled when + <function>commit</function> is called. + </para> + </refsect1> + <refsect1> + <title>See Also</title> + <simplelist> + <member><link linkend="commit"><function>commit</function></link></member> + <member><link linkend="rollback"><function>rollback</function></link></member> + <member><link linkend="add-transaction-rollback-hook"><function>add-transaction-rollback-hook</function></link></member> + <member><link linkend="with-transaction"><function>with-transaction</function></link></member> + </simplelist> + </refsect1> <refsect1> + <title>Notes</title> + <para> + <function>add-transaction-commit-hook</function> is a &clsql; extension. + </para> + </refsect1> + </refentry> + + <refentry id="add-transaction-rollback-hook"> + <refmeta> + <refentrytitle>ADD-TRANSACTION-ROLLBACK-HOOK</refentrytitle> + </refmeta> + <refnamediv> + <refname>ADD-TRANSACTION-ROLLBACK-HOOK</refname> + <refpurpose>Specify hooks to be run when rolling back changes.</refpurpose> + <refclass>Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis> + <function>add-transaction-rollback-hook</function> <replaceable>rollback-hook</replaceable> &key <replaceable>database</replaceable> => <returnvalue>result</returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>rollback-hook</parameter></term> + <listitem> + <para>A designator for a function with no required arguments.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>database</parameter></term> + <listitem> + <para>A + <glossterm linkend="gloss-database-object">database + object</glossterm>. This will default to the value + of <symbol>*default-database*</symbol>.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>result</parameter></term> + <listitem> + <para>The list of currently defined rollback hooks for + <parameter>database</parameter>. + </para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para> + Adds <parameter>rollback-hook</parameter>, which should a + designator for a function with no required arguments, to the + list of hooks run when <function>rollback</function> is called + on <parameter>database</parameter> which defaults to + <symbol>*default-database*</symbol>. </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(start-transaction) +=> NIL +(add-transaction-rollback-hook #'(lambda () (print "Successfully rolled back."))) +=> (#<Interpreted Function (LAMBDA # #) {48E37C31}>) +(rollback) +"Successfully rolled back." +=> NIL + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para> + <parameter>rollback-hook</parameter> is added to the list of + rollback hooks for <parameter>database</parameter>. + </para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para> + None. + </para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para> + If <parameter>rollback-hook</parameter> has one or more + required arguments, an error will be signalled when + <function>rollback</function> is called. + </para> + </refsect1> +<refsect1> + <title>See Also</title> + <simplelist> + <member><link linkend="commit"><function>commit</function></link></member> + <member><link linkend="rollback"><function>rollback</function></link></member> + <member><link linkend="add-transaction-commit-hook"><function>add-transaction-commit-hook</function></link></member> + </simplelist> + </refsect1> + <refsect1> + <title>Notes</title> + <para> + <function>add-transaction-rollback-hook</function> is a &clsql; extension. + </para> + </refsect1> + </refentry> + + <refentry id="set-autocommit"> + <refmeta> + <refentrytitle>SET-AUTOCOMMIT</refentrytitle> + </refmeta> + <refnamediv> + <refname>SET-AUTOCOMMIT</refname> + <refpurpose>Turn on or off autocommit for a database.</refpurpose> + <refclass>Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis> + <function>set-autocommit</function> <replaceable>value</replaceable> &key <replaceable>database</replaceable> => <returnvalue>result</returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>value</parameter></term> + <listitem> + <para>A Boolean specifying the desired autocommit + behaviour for <parameter>database</parameter>. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>database</parameter></term> + <listitem> + <para>A + <glossterm linkend="gloss-database-object">database + object</glossterm>. This will default to the value + of <symbol>*default-database*</symbol>.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>result</parameter></term> + <listitem> + <para>The previous autocommit value for + <parameter>database</parameter>. + </para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para>Turns autocommit off for <parameter>database</parameter> + if <parameter>value</parameter> is &nil;, and otherwise turns it + on. Returns the old value of autocommit flag. + </para> + <para> + For RDBMS (such as Oracle) which don't automatically commit + changes, turning autocommit on has the effect of explicitly + committing changes made whenever SQL statements are executed. + </para> + <para> + Autocommit is turned on by default. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> + <!-- examples --> + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para> + <parameter>database</parameter> is associated with the specified + autocommit mode. + </para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para> + None. + </para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para> + None. + </para> + </refsect1> + <refsect1> + <title>See Also</title> + <simplelist> + <member><link linkend="start-transaction"><function>start-transaction</function></link></member> + <member><link linkend="commit"><function>commit</function></link></member> + <member><link linkend="add-transaction-commit-hook"><function>add-transaction-commit-hook</function></link></member> + <member><link linkend="with-transaction"><function>with-transaction</function></link></member> + </simplelist> + </refsect1> + <refsect1> + <title>Notes</title> + <para> + <function>set-autocommit</function> is a &clsql; extension. + </para> + </refsect1> + </refentry> + + <refentry id="with-transaction"> + <refmeta> + <refentrytitle>WITH-TRANSACTION</refentrytitle> + </refmeta> + <refnamediv> + <refname>WITH-TRANSACTION</refname> + <refpurpose>Execute a body of code within a transaction.</refpurpose> + <refclass>Macro</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis> + <function>with-transaction</function> &key <replaceable>database</replaceable> &rest <replaceable>body</replaceable> => <returnvalue>result</returnvalue></synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>database</parameter></term> + <listitem> + <para>A + <glossterm linkend="gloss-database-object">database + object</glossterm>. This will default to the value + of <symbol>*default-database*</symbol>.</para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>body</parameter></term> + <listitem> + <para> + A body of Lisp code. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>result</parameter></term> + <listitem> + <para>The result of executing <parameter>body</parameter>.</para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para>Starts a transaction in the database specified by + <parameter>database</parameter>, which is + <symbol>*default-database*</symbol> by default, and executes + <parameter>body</parameter> within that transaction. If + <parameter>body</parameter> aborts or throws, + <parameter>database</parameter> is rolled back and otherwise the + transaction is committed. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(in-transaction-p) +=> NIL +(select [email] :from [employee] :where [= [emplid] 1] :flatp t :field-names nil) +=> ("lenin@soviet.org") +(with-transaction () + (update-records [employee] + :av-pairs '((email "lenin-nospam@soviet.org")) + :where [= [emplid] 1])) +=> NIL +(select [email] :from [employee] :where [= [emplid] 1] :flatp t :field-names nil) +=> ("lenin-nospam@soviet.org") +(in-transaction-p) +=> NIL + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para> + Changes specified in <parameter>body</parameter> may be made + to the underlying database if <parameter>body</parameter> + completes successfully. + </para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para> + None. + </para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para> + Signals an error of type <symbol>sql-database-error</symbol> + if <parameter>database</parameter> is not a database object. + </para> + </refsect1> + <refsect1> + <title>See Also</title> + <simplelist> + <member><link linkend="start-transaction"><function>start-transaction</function></link></member> + <member><link linkend="commit"><function>commit</function></link></member> + <member><link linkend="rollback"><function>rollback</function></link></member> + <member><link linkend="add-transaction-commit-hook"><function>add-transaction-commit-hook</function></link></member> + <member><link linkend="add-transaction-rollback-hook"><function>add-transaction-rollback-hook</function></link></member> + </simplelist> + </refsect1> + <refsect1> + <title>Notes</title> + <para> + None. + </para> + </refsect1> + </refentry> + + +</reference> diff --git a/doc/schemas.xml b/doc/schemas.xml new file mode 100644 index 0000000..018eb6f --- /dev/null +++ b/doc/schemas.xml @@ -0,0 +1,24 @@ +<?xml version="1.0"?> +<locatingRules xmlns="http://thaiopensource.com/ns/locating-rules/1.0"> + <uri resource="ref-fddl.xml" uri="/usr/share/emacs/site-lisp/nxml-mode/schema/docbook.rnc"/> + <uri resource="appendix.xml" typeId="DocBook"/> + <uri resource="bookinfo.xml" typeId="DocBook"/> + <uri resource="clsql.xml" typeId="DocBook"/> + <uri resource="glossary.xml" typeId="DocBook"/> + <uri resource="intro.xml" typeId="DocBook"/> + <uri resource="preface.xml" typeId="DocBook"/> + <uri resource="ref-clsql-sys.xml" typeId="DocBook"/> + <uri resource="ref-clsql.xml" typeId="DocBook"/> + <uri resource="ref-fddl.xml" typeId="DocBook"/> + <uri resource="ref-fdml.xml" typeId="DocBook"/> + <uri resource="ref-ooddl.xml" typeId="DocBook"/> + <uri resource="ref-oodml.xml" typeId="DocBook"/> + <uri resource="ref-connect.xml" typeId="DocBook"/> + <uri resource="ref-lob.xml" typeId="DocBook"/> + <uri resource="ref-prepared.xml" typeId="DocBook"/> + <uri resource="ref-conditions.xml" typeId="DocBook"/> + <uri resource="ref-transaction.xml" typeId="DocBook"/> + <uri resource="ref-syntax.xml" typeId="DocBook"/> + <uri resource="ref-recording.xml" typeId="DocBook"/> + <uri resource="global-index.xml" typeId="DocBook"/> +</locatingRules> diff --git a/doc/threading-warnings.txt b/doc/threading-warnings.txt new file mode 100644 index 0000000..6f6a528 --- /dev/null +++ b/doc/threading-warnings.txt @@ -0,0 +1,77 @@ +============= suggested addition to documentation =============== +== Threads and thread safety + +In a Lisp in which threading is internal, rather than done using OS threads, CLSQL should +be threadsafe. Thus what follows will consider the case of Lisp threads also being OS +threads. + +CLSQL attempts to be thread-safe, with important exceptions. The database pool used by +CONNECT and WITH-DATABASE performs appropriate locking, so that +it is possible to use pooled connections from different threads. As long as database +objects (representing connections) are not passed among threads, WITH-DATABASE +and CONNECT may be used by multiple threads. + +However, the database object contained in the VIEW-DATABASE slot of a STANDARD-DB-OBJECT +persists even after the database is returned to the pool. Thus it is possible for one +thread to read an object, return the database to pool, and then still possess a copy of +the database inside the VIEW-DATABASE slot. Then UPDATE-RECORDS-FOR-INSTANCE, +UPDATE-RECORD-FROM-SLOT, and UPDATE-RECORD-FROM-SLOTS +(which always use the VIEW-DATABASE slot, if not NIL, rather than any supplied +keyword argument DATABASE) can use the database even as a second thread as +retrieved it from a pool, resulting in serious problems. Automatic updating using the internal +VIEW-DATABASE slot also may be triggered by the global variable *DB-AUTO-SYNC*. + +This problem may been addressed by defining a new object class, and changing the method +used to select the database during UPDATE-RECORDS-FOR-INSTANCE, etc. + +;; define a threadsafe child class of STANDARD-DB-OBJECT +(defclass clsql::threadsafe-db-obj (clsql-sys:standard-db-object) nil + (:metaclass clsql-sys::standard-db-class)) + +;; for this class, define threadsafe database chooser method that never uses the +;; internal VIEW-DATABASE slot +(defmethod clsql-sys::choose-database-for-instance + ((object clsql::threadsafe-db-obj) &optional database) + (or database clsql-sys:*default-database* + (signal-no-database-error nil))) + +;; define a new sql database table that should be threadsafely UPDATE-able +(clsql-sys:def-view-class my-table (clsql::threadsafe-db-obj) + (…)) + + +Alternatively, users may redefine *DB-POOL* and *DB-POOL-LOCK* on a per-thread basis +using LET before entering the thread, which will prevent any cross-thread sharing +of connections, possibly at the cost of having more connections. [** is this a valid approach **] +*DB-POOL-LOCK* no longer necessary, however, if connection pools are per-thread. + + +==== Thread safety issues for the back-ends [** my best understanding **] + +* sqlite2 - sqlite2 is not threadsafe. + +* sqlite3 - sqlite3 after and including 3.3.1 is threadsafe if compiled in the default manner. According to sqlite3 documentation, + connections may be moved across threads if and only if no transaction is pending and all statements have been finalized. + +* mysql - the mysql interface is missing initializations required for thread safety: 1) mysql_library_init() is not called in a multithreaded environment; + 2) mysql_thread_init() is not called on a per-thread basis; and 3) mysql_thread_end() is not called before a thread terminates. + The second item may lead to corruption according to mysql documentation, and the third item + leads to memory leaks. + + Another issue with mysql is that it resets sigpipe in a way that renders SBCL unresponsive to interrupts, requiring additional saving and + restoring of the signal handler. [** an example? **] + + Nevertheless, the present version of the mysql back end often works successfully even in a threaded environment, albeit with subtle problems. + + +* postgreSQL - is probably threadsafe [No information] + +* postgreSQL socket - Is probably threadsafe -- has been used for a while without any observed errors. + +* ODBC - the Clsql side doesn't have additional issues beyond what's documented above. But this depends on what odbc driver your using. It appears to work with unixodbc and freetds. + +* AODBC - no information + +* Oracle - no information + +============= end of suggested addition to documentation =============== diff --git a/doc/xinclude.mod b/doc/xinclude.mod new file mode 100644 index 0000000..94c13b6 --- /dev/null +++ b/doc/xinclude.mod @@ -0,0 +1,24 @@ +<!ELEMENT xi:include (xi:fallback?) > +<!ATTLIST xi:include + xmlns:xi CDATA #FIXED "http://www.w3.org/2001/XInclude" + href CDATA #REQUIRED + parse (xml|text) "xml" + encoding CDATA #IMPLIED > + +<!ELEMENT xi:fallback ANY> +<!ATTLIST xi:fallback + xmlns:xi CDATA #FIXED "http://www.w3.org/2001/XInclude" > + +<!ENTITY % local.book.class "| xi:include"> + +<!-- inside book elements --> +<!ENTITY % local.chapter.class "| xi:include"> +<!-- inside chapter or section elements --> +<!ENTITY % local.divcomponent.mix "| xi:include"> +<!-- inside para, programlisting, literallayout, etc. --> +<!ENTITY % local.para.char.mix "| xi:include"> +<!-- inside bookinfo, chapterinfo, etc. --> +<!ENTITY % local.info.class "| xi:include"> + +<!-- used for xml:base in docbook 4.2 and prior --> +<!ENTITY % local.common.attrib "xml:base CDATA #IMPLIED"> diff --git a/examples/clsql-tutorial.lisp b/examples/clsql-tutorial.lisp new file mode 100644 index 0000000..1980e3d --- /dev/null +++ b/examples/clsql-tutorial.lisp @@ -0,0 +1,196 @@ +(asdf:operate 'asdf:load-op 'clsql) + +(in-package #:clsql-user) + +;; You must set these variables to appropriate values. +(defvar *tutorial-database-type* nil + "Possible values are :postgresql :postgresql-socket, :mysql, +:oracle, :odbc, :aodbc or :sqlite") +(defvar *tutorial-database-name* "clsqltut" + "The name of the database we will work in.") +(defvar *tutorial-database-user* "" + "The name of the database user we will work as.") +(defvar *tutorial-database-server* "" + "The name of the database server if required") +(defvar *tutorial-database-password* "" + "The password if required") + +(clsql:def-view-class employee () + ((emplid + :db-kind :key + :db-constraints :not-null + :type integer + :initarg :emplid) + (first-name + :accessor first-name + :type (string 30) + :initarg :first-name) + (last-name + :accessor last-name + :type (string 30) + :initarg :last-name) + (email + :accessor employee-email + :type (string 100) + :initarg :email) + (companyid + :type integer + :initarg :companyid) + (company + :accessor employee-company + :db-kind :join + :db-info (:join-class company + :home-key companyid + :foreign-key companyid + :set nil)) + (managerid + :type integer + :initarg :managerid) + (manager + :accessor employee-manager + :db-kind :join + :db-info (:join-class employee + :home-key managerid + :foreign-key emplid + :set nil))) + (:base-table employee)) + +(clsql:def-view-class company () + ((companyid + :db-kind :key + :db-constraints :not-null + :type integer + :initarg :companyid) + (name + :type (string 100) + :initarg :name) + (presidentid + :type integer + :initarg :presidentid) + (president + :reader president + :db-kind :join + :db-info (:join-class employee + :home-key presidentid + :foreign-key emplid + :set nil)) + (employees + :reader company-employees + :db-kind :join + :db-info (:join-class employee + :home-key companyid + :foreign-key companyid + :set t))) + (:base-table company)) + +;; Connect to the database (see the CLSQL documentation for vendor +;; specific connection specs). +(case *tutorial-database-type* + ((:mysql :postgresql :postgresql-socket) + (clsql:connect `(,*tutorial-database-server* + ,*tutorial-database-name* + ,*tutorial-database-user* + ,*tutorial-database-password*) + :database-type *tutorial-database-type*)) + ((:odbc :aodbc :oracle) + (clsql:connect `(,*tutorial-database-name* + ,*tutorial-database-user* + ,*tutorial-database-password*) + :database-type *tutorial-database-type*)) + (:sqlite + (clsql:connect `(,*tutorial-database-name*) + :database-type *tutorial-database-type*))) + +;; Record the sql going out, helps us learn what is going +;; on behind the scenes +(clsql:start-sql-recording) + +;; Create the tables for our view classes +;; First we drop them, ignoring any errors +(ignore-errors + (clsql:drop-view-from-class 'employee) + (clsql:drop-view-from-class 'company)) + +(clsql:create-view-from-class 'employee) +(clsql:create-view-from-class 'company) + + +;; Create some instances of our view classes +(defvar company1 (make-instance 'company + :companyid 1 + :name "Widgets Inc." + ;; Lenin is president of Widgets Inc. + :presidentid 1)) + +(defvar employee1 (make-instance 'employee + :emplid 1 + :first-name "Vladamir" + :last-name "Lenin" + :email "lenin@soviet.org" + :companyid 1)) + +(defvar employee2 (make-instance 'employee + :emplid 2 + :first-name "Josef" + :last-name "Stalin" + :email "stalin@soviet.org" + :companyid 1 + ;; Lenin manages Stalin (for now) + :managerid 1)) + +(clsql:update-records-from-instance employee1) +(clsql:update-records-from-instance employee2) +(clsql:update-records-from-instance company1) + +;; lets use the functional sql interface +(clsql:locally-enable-sql-reader-syntax) + +(format t "The email address of ~A ~A is ~A" + (first-name employee1) + (last-name employee1) + (employee-email employee1)) + +(setf (employee-email employee1) "lenin-nospam@soviets.org") + +;; Update the database +(clsql:update-records-from-instance employee1) + +(let ((new-lenin (car + (clsql:select 'employee + :where [= [slot-value 'employee 'emplid] 1] + :flatp t)))) + (format t "His new email is ~A" + (employee-email new-lenin))) + + +;; Some queries + +;; all employees +(clsql:select 'employee) +;; all companies +(clsql:select 'company) + +;; employees named Lenin +(clsql:select 'employee :where [= [slot-value 'employee 'last-name] + "Lenin"]) + +(clsql:select 'company :where [= [slot-value 'company 'name] + "Widgets Inc."]) + +;; Employees of Widget's Inc. +(clsql:select 'employee + :where [and [= [slot-value 'employee 'companyid] + [slot-value 'company 'companyid]] + [= [slot-value 'company 'name] + "Widgets Inc."]]) + +;; Same thing, except that we are using the employee +;; relation in the company view class to do the join for us, +;; saving us the work of writing out the SQL! +(company-employees company1) + +;; President of Widgets Inc. +(president company1) + +;; Manager of Josef Stalin +(employee-manager employee2) diff --git a/examples/dot.clsql-test.config b/examples/dot.clsql-test.config new file mode 100644 index 0000000..c6308a1 --- /dev/null +++ b/examples/dot.clsql-test.config @@ -0,0 +1,14 @@ +;; -*- Mode: Lisp -*- ;; Emacs mode line +;; +;; Example CLSQL test configuration file +;; Since this file is read by Lisp, it is okay to use +;; comments in this file +;; This file should be named .clsql-test.config and +;; placed in your home directory + +((:mysql ("localhost" "a-mysql-db" "user1" "secret")) + (:aodbc ("my-dsn" "a-user" "pass")) + (:postgresql ("localhost" "another-db" "user2" "dont-tell")) + (:postgresql-socket ("pg-server" "a-db-name" "user" "secret-password")) + (:sqlite ("path-to-sqlite-db"))) + diff --git a/examples/run-tests.sh b/examples/run-tests.sh new file mode 100755 index 0000000..acfb767 --- /dev/null +++ b/examples/run-tests.sh @@ -0,0 +1,78 @@ +#!/bin/bash + +REPORT_FILE=/tmp/clsql-test-report.txt +SEXP_REPORT_FILE=/tmp/clsql-test-report.sexp +LISP_CMD_FILE=/tmp/clsql-test.lisp + +CMD=" +(setq *print-readably* nil) +(let ((boot-file + (merge-pathnames + (parse-namestring #+allegro \".clinit.cl\" + #+cmu \".cmucl-init.lisp\" + #+lispworks \".lispworks\" + #+openmcl \"openmcl-init.lisp\" + #+sbcl \".sbclrc\" + #+scl \".scl-init.lisp\" + ) + (user-homedir-pathname)))) + (if (probe-file boot-file) + (load boot-file) + (warn \"Unable to load boot file ~A.\" boot-file))) + + (asdf:operate 'asdf:load-op 'clsql-tests) + (clsql-tests:run-tests-append-report-file \"${REPORT_FILE}\") + + #+allegro (excl:exit) + #+clisp (#+lisp=cl ext:quit #-lisp=cl lisp:quit) + #+cmu (ext:quit) + #+lispworks (lw:quit) + #+openmcl (ccl:quit) + #+sbcl (sb-ext:quit) + #+scl (ext:quit)" + +SUMMARY_CMD=" +(asdf:operate 'asdf:load-op 'clsql-tests) +(clsql-tests:summarize-test-report \"${SEXP_REPORT_FILE}\") + +#+allegro (excl:exit :quiet t) +#+clisp (#+lisp=cl ext:quit #-lisp=cl lisp:quit) +#+cmu (ext:quit) +#+lispworks (lw:quit) +#+openmcl (ccl:quit) +#+sbcl (sb-ext:quit)) +#+scl (ext:quit)" + +rm -rf $REPORT_FILE $SEXP_REPORT_FILE $LISP_CMD_FILE +echo $CMD > $LISP_CMD_FILE + +ALLEGRO=mlisp +if [ "`which $ALLEGRO`" ]; then + $ALLEGRO -q -L $LISP_CMD_FILE +fi + +CMUCL=lisp +if [ "`which $CMUCL`" ]; then + $CMUCL -init $LISP_CMD_FILE +fi + +LISPWORKS=lw-console +#if [ "`which $LISPWORKS`" ]; then + $LISPWORKS -init $LISP_CMD_FILE +#fi + +OPENCML=openmcl +#if [ "`which $OPENMCL`" ]; then + $OPENMCL -init $LISP_CMD_FILE +#fi + +SBCL=sbcl +if [ "`which $SBCL`" ]; then + $SBCL --noinform --disable-debugger --userinit $LISP_CMD_FILE +fi + +if [ -s $SEXP_REPORT_FILE ]; then + echo "$SUMMARY_CMD" | $SBCL +fi + +#rm -rf $LISP_CMD_FILE diff --git a/examples/sqlite3/init-func/Makefile b/examples/sqlite3/init-func/Makefile new file mode 100644 index 0000000..d771bdc --- /dev/null +++ b/examples/sqlite3/init-func/Makefile @@ -0,0 +1,21 @@ +#!/usr/bin/make +########################################################################## +# FILE IDENTIFICATION +# +# Name: Makefile +# Purpose: Makefile for SQLite 3 init function example. +# Programer: Aurelio Bignoli +# Date Started: Oct 2004 +# +# This file, part of CLSQL, is Copyright (c) 2004 by Aurelio Bignoli +# +# 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. +########################################################################## + + +sqlite3-utils.so: iso-8859-15-coll.c Makefile + gcc -c -fPIC iso-8859-15-coll.c -o iso-8859-15-coll.o + gcc -shared iso-8859-15-coll.o -o sqlite3-utils.so -l sqlite3 + diff --git a/examples/sqlite3/init-func/example.lisp b/examples/sqlite3/init-func/example.lisp new file mode 100644 index 0000000..eb04c07 --- /dev/null +++ b/examples/sqlite3/init-func/example.lisp @@ -0,0 +1,68 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: example.lisp +;;;; Purpose: Sample code for SQLite 3 initialization functions +;;;; Authors: Aurelio Bignoli +;;;; Created: Oct 2004 +;;;; +;;;; This file, part of CLSQL, is Copyright (c) 2004 by Aurelio Bignoli +;;;; +;;;; 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. +;;;; ************************************************************************* + +;;;; Load CLSQL. +(asdf:oos 'asdf:load-op :clsql-sqlite3) + +;;;; Load sqlite3-utils.so library. See Makefile for library creation. +(unless (uffi:load-foreign-library "/usr/lib/clsql/sqlite3-utils.so" + :module "sqlite3-utils" + :supporting-libraries '("c")) + (error "Unable to load foreign library")) + +;;;; Define the foreign function to be used as init function. +(uffi:def-function + ("create_iso_8859_15_ci_collation" create-coll) + ((db sqlite3:sqlite3-db)) + :returning :int + :module "sqlite3-utils") + +;;;; Create the DB using create-coll as init function. +(defparameter db-name "init-func-test.db") +(clsql:destroy-database (list db-name) :database-type :sqlite3) +(clsql:connect (list db-name #'create-coll) :database-type :sqlite3) + +;;;; Create a table. Field f2 uses the newly defined collating +;;;; sequence. +(clsql:execute-command + "CREATE TABLE t1 (f1 CHAR(1), f2 CHAR(1) COLLATE ISO_8859_15_CI)") + +;;;; Populate the table. +(clsql:execute-command "INSERT INTO t1 VALUES ('à ', 'à ')") +(clsql:execute-command "INSERT INTO t1 VALUES ('a', 'a')") +(clsql:execute-command "INSERT INTO t1 VALUES ('A', 'A')") +(clsql:execute-command "INSERT INTO t1 VALUES ('é', 'é')") +(clsql:execute-command "INSERT INTO t1 VALUES ('e', 'e')") +(clsql:execute-command "INSERT INTO t1 VALUES ('E', 'E')") +(clsql:execute-command "INSERT INTO t1 VALUES ('ì', 'ì')") +(clsql:execute-command "INSERT INTO t1 VALUES ('i', 'i')") +(clsql:execute-command "INSERT INTO t1 VALUES ('I', 'I')") +(clsql:execute-command "INSERT INTO t1 VALUES ('ò', 'ò')") +(clsql:execute-command "INSERT INTO t1 VALUES ('o', 'o')") +(clsql:execute-command "INSERT INTO t1 VALUES ('O', 'O')") +(clsql:execute-command "INSERT INTO t1 VALUES ('ù', 'ù')") +(clsql:execute-command "INSERT INTO t1 VALUES ('u', 'u')") +(clsql:execute-command "INSERT INTO t1 VALUES ('U', 'U')") + +;;;; Perform some SELECTs. +(format t "~&SELECT * FROM t1 ==> ~A~%"(clsql:query "SELECT * FROM t1")) +(format t "~&SELECT * FROM t1 ORDER BY f1 ==> ~A~%" + (clsql:query "SELECT * FROM t1 ORDER BY f1")) +(format t "~&SELECT * FROM t1 ORDER BY f2 ==> ~A~%" + (clsql:query "SELECT * FROM t1 ORDER BY f2")) + +;;;; Disconnect from database. +(clsql:disconnect) diff --git a/examples/sqlite3/init-func/iso-8859-15-coll.c b/examples/sqlite3/init-func/iso-8859-15-coll.c new file mode 100644 index 0000000..a5d0f8e --- /dev/null +++ b/examples/sqlite3/init-func/iso-8859-15-coll.c @@ -0,0 +1,77 @@ +/**************************************************************************** + * FILE IDENTIFICATION + * + * Name: iso-8859-15-coll.c + * Purpose: SQLite 3 initialization function for + * ISO-8859-15 collating sequence. + * Programmer: Aurelio Bignoli + * Date Started: Oct 2004 + * + * This file, part of CLSQL, is Copyright (c) 2004 by Aurelio Bignoli + * + * 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. + ***************************************************************************/ + + +/* Collating sequence name. CI = Case Insensitive */ +#define ISO_8859_15_CI_NAME "ISO_8859_15_CI" + +/* Conversion table. */ +const unsigned char iso_8859_15_ci [] = { + /* 0 */ 0x00, 0x01, 0x02, 0x03, 0x04, 0x05, 0x06, 0x07, 0x08, 0x09, 0x0A, 0x0B, 0x0C, 0x0D, 0x0E, 0x0F, + /* 1 */ 0x10, 0x11, 0x12, 0x13, 0x14, 0x15, 0x16, 0x17, 0x18, 0x19, 0x1A, 0x1B, 0x1C, 0x1D, 0x1E, 0x1F, + /* 2 */ 0x20, 0x21, 0x22, 0x23, 0x24, 0x25, 0x26, 0x27, 0x28, 0x29, 0x2A, 0x2B, 0x2C, 0x2D, 0x2E, 0x2F, + /* 3 */ 0x30, 0x31, 0x32, 0x33, 0x34, 0x35, 0x36, 0x37, 0x38, 0x39, 0x3A, 0x3B, 0x3C, 0x3D, 0x3E, 0x3F, + /* 4 */ 0x40, 0x61, 0x62, 0x63, 0x64, 0x65, 0x66, 0x67, 0x68, 0x69, 0x6A, 0x6B, 0x6C, 0x6D, 0x6E, 0x6F, + /* 5 */ 0x70, 0x71, 0x72, 0x73, 0x74, 0x75, 0x76, 0x77, 0x78, 0x79, 0x7A, 0x5B, 0x5C, 0x5D, 0x5E, 0x5F, + /* 6 */ 0x60, 0x61, 0x62, 0x63, 0x64, 0x65, 0x66, 0x67, 0x68, 0x69, 0x6A, 0x6B, 0x6C, 0x6D, 0x6E, 0x6F, + /* 7 */ 0x70, 0x71, 0x72, 0x73, 0x74, 0x75, 0x76, 0x77, 0x78, 0x79, 0x7A, 0x7B, 0x7C, 0x7D, 0x7E, 0x7F, + /* 8 */ 0x80, 0x81, 0x82, 0x83, 0x84, 0x85, 0x86, 0x87, 0x88, 0x89, 0x73, 0x8B, 0x6F, 0x8D, 0x7A, 0x79, + /* 9 */ 0x90, 0x91, 0x92, 0x93, 0x94, 0x95, 0x96, 0x97, 0x98, 0x99, 0x73, 0x9B, 0x6F, 0x9D, 0x7A, 0x79, + /* A */ 0xA0, 0xA1, 0xA2, 0xA3, 0xA4, 0xA5, 0x73, 0xA7, 0x73, 0xA9, 0xAA, 0xAB, 0xAC, 0xAD, 0xAE, 0xAF, + /* B */ 0xB0, 0xB1, 0xB2, 0xB3, 0x7A, 0xB5, 0xB6, 0xB7, 0x7A, 0xB9, 0xBA, 0xBB, 0x6F, 0xBD, 0x79, 0xBF, + /* C */ 0x61, 0x61, 0x61, 0x61, 0x61, 0x61, 0x65, 0x63, 0x65, 0x65, 0x65, 0x65, 0x69, 0x69, 0x69, 0x69, + /* D */ 0x64, 0x6E, 0x6F, 0x6F, 0x6F, 0x6F, 0x6F, 0xD7, 0x6F, 0x75, 0x75, 0x75, 0x75, 0x79, 0xDE, 0x73, + /* E */ 0x61, 0x61, 0x61, 0x61, 0x61, 0x61, 0x65, 0x63, 0x65, 0x65, 0x65, 0x65, 0x69, 0x69, 0x69, 0x69, + /* F */ 0x64, 0x6E, 0x6F, 0x6F, 0x6F, 0x6F, 0x6F, 0xF7, 0x6F, 0x75, 0x75, 0x75, 0x75, 0x79, 0xFE, 0x73 +}; + +/* + * A modified version of sqlite3StrNICmp in sqlite/src/util.c + */ +int iso_8859_15_ci_StrCmp(const char *zLeft, const char *zRight, int N){ + register unsigned char *a, *b; + a = (unsigned char *)zLeft; + b = (unsigned char *)zRight; + while( N-- > 0 && *a!=0 && iso_8859_15_ci[*a]==iso_8859_15_ci[*b]){ a++; b++; } + return N<0 ? 0 : iso_8859_15_ci[*a] - iso_8859_15_ci[*b]; +} + +/* + * A modified version of nocaseCollatinFunc in sqlite/src/main.c. + */ +int iso_8859_15_ci_CollatingFunc( + void *NotUsed, + int nKey1, const void *pKey1, + int nKey2, const void *pKey2 +){ + int r = iso_8859_15_ci_StrCmp( + (const char *)pKey1, (const char *)pKey2, (nKey1<nKey2)?nKey1:nKey2); + if( 0==r ){ + r = nKey1-nKey2; + } + return r; +} + +/* + * Set the ISO_8859_15_CI collating sequence for a db. + */ +#include "sqlite3.h" + +int create_iso_8859_15_ci_collation (sqlite3 *db) +{ + return sqlite3_create_collation (db, ISO_8859_15_CI_NAME, SQLITE_UTF8, 0, + iso_8859_15_ci_CollatingFunc); +} diff --git a/notes/add-type-hints.txt b/notes/add-type-hints.txt new file mode 100644 index 0000000..1f129b5 --- /dev/null +++ b/notes/add-type-hints.txt @@ -0,0 +1,32 @@ +How to Add a Type to CL-SQL (Alan Shields - Alan-Shields@omrf.ouhsc.edu) + +I made this small guide to eliminate some of the work I went through. +I hope it is useful and/or correct. + +To add a type to CL-SQL, the following methods need to be +declared. + + +"sql/expressions.lisp" +(defmethod database-output-sql (self database)) + +SELF is specialized for the lisp type, such as (self integer). + +"sql/oodml.lisp" +(defmethod database-get-type-specifier (type args database db-type)) + +TYPE is a symbol for the clsql type, such as (type (eql 'integer)). +Note that DB-TYPE is the database type, not DATABASE. + +"sql/oodml.lisp" +(defmethod read-sql-value (val type database db-type)) + +TYPE is a symbol for the clsql type, as above. +Same warnings as above. + + +If your type is stored in different ways in different sql servers, you'll need +to specialize these methods. + +These specializations usually go in either db-<database>/<database>-objects.lisp or +sql/generic-<database>.lisp. diff --git a/sql/Makefile b/sql/Makefile new file mode 100644 index 0000000..1f71fb2 --- /dev/null +++ b/sql/Makefile @@ -0,0 +1,24 @@ +#!/usr/bin/make +########################################################################## +# FILE IDENTIFICATION +# +# Name: Makefile +# Purpose: Makefile for CLSQL SQL interface +# Programer: Kevin M. Rosenberg +# Date Started: Mar 2002 +# +# This file, part of CLSQL, is Copyright (c) 2002-2010 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. +########################################################################## + + +SUBDIRS= + +include ../Makefile.common + +.PHONY: distclean +distclean: clean + diff --git a/sql/ansi-loop.lisp b/sql/ansi-loop.lisp new file mode 100644 index 0000000..6a2cab4 --- /dev/null +++ b/sql/ansi-loop.lisp @@ -0,0 +1,2282 @@ +;;; -*- Mode: LISP; Package: ANSI-LOOP; Syntax: Common-lisp; Base: 10; Lowercase:T -*- +;;; +;;; This file is included with CLSQL to be used by CLISP which does not +;;; have an extensible LOOP macro. It was copied from the CMUCL 19c source. +;;; Minor porting changes have been made Copyright (c) 2006 Kevin M. Rosenberg +;;; +;;;> +;;;> Portions of LOOP are Copyright (c) 1986 by the Massachusetts Institute of Technology. +;;;> All Rights Reserved. +;;;> +;;;> Permission to use, copy, modify and distribute this software and its +;;;> documentation for any purpose and without fee is hereby granted, +;;;> provided that the M.I.T. copyright notice appear in all copies and that +;;;> both that copyright notice and this permission notice appear in +;;;> supporting documentation. The names "M.I.T." and "Massachusetts +;;;> Institute of Technology" may not be used in advertising or publicity +;;;> pertaining to distribution of the software without specific, written +;;;> prior permission. Notice must be given in supporting documentation that +;;;> copying distribution is by permission of M.I.T. M.I.T. makes no +;;;> representations about the suitability of this software for any purpose. +;;;> It is provided "as is" without express or implied warranty. +;;;> +;;;> Massachusetts Institute of Technology +;;;> 77 Massachusetts Avenue +;;;> Cambridge, Massachusetts 02139 +;;;> United States of America +;;;> +1-617-253-1000 +;;;> +;;;> Portions of LOOP are Copyright (c) 1989, 1990, 1991, 1992 by Symbolics, Inc. +;;;> All Rights Reserved. +;;;> +;;;> Permission to use, copy, modify and distribute this software and its +;;;> documentation for any purpose and without fee is hereby granted, +;;;> provided that the Symbolics copyright notice appear in all copies and +;;;> that both that copyright notice and this permission notice appear in +;;;> supporting documentation. The name "Symbolics" may not be used in +;;;> advertising or publicity pertaining to distribution of the software +;;;> without specific, written prior permission. Notice must be given in +;;;> supporting documentation that copying distribution is by permission of +;;;> Symbolics. Symbolics makes no representations about the suitability of +;;;> this software for any purpose. It is provided "as is" without express +;;;> or implied warranty. +;;;> +;;;> Symbolics, CLOE Runtime, and Minima are trademarks, and CLOE, Genera, +;;;> and Zetalisp are registered trademarks of Symbolics, Inc. +;;;> +;;;> Symbolics, Inc. +;;;> 8 New England Executive Park, East +;;;> Burlington, Massachusetts 01803 +;;;> United States of America +;;;> +1-617-221-1000 + +;; $aclHeader: loop.cl,v 1.5 91/12/04 01:13:48 cox acl4_1 $ +#+cmu +(ext:file-comment + "$Header: /project/cmucl/cvsroot/src/code/loop.lisp,v 1.27 2004/10/21 02:31:08 rtoy Exp $") + + +;;;; LOOP Iteration Macro + +#+clisp +(eval-when (:compile-toplevel :load-toplevel :execute) + (setf (ext:package-lock (find-package "COMMON-LISP")) nil)) +(defpackage ansi-loop (:use :common-lisp) + (:shadowing-import-from "COMMON-LISP" "LOOP" "LOOP-FINISH")) +(in-package ansi-loop) + +;;; Technology. +;;; +;;; The LOOP iteration macro is one of a number of pieces of code +;;; originally developed at MIT and licensed as set out above. This +;;; version of LOOP, which is almost entirely rewritten both as a +;;; clean-up and to conform with the ANSI Lisp LOOP standard, started +;;; life as MIT LOOP version 829 (which was a part of NIL, possibly +;;; never released). +;;; +;;; A "light revision" was performed by Glenn Burke while at Palladian +;;; Software in April 1986, to make the code run in Common Lisp. This +;;; revision was informally distributed to a number of people, and was +;;; sort of the "MIT" version of LOOP for running in Common Lisp. +;;; +;;; A later more drastic revision was performed at Palladian perhaps a +;;; year later. This version was more thoroughly Common Lisp in +;;; style, with a few miscellaneous internal improvements and +;;; extensions. Glenn Burke lost track of this source, apparently +;;; never having moved it to the MIT distribution point; and does not +;;; remember if it was ever distributed. +;;; +;;; This revision for the ANSI standard is based on the code of Glenn +;;; Burke's April 1986 version, with almost everything redesigned +;;; and/or rewritten. + + +;;; The design of this LOOP is intended to permit, using mostly the same +;;; kernel of code, up to three different "loop" macros: +;;; +;;; (1) The unextended, unextensible ANSI standard LOOP; +;;; +;;; (2) A clean "superset" extension of the ANSI LOOP which provides +;;; functionality similar to that of the old LOOP, but "in the style of" +;;; the ANSI LOOP. For instance, user-definable iteration paths, with a +;;; somewhat cleaned-up interface. +;;; +;;; (3) Extensions provided in another file which can make this LOOP +;;; kernel behave largely compatibly with the Genera-vintage LOOP macro, +;;; with only a small addition of code (instead of two whole, separate, +;;; LOOP macros). +;;; +;;; Each of the above three LOOP variations can coexist in the same LISP +;;; environment. +;;; + + +;;;; Miscellaneous Environment Things + + + +;;;@@@@The LOOP-Prefer-POP feature makes LOOP generate code which "prefers" to use POP or +;;; its obvious expansion (prog1 (car x) (setq x (cdr x))). Usually this involves +;;; shifting fenceposts in an iteration or series of carcdr operations. This is +;;; primarily recognized in the list iterators (FOR .. {IN,ON}), and LOOP's +;;; destructuring setq code. +(eval-when (compile load eval) + #+(or Genera Minima) (pushnew :LOOP-Prefer-POP *features*) + ) + + +;;; The uses of this macro are retained in the CL version of loop, in +;;; case they are needed in a particular implementation. Originally +;;; dating from the use of the Zetalisp COPYLIST* function, this is used +;;; in situations where, were cdr-coding in use, having cdr-NIL at the +;;; end of the list might be suboptimal because the end of the list will +;;; probably be RPLACDed and so cdr-normal should be used instead. +(defmacro loop-copylist* (l) + #+Genera `(lisp:copy-list ,l nil t) ; arglist = (list &optional area force-dotted) + ;;@@@@Explorer?? + #-Genera `(copy-list ,l) + ) + + +(defvar *loop-gentemp* t) + +(defun loop-gentemp (&optional (pref 'loopvar-)) + (if *loop-gentemp* + (gensym (string pref)) + (gensym))) + + + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defvar *loop-real-data-type* 'real)) + + +(defun loop-optimization-quantities (env) + ;;@@@@ The ANSI conditionalization here is for those lisps that implement + ;; DECLARATION-INFORMATION (from cleanup SYNTACTIC-ENVIRONMENT-ACCESS). + ;; It is really commentary on how this code could be written. I don't + ;; actually expect there to be an ANSI #+-conditional -- it should be + ;; replaced with the appropriate conditional name for your + ;; implementation/dialect. + (declare #-ANSI (ignore env) + #+Genera (values speed space safety compilation-speed debug)) + #+ANSI (let ((stuff (declaration-information 'optimize env))) + (values (or (cdr (assoc 'speed stuff)) 1) + (or (cdr (assoc 'space stuff)) 1) + (or (cdr (assoc 'safety stuff)) 1) + (or (cdr (assoc 'compilation-speed stuff)) 1) + (or (cdr (assoc 'debug stuff)) 1))) + #+CLOE-Runtime (values compiler::time compiler::space + compiler::safety compiler::compilation-speed 1) + #-(or ANSI CLOE-Runtime) (values 1 1 1 1 1)) + + +;;;@@@@ The following form takes a list of variables and a form which presumably +;;; references those variables, and wraps it somehow so that the compiler does not +;;; consider those variables have been referenced. The intent of this is that +;;; iteration variables can be flagged as unused by the compiler, e.g. I in +;;; (loop for i from 1 to 10 do (print t)), since we will tell it when a usage +;;; of it is "invisible" or "not to be considered". +;;;We implicitly assume that a setq does not count as a reference. That is, the +;;; kind of form generated for the above loop construct to step I, simplified, is +;;; `(SETQ I ,(HIDE-VARIABLE-REFERENCES '(I) '(1+ I))). +(defun hide-variable-references (variable-list form) + (declare #-Genera (ignore variable-list)) + #+Genera (if variable-list `(compiler:invisible-references ,variable-list ,form) form) + #-Genera form) + + +;;;@@@@ The following function takes a flag, a variable, and a form which presumably +;;; references that variable, and wraps it somehow so that the compiler does not +;;; consider that variable to have been referenced. The intent of this is that +;;; iteration variables can be flagged as unused by the compiler, e.g. I in +;;; (loop for i from 1 to 10 do (print t)), since we will tell it when a usage +;;; of it is "invisible" or "not to be considered". +;;;We implicitly assume that a setq does not count as a reference. That is, the +;;; kind of form generated for the above loop construct to step I, simplified, is +;;; `(SETQ I ,(HIDE-VARIABLE-REFERENCES T 'I '(1+ I))). +;;;Certain cases require that the "invisibility" of the reference be conditional upon +;;; something. This occurs in cases of "named" variables (the USING clause). For instance, +;;; we want IDX in (LOOP FOR E BEING THE VECTOR-ELEMENTS OF V USING (INDEX IDX) ...) +;;; to be "invisible" when it is stepped, so that the user gets informed if IDX is +;;; not referenced. However, if no USING clause is present, we definitely do not +;;; want to be informed that some random gensym is not used. +;;;It is easier for the caller to do this conditionally by passing a flag (which +;;; happens to be the second value of NAMED-VARIABLE, q.v.) to this function than +;;; for all callers to contain the conditional invisibility construction. +(defun hide-variable-reference (really-hide variable form) + (declare #-Genera (ignore really-hide variable)) + #+Genera (if (and really-hide variable (atom variable)) ;Punt on destructuring patterns + `(compiler:invisible-references (,variable) ,form) + form) + #-Genera form) + + +;;;; List Collection Macrology + + +(defmacro with-loop-list-collection-head ((head-var tail-var &optional user-head-var) + &body body) + ;;@@@@ TI? Exploder? + #+LISPM (let ((head-place (or user-head-var head-var))) + `(let* ((,head-place nil) + (,tail-var + ,(hide-variable-reference + user-head-var user-head-var + `(progn #+Genera (scl:locf ,head-place) + #-Genera (system:variable-location ,head-place))))) + ,@body)) + #-LISPM (let ((l (and user-head-var (list (list user-head-var nil))))) + #+CLOE `(sys::with-stack-list* (,head-var nil nil) + (let ((,tail-var ,head-var) ,@l) + ,@body)) + #-CLOE `(let* ((,head-var (list nil)) (,tail-var ,head-var) ,@l) + ,@body))) + + +(defmacro loop-collect-rplacd (&environment env + (head-var tail-var &optional user-head-var) form) + (declare + #+LISPM (ignore head-var user-head-var) ;use locatives, unconditionally update through the tail. + ) + (setq form (macroexpand form env)) + (flet ((cdr-wrap (form n) + (declare (fixnum n)) + (do () ((<= n 4) (setq form `(,(case n + (1 'cdr) + (2 'cddr) + (3 'cdddr) + (4 'cddddr)) + ,form))) + (setq form `(cddddr ,form) n (- n 4))))) + (let ((tail-form form) (ncdrs nil)) + ;;Determine if the form being constructed is a list of known length. + (when (consp form) + (cond ((eq (car form) 'list) + (setq ncdrs (1- (length (cdr form)))) + ;;@@@@ Because the last element is going to be RPLACDed, + ;; we don't want the cdr-coded implementations to use + ;; cdr-nil at the end (which would just force copying + ;; the whole list again). + #+LISPM (setq tail-form `(list* ,@(cdr form) nil))) + ((member (car form) '(list* cons)) + (when (and (cddr form) (member (car (last form)) '(nil 'nil))) + (setq ncdrs (- (length (cdr form)) 2)))))) + (let ((answer + (cond ((null ncdrs) + `(when (setf (cdr ,tail-var) ,tail-form) + (setq ,tail-var (last (cdr ,tail-var))))) + ((< ncdrs 0) (return-from loop-collect-rplacd nil)) + ((= ncdrs 0) + ;;@@@@ Here we have a choice of two idioms: + ;; (rplacd tail (setq tail tail-form)) + ;; (setq tail (setf (cdr tail) tail-form)). + ;;Genera and most others I have seen do better with the former. + `(rplacd ,tail-var (setq ,tail-var ,tail-form))) + (t `(setq ,tail-var ,(cdr-wrap `(setf (cdr ,tail-var) ,tail-form) + ncdrs)))))) + ;;If not using locatives or something similar to update the user's + ;; head variable, we've got to set it... It's harmless to repeatedly set it + ;; unconditionally, and probably faster than checking. + #-LISPM (when user-head-var + (setq answer `(progn ,answer (setq ,user-head-var (cdr ,head-var))))) + answer)))) + + +(defmacro loop-collect-answer (head-var &optional user-head-var) + (or user-head-var + (progn + ;;If we use locatives to get tail-updating to update the head var, + ;; then the head var itself contains the answer. Otherwise we + ;; have to cdr it. + #+LISPM head-var + #-LISPM `(cdr ,head-var)))) + + +;;;; Maximization Technology + + +#| +The basic idea of all this minimax randomness here is that we have to +have constructed all uses of maximize and minimize to a particular +"destination" before we can decide how to code them. The goal is to not +have to have any kinds of flags, by knowing both that (1) the type is +something which we can provide an initial minimum or maximum value for +and (2) know that a MAXIMIZE and MINIMIZE are not being combined. + +SO, we have a datastructure which we annotate with all sorts of things, +incrementally updating it as we generate loop body code, and then use +a wrapper and internal macros to do the coding when the loop has been +constructed. +|# + + +(defstruct (loop-minimax + (:constructor make-loop-minimax-internal) + (:copier nil) + (:predicate nil)) + answer-variable + type + temp-variable + flag-variable + operations + infinity-data) + + +(defvar *loop-minimax-type-infinities-alist* + ;;@@@@ This is the sort of value this should take on for a Lisp that has + ;; "eminently usable" infinities. n.b. there are neither constants nor + ;; printed representations for infinities defined by CL. + ;;@@@@ This grotesque read-from-string below is to help implementations + ;; which croak on the infinity character when it appears in a token, even + ;; conditionalized out. + #+Genera + '#.(read-from-string + "((fixnum most-positive-fixnum most-negative-fixnum) + (short-float +1s -1s) + (single-float +1f -1f) + (double-float +1d -1d) + (long-float +1l -1l))") + ;;This is how the alist should look for a lisp that has no infinities. In + ;; that case, MOST-POSITIVE-x-FLOAT really IS the most positive. + #+(or CLOE-Runtime Minima) + '((fixnum most-positive-fixnum most-negative-fixnum) + (short-float most-positive-short-float most-negative-short-float) + (single-float most-positive-single-float most-negative-single-float) + (double-float most-positive-double-float most-negative-double-float) + (long-float most-positive-long-float most-negative-long-float)) + ;; CMUCL has infinities so let's use them. + #+CMU + '((fixnum most-positive-fixnum most-negative-fixnum) + (short-float ext:single-float-positive-infinity ext:single-float-negative-infinity) + (single-float ext:single-float-positive-infinity ext:single-float-negative-infinity) + (double-float ext:double-float-positive-infinity ext:double-float-negative-infinity) + (long-float ext:long-float-positive-infinity ext:long-float-negative-infinity)) + ;; If we don't know, then we cannot provide "infinite" initial values for any of the + ;; types but FIXNUM: + #-(or Genera CLOE-Runtime Minima CMU) + '((fixnum most-positive-fixnum most-negative-fixnum)) + ) + + +(defun make-loop-minimax (answer-variable type) + (let ((infinity-data (cdr (assoc type *loop-minimax-type-infinities-alist* :test #'subtypep)))) + (make-loop-minimax-internal + :answer-variable answer-variable + :type type + :temp-variable (loop-gentemp 'loop-maxmin-temp-) + :flag-variable (and (not infinity-data) (loop-gentemp 'loop-maxmin-flag-)) + :operations nil + :infinity-data infinity-data))) + + +(defun loop-note-minimax-operation (operation minimax) + (pushnew (the symbol operation) (loop-minimax-operations minimax)) + (when (and (cdr (loop-minimax-operations minimax)) + (not (loop-minimax-flag-variable minimax))) + (setf (loop-minimax-flag-variable minimax) (loop-gentemp 'loop-maxmin-flag-))) + operation) + + +(defmacro with-minimax-value (lm &body body) + (let ((init (loop-typed-init (loop-minimax-type lm))) + (which (car (loop-minimax-operations lm))) + (infinity-data (loop-minimax-infinity-data lm)) + (answer-var (loop-minimax-answer-variable lm)) + (temp-var (loop-minimax-temp-variable lm)) + (flag-var (loop-minimax-flag-variable lm)) + (type (loop-minimax-type lm))) + (if flag-var + `(let ((,answer-var ,init) (,temp-var ,init) (,flag-var nil)) + (declare (type ,type ,answer-var ,temp-var)) + ,@body) + `(let ((,answer-var ,(if (eq which 'min) (first infinity-data) (second infinity-data))) + (,temp-var ,init)) + (declare (type ,type ,answer-var ,temp-var)) + ,@body)))) + + +(defmacro loop-accumulate-minimax-value (lm operation form) + (let* ((answer-var (loop-minimax-answer-variable lm)) + (temp-var (loop-minimax-temp-variable lm)) + (flag-var (loop-minimax-flag-variable lm)) + (test + (hide-variable-reference + t (loop-minimax-answer-variable lm) + `(,(ecase operation + (min '<) + (max '>)) + ,temp-var ,answer-var)))) + `(progn + (setq ,temp-var ,form) + (when ,(if flag-var `(or (not ,flag-var) ,test) test) + (setq ,@(and flag-var `(,flag-var t)) + ,answer-var ,temp-var))))) + + + +;;;; Loop Keyword Tables + + +#| +LOOP keyword tables are hash tables string keys and a test of EQUAL. + +The actual descriptive/dispatch structure used by LOOP is called a "loop +universe" contains a few tables and parameterizations. The basic idea is +that we can provide a non-extensible ANSI-compatible loop environment, +an extensible ANSI-superset loop environment, and (for such environments +as CLOE) one which is "sufficiently close" to the old Genera-vintage +LOOP for use by old user programs without requiring all of the old LOOP +code to be loaded. +|# + + +;;;; Token Hackery + + +;;;Compare two "tokens". The first is the frob out of *LOOP-SOURCE-CODE*, +;;; the second a symbol to check against. +(defun loop-tequal (x1 x2) + (and (symbolp x1) (string= x1 x2))) + + +(defun loop-tassoc (kwd alist) + (and (symbolp kwd) (assoc kwd alist :test #'string=))) + + +(defun loop-tmember (kwd list) + (and (symbolp kwd) (member kwd list :test #'string=))) + + +(defun loop-lookup-keyword (loop-token table) + (and (symbolp loop-token) + (values (gethash (symbol-name loop-token) table)))) + + +(defmacro loop-store-table-data (symbol table datum) + `(setf (gethash (symbol-name ,symbol) ,table) ,datum)) + + +(defstruct (loop-universe + (:print-function print-loop-universe) + (:copier nil) + (:predicate nil)) + keywords ;hash table, value = (fn-name . extra-data). + iteration-keywords ;hash table, value = (fn-name . extra-data). + for-keywords ;hash table, value = (fn-name . extra-data). + path-keywords ;hash table, value = (fn-name . extra-data). + type-symbols ;hash table of type SYMBOLS, test EQ, value = CL type specifier. + type-keywords ;hash table of type STRINGS, test EQUAL, value = CL type spec. + ansi ;NIL, T, or :EXTENDED. + implicit-for-required ;see loop-hack-iteration + ) + + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun print-loop-universe (u stream level) + (declare (ignore level)) + (let ((str (case (loop-universe-ansi u) + ((nil) "Non-ANSI") + ((t) "ANSI") + (:extended "Extended-ANSI") + (t (loop-universe-ansi u))))) + ;;Cloe could be done with the above except for bootstrap lossage... + #+CLOE + (format stream "#<~S ~A ~X>" (type-of u) str (sys::address-of u)) + (print-unreadable-object (u stream :type t :identity t) + (princ str stream)) + ))) + + +;;;This is the "current" loop context in use when we are expanding a +;;;loop. It gets bound on each invocation of LOOP. +(defvar *loop-universe*) + + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun make-standard-loop-universe (&key keywords for-keywords iteration-keywords path-keywords + type-keywords type-symbols ansi) + #-(and CLOE Source-Bootstrap) (check-type ansi (member nil t :extended)) + (flet ((maketable (entries) + (let* ((size (length entries)) + (ht (make-hash-table :size (if (< size 10) 10 size) :test #'equal))) + (dolist (x entries) (setf (gethash (symbol-name (car x)) ht) (cadr x))) + ht))) + (make-loop-universe + :keywords (maketable keywords) + :for-keywords (maketable for-keywords) + :iteration-keywords (maketable iteration-keywords) + :path-keywords (maketable path-keywords) + :ansi ansi + :implicit-for-required (not (null ansi)) + :type-keywords (maketable type-keywords) + :type-symbols (let* ((size (length type-symbols)) + (ht (make-hash-table :size (if (< size 10) 10 size) :test #'eq))) + (dolist (x type-symbols) + (if (atom x) (setf (gethash x ht) x) (setf (gethash (car x) ht) (cadr x)))) + ht))))) + + + +;;;; Setq Hackery + + +(defvar *loop-destructuring-hooks* + nil + "If not NIL, this must be a list of two things: +a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring.") + + +(defun loop-make-psetq (frobs) + (and frobs + (loop-make-desetq + (list (car frobs) + (if (null (cddr frobs)) (cadr frobs) + `(prog1 ,(cadr frobs) + ,(loop-make-psetq (cddr frobs)))))))) + + +(defun loop-make-desetq (var-val-pairs) + (if (null var-val-pairs) + nil + (cons (if *loop-destructuring-hooks* + (cadr *loop-destructuring-hooks*) + 'loop-really-desetq) + var-val-pairs))) + + +(defvar *loop-desetq-temporary* + (make-symbol "LOOP-DESETQ-TEMP")) + + +(defmacro loop-really-desetq (&environment env &rest var-val-pairs) + (labels ((find-non-null (var) + ;; see if there's any non-null thing here + ;; recurse if the list element is itself a list + (do ((tail var)) ((not (consp tail)) tail) + (when (find-non-null (pop tail)) (return t)))) + (loop-desetq-internal (var val &optional temp) + ;; returns a list of actions to be performed + (typecase var + (null + (when (consp val) + ;; don't lose possible side-effects + (if (eq (car val) 'prog1) + ;; these can come from psetq or desetq below. + ;; throw away the value, keep the side-effects. + ;;Special case is for handling an expanded POP. + (mapcan #'(lambda (x) + (and (consp x) + (or (not (eq (car x) 'car)) + (not (symbolp (cadr x))) + (not (symbolp (setq x (macroexpand x env))))) + (cons x nil))) + (cdr val)) + `(,val)))) + (cons + (let* ((car (car var)) + (cdr (cdr var)) + (car-non-null (find-non-null car)) + (cdr-non-null (find-non-null cdr))) + (when (or car-non-null cdr-non-null) + (if cdr-non-null + (let* ((temp-p temp) + (temp (or temp *loop-desetq-temporary*)) + (body #+LOOP-Prefer-POP `(,@(loop-desetq-internal + car + `(prog1 (car ,temp) + (setq ,temp (cdr ,temp)))) + ,@(loop-desetq-internal cdr temp temp)) + #-LOOP-Prefer-POP `(,@(loop-desetq-internal car `(car ,temp)) + (setq ,temp (cdr ,temp)) + ,@(loop-desetq-internal cdr temp temp)))) + (if temp-p + `(,@(unless (eq temp val) + `((setq ,temp ,val))) + ,@body) + `((let ((,temp ,val)) + ,@body)))) + ;; no cdring to do + (loop-desetq-internal car `(car ,val) temp))))) + (otherwise + (unless (eq var val) + `((setq ,var ,val))))))) + (do ((actions)) + ((null var-val-pairs) + (if (null (cdr actions)) (car actions) `(progn ,@(nreverse actions)))) + (setq actions (revappend + (loop-desetq-internal (pop var-val-pairs) (pop var-val-pairs)) + actions))))) + + +;;;; LOOP-local variables + +;;;This is the "current" pointer into the LOOP source code. +(defvar *loop-source-code*) + + +;;;This is the pointer to the original, for things like NAMED that +;;;insist on being in a particular position +(defvar *loop-original-source-code*) + + +;;;This is *loop-source-code* as of the "last" clause. It is used +;;;primarily for generating error messages (see loop-error, loop-warn). +(defvar *loop-source-context*) + + +;;;List of names for the LOOP, supplied by the NAMED clause. +(defvar *loop-names*) + +;;;The macroexpansion environment given to the macro. +(defvar *loop-macro-environment*) + +;;;This holds variable names specified with the USING clause. +;;; See LOOP-NAMED-VARIABLE. +(defvar *loop-named-variables*) + +;;; LETlist-like list being accumulated for one group of parallel bindings. +(defvar *loop-variables*) + +;;;List of declarations being accumulated in parallel with +;;;*loop-variables*. +(defvar *loop-declarations*) + +;;;Used by LOOP for destructuring binding, if it is doing that itself. +;;; See loop-make-variable. +(defvar *loop-desetq-crocks*) + +;;; List of wrapping forms, innermost first, which go immediately inside +;;; the current set of parallel bindings being accumulated in +;;; *loop-variables*. The wrappers are appended onto a body. E.g., +;;; this list could conceivably has as its value ((with-open-file (g0001 +;;; g0002 ...))), with g0002 being one of the bindings in +;;; *loop-variables* (this is why the wrappers go inside of the variable +;;; bindings). +(defvar *loop-wrappers*) + +;;;This accumulates lists of previous values of *loop-variables* and the +;;;other lists above, for each new nesting of bindings. See +;;;loop-bind-block. +(defvar *loop-bind-stack*) + +;;;This is a LOOP-global variable for the (obsolete) NODECLARE clause +;;;which inhibits LOOP from actually outputting a type declaration for +;;;an iteration (or any) variable. +(defvar *loop-nodeclare*) + +;;;This is simply a list of LOOP iteration variables, used for checking +;;;for duplications. +(defvar *loop-iteration-variables*) + + +;;;List of prologue forms of the loop, accumulated in reverse order. +(defvar *loop-prologue*) + +(defvar *loop-before-loop*) +(defvar *loop-body*) +(defvar *loop-after-body*) + +;;;This is T if we have emitted any body code, so that iteration driving +;;;clauses can be disallowed. This is not strictly the same as +;;;checking *loop-body*, because we permit some clauses such as RETURN +;;;to not be considered "real" body (so as to permit the user to "code" +;;;an abnormal return value "in loop"). +(defvar *loop-emitted-body*) + + +;;;List of epilogue forms (supplied by FINALLY generally), accumulated +;;; in reverse order. +(defvar *loop-epilogue*) + +;;;List of epilogue forms which are supplied after the above "user" +;;;epilogue. "normal" termination return values are provide by putting +;;;the return form in here. Normally this is done using +;;;loop-emit-final-value, q.v. +(defvar *loop-after-epilogue*) + +;;;The "culprit" responsible for supplying a final value from the loop. +;;;This is so loop-emit-final-value can moan about multiple return +;;;values being supplied. +(defvar *loop-final-value-culprit*) + +;;;If not NIL, we are in some branch of a conditional. Some clauses may +;;;be disallowed. +(defvar *loop-inside-conditional*) + +;;;If not NIL, this is a temporary bound around the loop for holding the +;;;temporary value for "it" in things like "when (f) collect it". It +;;;may be used as a supertemporary by some other things. +(defvar *loop-when-it-variable*) + +;;;Sometimes we decide we need to fold together parts of the loop, but +;;;some part of the generated iteration code is different for the first +;;;and remaining iterations. This variable will be the temporary which +;;;is the flag used in the loop to tell whether we are in the first or +;;;remaining iterations. +(defvar *loop-never-stepped-variable*) + +;;;List of all the value-accumulation descriptor structures in the loop. +;;; See loop-get-collection-info. +(defvar *loop-collection-cruft*) ; for multiple COLLECTs (etc) + + +;;;; Code Analysis Stuff + + +(defun loop-constant-fold-if-possible (form &optional expected-type) + #+Genera (declare (values new-form constantp constant-value)) + (let ((new-form form) (constantp nil) (constant-value nil)) + #+Genera (setq new-form (compiler:optimize-form form *loop-macro-environment* + :repeat t + :do-macro-expansion t + :do-named-constants t + :do-inline-forms t + :do-optimizers t + :do-constant-folding t + :do-function-args t) + constantp (constantp new-form *loop-macro-environment*) + constant-value (and constantp (lt:evaluate-constant new-form *loop-macro-environment*))) + #-Genera (when (setq constantp (constantp new-form)) + (setq constant-value (eval new-form))) + (when (and constantp expected-type) + (unless (typep constant-value expected-type) + (loop-warn "The form ~S evaluated to ~S, which was not of the anticipated type ~S." + form constant-value expected-type) + (setq constantp nil constant-value nil))) + (values new-form constantp constant-value))) + + +(defun loop-constantp (form) + #+Genera (constantp form *loop-macro-environment*) + #-Genera (constantp form)) + + +;;;; LOOP Iteration Optimization + +(defvar *loop-duplicate-code* + nil) + + +(defvar *loop-iteration-flag-variable* + (make-symbol "LOOP-NOT-FIRST-TIME")) + + +(defun loop-code-duplication-threshold (env) + (multiple-value-bind (speed space) (loop-optimization-quantities env) + (+ 40 (* (- speed space) 10)))) + + +(defmacro loop-body (&environment env + prologue + before-loop + main-body + after-loop + epilogue + &aux rbefore rafter flagvar) + (unless (= (length before-loop) (length after-loop)) + (error "LOOP-BODY called with non-synched before- and after-loop lists.")) + ;;All our work is done from these copies, working backwards from the end: + (setq rbefore (reverse before-loop) rafter (reverse after-loop)) + (labels ((psimp (l) + (let ((ans nil)) + (dolist (x l) + (when x + (push x ans) + (when (and (consp x) (member (car x) '(go return return-from))) + (return nil)))) + (nreverse ans))) + (pify (l) (if (null (cdr l)) (car l) `(progn ,@l))) + (makebody () + (let ((form `(tagbody + ;; ANSI CL 6.1.7.2 says that initially clauses are + ;; evaluated in the loop prologue, which precedes + ;; all loop code except for the initial settings + ;; provided by with, for, or as. + ,@(psimp (append (nreverse rbefore) prologue)) + next-loop + ,@(psimp (append main-body (nreconc rafter `((go next-loop))))) + end-loop + ,@(psimp epilogue)))) + (if flagvar `(let ((,flagvar nil)) ,form) form)))) + (when (or *loop-duplicate-code* (not rbefore)) + (return-from loop-body (makebody))) + ;; This outer loop iterates once for each not-first-time flag test generated + ;; plus once more for the forms that don't need a flag test + (do ((threshold (loop-code-duplication-threshold env))) (nil) + (declare (fixnum threshold)) + ;; Go backwards from the ends of before-loop and after-loop merging all the equivalent + ;; forms into the body. + (do () ((or (null rbefore) (not (equal (car rbefore) (car rafter))))) + (push (pop rbefore) main-body) + (pop rafter)) + (unless rbefore (return (makebody))) + ;; The first forms in rbefore & rafter (which are the chronologically + ;; last forms in the list) differ, therefore they cannot be moved + ;; into the main body. If everything that chronologically precedes + ;; them either differs or is equal but is okay to duplicate, we can + ;; just put all of rbefore in the prologue and all of rafter after + ;; the body. Otherwise, there is something that is not okay to + ;; duplicate, so it and everything chronologically after it in + ;; rbefore and rafter must go into the body, with a flag test to + ;; distinguish the first time around the loop from later times. + ;; What chronologically precedes the non-duplicatable form will + ;; be handled the next time around the outer loop. + (do ((bb rbefore (cdr bb)) (aa rafter (cdr aa)) (lastdiff nil) (count 0) (inc nil)) + ((null bb) (return-from loop-body (makebody))) ;Did it. + (cond ((not (equal (car bb) (car aa))) (setq lastdiff bb count 0)) + ((or (not (setq inc (estimate-code-size (car bb) env))) + (> (incf count inc) threshold)) + ;; Ok, we have found a non-duplicatable piece of code. Everything + ;; chronologically after it must be in the central body. + ;; Everything chronologically at and after lastdiff goes into the + ;; central body under a flag test. + (let ((then nil) (else nil)) + (do () (nil) + (push (pop rbefore) else) + (push (pop rafter) then) + (when (eq rbefore (cdr lastdiff)) (return))) + (unless flagvar + (push `(setq ,(setq flagvar *loop-iteration-flag-variable*) t) else)) + (push `(if ,flagvar ,(pify (psimp then)) ,(pify (psimp else))) + main-body)) + ;; Everything chronologically before lastdiff until the non-duplicatable form (car bb) + ;; is the same in rbefore and rafter so just copy it into the body + (do () (nil) + (pop rafter) + (push (pop rbefore) main-body) + (when (eq rbefore (cdr bb)) (return))) + (return))))))) + + + +(defun duplicatable-code-p (expr env) + (if (null expr) 0 + (let ((ans (estimate-code-size expr env))) + (declare (fixnum ans)) + ;;@@@@ Use (DECLARATION-INFORMATION 'OPTIMIZE ENV) here to get an alist of + ;; optimize quantities back to help quantify how much code we are willing to + ;; duplicate. + ans))) + + +(defvar *special-code-sizes* + '((return 0) (progn 0) + (null 1) (not 1) (eq 1) (car 1) (cdr 1) + (when 1) (unless 1) (if 1) + (caar 2) (cadr 2) (cdar 2) (cddr 2) + (caaar 3) (caadr 3) (cadar 3) (caddr 3) (cdaar 3) (cdadr 3) (cddar 3) (cdddr 3) + (caaaar 4) (caaadr 4) (caadar 4) (caaddr 4) + (cadaar 4) (cadadr 4) (caddar 4) (cadddr 4) + (cdaaar 4) (cdaadr 4) (cdadar 4) (cdaddr 4) + (cddaar 4) (cddadr 4) (cdddar 4) (cddddr 4))) + + +(defvar *estimate-code-size-punt* + '(block + do do* dolist + flet + labels lambda let let* locally + macrolet multiple-value-bind + prog prog* + symbol-macrolet + tagbody + unwind-protect + with-open-file)) + + +(defun destructuring-size (x) + (do ((x x (cdr x)) (n 0 (+ (destructuring-size (car x)) n))) + ((atom x) (+ n (if (null x) 0 1))))) + + +(defun estimate-code-size (x env) + (catch 'estimate-code-size + (estimate-code-size-1 x env))) + + +(defun estimate-code-size-1 (x env) + (flet ((list-size (l) + (let ((n 0)) + (declare (fixnum n)) + (dolist (x l n) (incf n (estimate-code-size-1 x env)))))) + ;;@@@@ ???? (declare (function list-size (list) fixnum)) + (cond ((constantp x #+Genera env) 1) + ((symbolp x) (multiple-value-bind (new-form expanded-p) (macroexpand-1 x env) + (if expanded-p (estimate-code-size-1 new-form env) 1))) + ((atom x) 1) ;??? self-evaluating??? + ((symbolp (car x)) + (let ((fn (car x)) (tem nil) (n 0)) + (declare (symbol fn) (fixnum n)) + (macrolet ((f (overhead &optional (args nil args-p)) + `(the fixnum (+ (the fixnum ,overhead) + (the fixnum (list-size ,(if args-p args '(cdr x)))))))) + (cond ((setq tem (get fn 'estimate-code-size)) + (typecase tem + (fixnum (f tem)) + (t (funcall tem x env)))) + ((setq tem (assoc fn *special-code-sizes*)) (f (second tem))) + #+Genera + ((eq fn 'compiler:invisible-references) (list-size (cddr x))) + ((eq fn 'cond) + (dolist (clause (cdr x) n) (incf n (list-size clause)) (incf n))) + ((eq fn 'desetq) + (do ((l (cdr x) (cdr l))) ((null l) n) + (setq n (+ n (destructuring-size (car l)) (estimate-code-size-1 (cadr l) env))))) + ((member fn '(setq psetq)) + (do ((l (cdr x) (cdr l))) ((null l) n) + (setq n (+ n (estimate-code-size-1 (cadr l) env) 1)))) + ((eq fn 'go) 1) + ((eq fn 'function) + ;;This skirts the issue of implementationally-defined lambda macros + ;; by recognizing CL function names and nothing else. + #-cmu 1 + #+cmu (if (ext:valid-function-name-p (cadr x)) + 1 + (throw 'duplicatable-code-p nil))) + ((eq fn 'multiple-value-setq) (f (length (second x)) (cddr x))) + ((eq fn 'return-from) (1+ (estimate-code-size-1 (third x) env))) + ((or (special-operator-p fn) (member fn *estimate-code-size-punt*)) + (throw 'estimate-code-size nil)) + (t (multiple-value-bind (new-form expanded-p) (macroexpand-1 x env) + (if expanded-p + (estimate-code-size-1 new-form env) + (f 3)))))))) + (t (throw 'estimate-code-size nil))))) + + +;;;; Loop Errors + + +(defun loop-context () + (do ((l *loop-source-context* (cdr l)) (new nil (cons (car l) new))) + ((eq l (cdr *loop-source-code*)) (nreverse new)))) + + +(defun loop-error (format-string &rest format-args) + #+(or Genera CLOE) (declare (dbg:error-reporter)) + #+Genera (setq format-args (copy-list format-args)) ;Don't ask. + #+cmu + (kernel:simple-program-error "~?~%Current LOOP context:~{ ~S~}." + format-string format-args (loop-context)) + #-cmu + (error "~?~%Current LOOP context:~{ ~S~}." + format-string format-args (loop-context))) + + +(defun loop-warn (format-string &rest format-args) + (warn "~?~%Current LOOP context:~{ ~S~}." format-string format-args (loop-context))) + + +(defun loop-check-data-type (specified-type required-type + &optional (default-type required-type)) + (if (null specified-type) + default-type + (multiple-value-bind (a b) (subtypep specified-type required-type) + (cond ((not b) + (loop-warn "LOOP couldn't verify that ~S is a subtype of the required type ~S." + specified-type required-type)) + ((not a) + (loop-error "Specified data type ~S is not a subtype of ~S." + specified-type required-type))) + specified-type))) + + +;;;INTERFACE: Traditional, ANSI, Lucid. +(defmacro loop-finish () + "Causes the iteration to terminate \"normally\", the same as implicit +termination by an iteration driving clause, or by use of WHILE or +UNTIL -- the epilogue code (if any) will be run, and any implicitly +collected result will be returned as the value of the LOOP." + '(go end-loop)) + + + +(defun subst-gensyms-for-nil (tree) + (declare (special *ignores*)) + (cond + ((null tree) (car (push (loop-gentemp) *ignores*))) + ((atom tree) tree) + (t (cons (subst-gensyms-for-nil (car tree)) + (subst-gensyms-for-nil (cdr tree)))))) + +(defun loop-build-destructuring-bindings (crocks forms) + (if crocks + (let ((*ignores* ())) + (declare (special *ignores*)) + `((destructuring-bind ,(subst-gensyms-for-nil (car crocks)) + ,(cadr crocks) + (declare (ignore ,@*ignores*)) + ,@(loop-build-destructuring-bindings (cddr crocks) forms)))) + forms)) + +(defun loop-translate (*loop-source-code* *loop-macro-environment* *loop-universe*) + (let ((*loop-original-source-code* *loop-source-code*) + (*loop-source-context* nil) + (*loop-iteration-variables* nil) + (*loop-variables* nil) + (*loop-nodeclare* nil) + (*loop-named-variables* nil) + (*loop-declarations* nil) + (*loop-desetq-crocks* nil) + (*loop-bind-stack* nil) + (*loop-prologue* nil) + (*loop-wrappers* nil) + (*loop-before-loop* nil) + (*loop-body* nil) + (*loop-emitted-body* nil) + (*loop-after-body* nil) + (*loop-epilogue* nil) + (*loop-after-epilogue* nil) + (*loop-final-value-culprit* nil) + (*loop-inside-conditional* nil) + (*loop-when-it-variable* nil) + (*loop-never-stepped-variable* nil) + (*loop-names* nil) + (*loop-collection-cruft* nil)) + (loop-iteration-driver) + (loop-bind-block) + (let ((answer `(loop-body + ,(nreverse *loop-prologue*) + ,(nreverse *loop-before-loop*) + ,(nreverse *loop-body*) + ,(nreverse *loop-after-body*) + ,(nreconc *loop-epilogue* (nreverse *loop-after-epilogue*))))) + (dolist (entry *loop-bind-stack*) + (let ((vars (first entry)) + (dcls (second entry)) + (crocks (third entry)) + (wrappers (fourth entry))) + (dolist (w wrappers) + (setq answer (append w (list answer)))) + (when (or vars dcls crocks) + (let ((forms (list answer))) + ;;(when crocks (push crocks forms)) + (when dcls (push `(declare ,@dcls) forms)) + (setq answer `(,(cond ((not vars) 'locally) + (*loop-destructuring-hooks* (first *loop-destructuring-hooks*)) + (t 'let)) + ,vars + ,@(loop-build-destructuring-bindings crocks forms))))))) + (if *loop-names* + (do () ((null (car *loop-names*)) answer) + (setq answer `(block ,(pop *loop-names*) ,answer))) + `(block nil ,answer))))) + + +(defun loop-iteration-driver () + (do () ((null *loop-source-code*)) + (let ((keyword (car *loop-source-code*)) (tem nil)) + (cond ((not (symbolp keyword)) + (loop-error "~S found where LOOP keyword expected." keyword)) + (t (setq *loop-source-context* *loop-source-code*) + (loop-pop-source) + (cond ((setq tem (loop-lookup-keyword keyword (loop-universe-keywords *loop-universe*))) + ;;It's a "miscellaneous" toplevel LOOP keyword (do, collect, named, etc.) + (apply (symbol-function (first tem)) (rest tem))) + ((setq tem (loop-lookup-keyword keyword (loop-universe-iteration-keywords *loop-universe*))) + (loop-hack-iteration tem)) + ((loop-tmember keyword '(and else)) + ;; Alternative is to ignore it, ie let it go around to the next keyword... + (loop-error "Secondary clause misplaced at top level in LOOP macro: ~S ~S ~S ..." + keyword (car *loop-source-code*) (cadr *loop-source-code*))) + (t (loop-error "~S is an unknown keyword in LOOP macro." keyword)))))))) + + + +(defun loop-pop-source () + (if *loop-source-code* + (pop *loop-source-code*) + (loop-error "LOOP source code ran out when another token was expected."))) + + +(defun loop-get-compound-form () + (let ((form (loop-get-form))) + (unless (consp form) + (loop-error "Compound form expected, but found ~A." form)) + form)) + +(defun loop-get-progn () + (do ((forms (list (loop-get-compound-form)) + (cons (loop-get-compound-form) forms)) + (nextform (car *loop-source-code*) + (car *loop-source-code*))) + ((atom nextform) + (if (null (cdr forms)) (car forms) (cons 'progn (nreverse forms)))))) + + +(defun loop-get-form () + (if *loop-source-code* + (loop-pop-source) + (loop-error "LOOP code ran out where a form was expected."))) + + +(defun loop-construct-return (form) + `(return-from ,(car *loop-names*) ,form)) + + +(defun loop-pseudo-body (form) + (cond ((or *loop-emitted-body* *loop-inside-conditional*) (push form *loop-body*)) + (t (push form *loop-before-loop*) (push form *loop-after-body*)))) + +(defun loop-emit-body (form) + (setq *loop-emitted-body* t) + (loop-pseudo-body form)) + +(defun loop-emit-final-value (&optional (form nil form-supplied-p)) + (when form-supplied-p + (push (loop-construct-return form) *loop-after-epilogue*)) + (when *loop-final-value-culprit* + (loop-warn "LOOP clause is providing a value for the iteration,~@ + however one was already established by a ~S clause." + *loop-final-value-culprit*)) + (setq *loop-final-value-culprit* (car *loop-source-context*))) + + +(defun loop-disallow-conditional (&optional kwd) + #+(or Genera CLOE) (declare (dbg:error-reporter)) + (when *loop-inside-conditional* + (loop-error "~:[This LOOP~;The LOOP ~:*~S~] clause is not permitted inside a conditional." kwd))) + +(defun loop-disallow-anonymous-collectors () + (when (find-if-not 'loop-collector-name *loop-collection-cruft*) + (loop-error "This LOOP clause is not permitted with anonymous collectors."))) + +(defun loop-disallow-aggregate-booleans () + (when (loop-tmember *loop-final-value-culprit* '(always never thereis)) + (loop-error "This anonymous collection LOOP clause is not permitted with aggregate booleans."))) + + + +;;;; Loop Types + + +(defun loop-typed-init (data-type) + (when (and data-type (subtypep data-type 'number)) + (if (or (subtypep data-type 'float) (subtypep data-type '(complex float))) + (coerce 0 data-type) + 0))) + + +(defun loop-optional-type (&optional variable) + ;;No variable specified implies that no destructuring is permissible. + (and *loop-source-code* ;Don't get confused by NILs... + (let ((z (car *loop-source-code*))) + (cond ((loop-tequal z 'of-type) + ;;This is the syntactically unambigous form in that the form of the + ;; type specifier does not matter. Also, it is assumed that the + ;; type specifier is unambiguously, and without need of translation, + ;; a common lisp type specifier or pattern (matching the variable) thereof. + (loop-pop-source) + (loop-pop-source)) + + ((symbolp z) + ;;This is the (sort of) "old" syntax, even though we didn't used to support all of + ;; these type symbols. + (let ((type-spec (or (gethash z (loop-universe-type-symbols *loop-universe*)) + (gethash (symbol-name z) (loop-universe-type-keywords *loop-universe*))))) + (when type-spec + (loop-pop-source) + type-spec))) + (t + ;;This is our sort-of old syntax. But this is only valid for when we are destructuring, + ;; so we will be compulsive (should we really be?) and require that we in fact be + ;; doing variable destructuring here. We must translate the old keyword pattern typespec + ;; into a fully-specified pattern of real type specifiers here. + (if (consp variable) + (unless (consp z) + (loop-error + "~S found where a LOOP keyword, LOOP type keyword, or LOOP type pattern expected." + z)) + (loop-error "~S found where a LOOP keyword or LOOP type keyword expected." z)) + (loop-pop-source) + (labels ((translate (k v) + (cond ((null k) nil) + ((atom k) + (replicate + (or (gethash k (loop-universe-type-symbols *loop-universe*)) + (gethash (symbol-name k) (loop-universe-type-keywords *loop-universe*)) + (loop-error + "Destructuring type pattern ~S contains unrecognized type keyword ~S." + z k)) + v)) + ((atom v) + (loop-error + "Destructuring type pattern ~S doesn't match variable pattern ~S." + z variable)) + (t (cons (translate (car k) (car v)) (translate (cdr k) (cdr v)))))) + (replicate (typ v) + (if (atom v) typ (cons (replicate typ (car v)) (replicate typ (cdr v)))))) + (translate z variable))))))) + + + +;;;; Loop Variables + + +(defun loop-bind-block () + (when (or *loop-variables* *loop-declarations* *loop-wrappers*) + (push (list (nreverse *loop-variables*) *loop-declarations* *loop-desetq-crocks* *loop-wrappers*) + *loop-bind-stack*) + (setq *loop-variables* nil + *loop-declarations* nil + *loop-desetq-crocks* nil + *loop-wrappers* nil))) + +(defun loop-variable-p (name) + (do ((entry *loop-bind-stack* (cdr entry))) (nil) + (cond ((null entry) + (return nil)) + ((assoc name (caar entry) :test #'eq) + (return t))))) + +(defun loop-make-variable (name initialization dtype &optional iteration-variable-p) + (cond ((null name) + (cond ((not (null initialization)) + (push (list (setq name (loop-gentemp 'loop-ignore-)) + initialization) + *loop-variables*) + (push `(ignore ,name) *loop-declarations*)))) + ((atom name) + (cond (iteration-variable-p + (if (member name *loop-iteration-variables*) + (loop-error "Duplicated LOOP iteration variable ~S." name) + (push name *loop-iteration-variables*))) + ((assoc name *loop-variables*) + (loop-error "Duplicated variable ~S in LOOP parallel binding." name))) + (unless (symbolp name) + (loop-error "Bad variable ~S somewhere in LOOP." name)) + (loop-declare-variable name dtype) + ;; We use ASSOC on this list to check for duplications (above), + ;; so don't optimize out this list: + (push (list name (or initialization (loop-typed-init dtype))) + *loop-variables*)) + (initialization + (cond (*loop-destructuring-hooks* + (loop-declare-variable name dtype) + (push (list name initialization) *loop-variables*)) + (t (let ((newvar (loop-gentemp 'loop-destructure-))) + (loop-declare-variable name dtype) + (push (list newvar initialization) *loop-variables*) + ;; *LOOP-DESETQ-CROCKS* gathered in reverse order. + (setq *loop-desetq-crocks* + (list* name newvar *loop-desetq-crocks*)) + #+ignore + (loop-make-variable name nil dtype iteration-variable-p))))) + (t (let ((tcar nil) (tcdr nil)) + (if (atom dtype) (setq tcar (setq tcdr dtype)) + (setq tcar (car dtype) tcdr (cdr dtype))) + (loop-make-variable (car name) nil tcar iteration-variable-p) + (loop-make-variable (cdr name) nil tcdr iteration-variable-p)))) + name) + + +(defun loop-make-iteration-variable (name initialization dtype) + (when (and name (loop-variable-p name)) + (loop-error "Variable ~S has already been used" name)) + (loop-make-variable name initialization dtype t)) + + +(defun loop-declare-variable (name dtype) + (cond ((or (null name) (null dtype) (eq dtype t)) nil) + ((symbolp name) + (unless (or (eq dtype t) (member (the symbol name) *loop-nodeclare*)) + (let ((dtype (let ((init (loop-typed-init dtype))) + (if (typep init dtype) + dtype + `(or (member ,init) ,dtype))))) + (push `(type ,dtype ,name) *loop-declarations*)))) + ((consp name) + (cond ((consp dtype) + (loop-declare-variable (car name) (car dtype)) + (loop-declare-variable (cdr name) (cdr dtype))) + (t (loop-declare-variable (car name) dtype) + (loop-declare-variable (cdr name) dtype)))) + (t (error "Invalid LOOP variable passed in: ~S." name)))) + + +(defun loop-maybe-bind-form (form data-type) + (if (loop-constantp form) + form + (loop-make-variable (loop-gentemp 'loop-bind-) form data-type))) + + + +(defun loop-do-if (for negatep) + (let ((form (loop-get-form)) + (it-p nil) + (first-clause-p t) then else) + (let ((*loop-inside-conditional* t)) + (flet ((get-clause (for) + (do ((body nil)) (nil) + (let ((key (car *loop-source-code*)) (*loop-body* nil) data) + (cond ((not (symbolp key)) + (loop-error + "~S found where keyword expected getting LOOP clause after ~S." + key for)) + (t (setq *loop-source-context* *loop-source-code*) + (loop-pop-source) + (when (and (loop-tequal (car *loop-source-code*) 'it) + first-clause-p) + (setq *loop-source-code* + (cons (or it-p (setq it-p (loop-when-it-variable))) + (cdr *loop-source-code*)))) + (cond ((or (not (setq data (loop-lookup-keyword + key (loop-universe-keywords *loop-universe*)))) + (progn (apply (symbol-function (car data)) (cdr data)) + (null *loop-body*))) + (loop-error + "~S does not introduce a LOOP clause that can follow ~S." + key for)) + (t (setq body (nreconc *loop-body* body))))))) + (setq first-clause-p nil) + (if (loop-tequal (car *loop-source-code*) :and) + (loop-pop-source) + (return (if (cdr body) `(progn ,@(nreverse body)) (car body))))))) + (setq then (get-clause for)) + (setq else (when (loop-tequal (car *loop-source-code*) :else) + (loop-pop-source) + (list (get-clause :else))))) + (when (loop-tequal (car *loop-source-code*) :end) + (loop-pop-source)) + (when it-p + (setq form `(setq ,it-p ,form)))) + (loop-pseudo-body + `(if ,(if negatep `(not ,form) form) + ,then + ,@else)))) + + +(defun loop-do-initially () + (loop-disallow-conditional :initially) + (push (loop-get-progn) *loop-prologue*)) + +(defun loop-do-finally () + (loop-disallow-conditional :finally) + (push (loop-get-progn) *loop-epilogue*)) + +(defun loop-do-do () + (loop-emit-body (loop-get-progn))) + +(defun loop-do-named () + (let ((name (loop-pop-source))) + (unless (symbolp name) + (loop-error "~S is an invalid name for your LOOP." name)) + (when (or *loop-before-loop* *loop-body* *loop-after-epilogue* *loop-inside-conditional*) + (loop-error "The NAMED ~S clause occurs too late." name)) + (when *loop-names* + (loop-error "You may only use one NAMED clause in your loop: NAMED ~S ... NAMED ~S." + (car *loop-names*) name)) + (setq *loop-names* (list name nil)))) + +(defun loop-do-return () + (loop-pseudo-body (loop-construct-return (loop-get-form)))) + + +;;;; Value Accumulation: List + + +(defstruct (loop-collector + (:copier nil) + (:predicate nil)) + name + class + (history nil) + (tempvars nil) + dtype + (data nil)) ;collector-specific data + + +(defun loop-get-collection-info (collector class default-type) + (let ((form (loop-get-form)) + (dtype (and (not (loop-universe-ansi *loop-universe*)) (loop-optional-type))) + (name (when (loop-tequal (car *loop-source-code*) 'into) + (loop-pop-source) + (loop-pop-source)))) + (when (not (symbolp name)) + (loop-error "Value accumulation recipient name, ~S, is not a symbol." name)) + (unless name + (loop-disallow-aggregate-booleans)) + (unless dtype + (setq dtype (or (loop-optional-type) default-type))) + (let ((cruft (find (the symbol name) *loop-collection-cruft* + :key #'loop-collector-name))) + (cond ((not cruft) + (when (and name (loop-variable-p name)) + (loop-error "Variable ~S cannot be used in INTO clause" name)) + (push (setq cruft (make-loop-collector + :name name :class class + :history (list collector) :dtype dtype)) + *loop-collection-cruft*)) + (t (unless (eq (loop-collector-class cruft) class) + (loop-error + "Incompatible kinds of LOOP value accumulation specified for collecting~@ + ~:[as the value of the LOOP~;~:*INTO ~S~]: ~S and ~S." + name (car (loop-collector-history cruft)) collector)) + (unless (equal dtype (loop-collector-dtype cruft)) + (loop-warn + "Unequal datatypes specified in different LOOP value accumulations~@ + into ~S: ~S and ~S." + name dtype (loop-collector-dtype cruft)) + (when (eq (loop-collector-dtype cruft) t) + (setf (loop-collector-dtype cruft) dtype))) + (push collector (loop-collector-history cruft)))) + (values cruft form)))) + + +(defun loop-list-collection (specifically) ;NCONC, LIST, or APPEND + (multiple-value-bind (lc form) (loop-get-collection-info specifically 'list 'list) + (let ((tempvars (loop-collector-tempvars lc))) + (unless tempvars + (setf (loop-collector-tempvars lc) + (setq tempvars (list* (loop-gentemp 'loop-list-head-) + (loop-gentemp 'loop-list-tail-) + (and (loop-collector-name lc) + (list (loop-collector-name lc)))))) + (push `(with-loop-list-collection-head ,tempvars) *loop-wrappers*) + (unless (loop-collector-name lc) + (loop-emit-final-value `(loop-collect-answer ,(car tempvars) ,@(cddr tempvars))))) + (ecase specifically + (list (setq form `(list ,form))) + (nconc nil) + (append (unless (and (consp form) (eq (car form) 'list)) + (setq form `(loop-copylist* ,form))))) + (loop-emit-body `(loop-collect-rplacd ,tempvars ,form))))) + + +;;;; Value Accumulation: max, min, sum, count. + + + +(defun loop-sum-collection (specifically required-type default-type) ;SUM, COUNT + (multiple-value-bind (lc form) + (loop-get-collection-info specifically 'sum default-type) + (loop-check-data-type (loop-collector-dtype lc) required-type) + (let ((tempvars (loop-collector-tempvars lc))) + (unless tempvars + (setf (loop-collector-tempvars lc) + (setq tempvars (list (loop-make-variable + (or (loop-collector-name lc) + (loop-gentemp 'loop-sum-)) + nil (loop-collector-dtype lc))))) + (unless (loop-collector-name lc) + (loop-emit-final-value (car (loop-collector-tempvars lc))))) + (loop-emit-body + (if (eq specifically 'count) + `(when ,form + (setq ,(car tempvars) + ,(hide-variable-reference t (car tempvars) `(1+ ,(car tempvars))))) + `(setq ,(car tempvars) + (+ ,(hide-variable-reference t (car tempvars) (car tempvars)) + ,form))))))) + + + +(defun loop-maxmin-collection (specifically) + (multiple-value-bind (lc form) + (loop-get-collection-info specifically 'maxmin *loop-real-data-type*) + (loop-check-data-type (loop-collector-dtype lc) *loop-real-data-type*) + (let ((data (loop-collector-data lc))) + (unless data + (setf (loop-collector-data lc) + (setq data (make-loop-minimax + (or (loop-collector-name lc) (loop-gentemp 'loop-maxmin-)) + (loop-collector-dtype lc)))) + (unless (loop-collector-name lc) + (loop-emit-final-value (loop-minimax-answer-variable data)))) + (loop-note-minimax-operation specifically data) + (push `(with-minimax-value ,data) *loop-wrappers*) + (loop-emit-body `(loop-accumulate-minimax-value ,data ,specifically ,form)) + ))) + + +;;;; Value Accumulation: Aggregate Booleans + +;;;ALWAYS and NEVER. +;;; Under ANSI these are not permitted to appear under conditionalization. +(defun loop-do-always (restrictive negate) + (let ((form (loop-get-form))) + (when restrictive (loop-disallow-conditional)) + (loop-disallow-anonymous-collectors) + (loop-emit-body `(,(if negate 'when 'unless) ,form + ,(loop-construct-return nil))) + (loop-emit-final-value t))) + + + +;;;THERIS. +;;; Under ANSI this is not permitted to appear under conditionalization. +(defun loop-do-thereis (restrictive) + (when restrictive (loop-disallow-conditional)) + (loop-disallow-anonymous-collectors) + (loop-emit-final-value) + (loop-emit-body `(when (setq ,(loop-when-it-variable) ,(loop-get-form)) + ,(loop-construct-return *loop-when-it-variable*)))) + + +(defun loop-do-while (negate kwd &aux (form (loop-get-form))) + (loop-disallow-conditional kwd) + (loop-pseudo-body `(,(if negate 'when 'unless) ,form (go end-loop)))) + + +(defun loop-do-with () + (loop-disallow-conditional :with) + (do ((var) (val) (dtype)) (nil) + (setq var (loop-pop-source) + dtype (loop-optional-type var) + val (cond ((loop-tequal (car *loop-source-code*) :=) + (loop-pop-source) + (loop-get-form)) + (t nil))) + (when (and var (loop-variable-p var)) + (loop-error "Variable ~S has already been used" var)) + (loop-make-variable var val dtype) + (if (loop-tequal (car *loop-source-code*) :and) + (loop-pop-source) + (return (loop-bind-block))))) + + +;;;; The iteration driver + +(defun loop-hack-iteration (entry) + (flet ((make-endtest (list-of-forms) + (cond ((null list-of-forms) nil) + ((member t list-of-forms) '(go end-loop)) + (t `(when ,(if (null (cdr (setq list-of-forms (nreverse list-of-forms)))) + (car list-of-forms) + (cons 'or list-of-forms)) + (go end-loop)))))) + (do ((pre-step-tests nil) + (steps nil) + (post-step-tests nil) + (pseudo-steps nil) + (pre-loop-pre-step-tests nil) + (pre-loop-steps nil) + (pre-loop-post-step-tests nil) + (pre-loop-pseudo-steps nil) + (tem) (data)) + (nil) + ;; Note we collect endtests in reverse order, but steps in correct + ;; order. MAKE-ENDTEST does the nreverse for us. + (setq tem (setq data (apply (symbol-function (first entry)) (rest entry)))) + (and (car tem) (push (car tem) pre-step-tests)) + (setq steps (nconc steps (loop-copylist* (car (setq tem (cdr tem)))))) + (and (car (setq tem (cdr tem))) (push (car tem) post-step-tests)) + (setq pseudo-steps (nconc pseudo-steps (loop-copylist* (car (setq tem (cdr tem)))))) + (setq tem (cdr tem)) + (when *loop-emitted-body* + (loop-error "Iteration in LOOP follows body code.")) + (unless tem (setq tem data)) + (when (car tem) (push (car tem) pre-loop-pre-step-tests)) + (setq pre-loop-steps (nconc pre-loop-steps (loop-copylist* (car (setq tem (cdr tem)))))) + (when (car (setq tem (cdr tem))) (push (car tem) pre-loop-post-step-tests)) + (setq pre-loop-pseudo-steps (nconc pre-loop-pseudo-steps (loop-copylist* (cadr tem)))) + (unless (loop-tequal (car *loop-source-code*) :and) + (setq *loop-before-loop* (list* (loop-make-desetq pre-loop-pseudo-steps) + (make-endtest pre-loop-post-step-tests) + (loop-make-psetq pre-loop-steps) + (make-endtest pre-loop-pre-step-tests) + *loop-before-loop*) + *loop-after-body* (list* (loop-make-desetq pseudo-steps) + (make-endtest post-step-tests) + (loop-make-psetq steps) + (make-endtest pre-step-tests) + *loop-after-body*)) + (loop-bind-block) + (return nil)) + (loop-pop-source) ; flush the "AND" + (when (and (not (loop-universe-implicit-for-required *loop-universe*)) + (setq tem (loop-lookup-keyword + (car *loop-source-code*) + (loop-universe-iteration-keywords *loop-universe*)))) + ;;Latest ANSI clarification is that the FOR/AS after the AND must NOT be supplied. + (loop-pop-source) + (setq entry tem))))) + + +;;;; Main Iteration Drivers + + +;FOR variable keyword ..args.. +(defun loop-do-for () + (let* ((var (or (loop-pop-source) (loop-gentemp 'loop-do-for-anon-))) + (data-type (loop-optional-type var)) + (keyword (loop-pop-source)) + (first-arg nil) + (tem nil)) + (setq first-arg (loop-get-form)) + (unless (and (symbolp keyword) + (setq tem (loop-lookup-keyword + keyword + (loop-universe-for-keywords *loop-universe*)))) + (loop-error "~S is an unknown keyword in FOR or AS clause in LOOP." keyword)) + (apply (car tem) var first-arg data-type (cdr tem)))) + +(defun loop-do-repeat () + (loop-disallow-conditional :repeat) + (let ((form (loop-get-form)) + (type 'real)) + (let ((var (loop-make-variable (loop-gentemp) form type))) + (push `(when (minusp (decf ,var)) (go end-loop)) *loop-before-loop*) + (push `(when (minusp (decf ,var)) (go end-loop)) *loop-after-body*) + ;; FIXME: What should + ;; (loop count t into a + ;; repeat 3 + ;; count t into b + ;; finally (return (list a b))) + ;; return: (3 3) or (4 3)? PUSHes above are for the former + ;; variant, L-P-B below for the latter. + #+nil (loop-pseudo-body `(when (minusp (decf ,var)) (go end-loop)))))) + +(defun loop-when-it-variable () + (or *loop-when-it-variable* + (setq *loop-when-it-variable* + (loop-make-variable (loop-gentemp 'loop-it-) nil nil)))) + + +;;;; Various FOR/AS Subdispatches + + +;;;ANSI "FOR x = y [THEN z]" is sort of like the old Genera one when the THEN +;;; is omitted (other than being more stringent in its placement), and like +;;; the old "FOR x FIRST y THEN z" when the THEN is present. I.e., the first +;;; initialization occurs in the loop body (first-step), not in the variable binding +;;; phase. +(defun loop-ansi-for-equals (var val data-type) + (loop-make-iteration-variable var nil data-type) + (cond ((loop-tequal (car *loop-source-code*) :then) + ;;Then we are the same as "FOR x FIRST y THEN z". + (loop-pop-source) + `(() (,var ,(loop-get-form)) () () + () (,var ,val) () ())) + (t ;;We are the same as "FOR x = y". + ;; Let me document here what this is returning. Look at + ;; loop-hack-iteration for more info. But anyway, we return a list of + ;; 8 items, in this order: PRE-STEP-TESTS, STEPS, POST-STEP-TESTS, + ;; PSEUDO-STEPS, PRE-LOOP-PRE-STEP-TESTS, PRE-LOOP-STEPS, + ;; PRE-LOOP-POST-STEP-TESTS, PRE-LOOP-PSEUDO-STEPS. (We should add + ;; something to make it easier to figure out what these args are!) + ;; + ;; For a "FOR x = y" clause without the THEN, we want the STEPS item to + ;; step the variable VAR with the value VAL. This gets placed in the + ;; body of the loop. The original code just did that. It seems that + ;; the STEPS form is placed in *loop-before-loop* and in + ;; *loop-after-loop*. Loop optimization would then see the same form + ;; in both, and move them into the beginning of body. This is ok, + ;; except that if there are :initially forms that were placed into the + ;; loop prologue, the :initially forms might refer to incorrectly + ;; initialized variables, because the optimizer moved STEPS from from + ;; *loop-before-loop* into the body. + ;; + ;; To solve this, we add a PRE-LOOP-PSEUDO-STEP form that is identical + ;; to the STEPS form. This gets placed in *loop-before-loop*. But + ;; this won't match any *loop-after-loop* form, so it won't get moved, + ;; and we maintain the proper sequencing such that the + ;; PRE-LOOP-PSEUDO-STEP form is in *loop-before-loop*, before any + ;; :initially clauses that might refer to this. So all is well. Whew. + ;; + ;; I hope this doesn't break anything else. + `(() (,var ,val) () () + () () () (,var ,val)) + ))) + + +(defun loop-for-across (var val data-type) + (loop-make-iteration-variable var nil data-type) + (let ((vector-var (loop-gentemp 'loop-across-vector-)) + (index-var (loop-gentemp 'loop-across-index-))) + (multiple-value-bind (vector-form constantp vector-value) + (loop-constant-fold-if-possible val 'vector) + (loop-make-variable + vector-var vector-form + (if (and (consp vector-form) (eq (car vector-form) 'the)) + (cadr vector-form) + 'vector)) + #+Genera (push `(system:array-register ,vector-var) *loop-declarations*) + (loop-make-variable index-var 0 'fixnum) + (let* ((length 0) + (length-form (cond ((not constantp) + (let ((v (loop-gentemp 'loop-across-limit-))) + ;; This used to just push the length + ;; computation into the prologue code. I + ;; (rtoy) don't think that's right, + ;; especially since the prologue is supposed + ;; to happen AFTER other initializations. + ;; So, this puts the computation in + ;; *loop-before-body*. We need a matching + ;; entry for *loop-after-body*, so stuff a + ;; NIL there. + (push `(setq ,v (length ,vector-var)) *loop-before-loop*) + (push nil *loop-after-body*) + (loop-make-variable v 0 'fixnum))) + (t (setq length (length vector-value))))) + (first-test `(>= ,index-var ,length-form)) + (other-test first-test) + (step `(,var (aref ,vector-var ,index-var))) + (pstep `(,index-var (1+ ,index-var)))) + (declare (fixnum length)) + (when constantp + (setq first-test (= length 0)) + (when (<= length 1) + (setq other-test t))) + `(,other-test ,step () ,pstep + ,@(and (not (eq first-test other-test)) `(,first-test ,step () ,pstep))))))) + + + +;;;; List Iteration + + +(defun loop-list-step (listvar) + ;;We are not equipped to analyze whether 'FOO is the same as #'FOO here in any + ;; sensible fashion, so let's give an obnoxious warning whenever 'FOO is used + ;; as the stepping function. + ;;While a Discerning Compiler may deal intelligently with (funcall 'foo ...), not + ;; recognizing FOO may defeat some LOOP optimizations. + (let ((stepper (cond ((loop-tequal (car *loop-source-code*) :by) + (loop-pop-source) + (loop-get-form)) + (t '(function cdr))))) + (cond ((and (consp stepper) (eq (car stepper) 'quote)) + (loop-warn "Use of QUOTE around stepping function in LOOP will be left verbatim.") + (values `(funcall ,stepper ,listvar) nil)) + ((and (consp stepper) (eq (car stepper) 'function)) + (values (list (cadr stepper) listvar) (cadr stepper))) + (t (values `(funcall ,(loop-make-variable (loop-gentemp 'loop-fn-) stepper 'function) + ,listvar) + nil))))) + + +(defun loop-for-on (var val data-type) + (multiple-value-bind (list constantp list-value) (loop-constant-fold-if-possible val) + (let ((listvar var)) + (cond ((and var (symbolp var)) (loop-make-iteration-variable var list data-type)) + (t (loop-make-variable (setq listvar (loop-gentemp)) list 't) + (loop-make-iteration-variable var nil data-type))) + (multiple-value-bind (list-step step-function) (loop-list-step listvar) + (declare #+(and (not LOOP-Prefer-POP) (not CLOE)) (ignore step-function)) + ;;@@@@ The CLOE problem above has to do with bug in macroexpansion of multiple-value-bind. + (let* ((first-endtest + (hide-variable-reference + (eq var listvar) + listvar + ;; the following should use `atom' instead of `endp', per + ;; [bug2428] + `(atom ,listvar))) + (other-endtest first-endtest)) + (when (and constantp (listp list-value)) + (setq first-endtest (null list-value))) + (cond ((eq var listvar) + ;;Contour of the loop is different because we use the user's variable... + `(() (,listvar ,(hide-variable-reference t listvar list-step)) ,other-endtest + () () () ,first-endtest ())) + #+LOOP-Prefer-POP + ((and step-function + (let ((n (cdr (assoc step-function '((cdr . 1) (cddr . 2) + (cdddr . 3) (cddddr . 4)))))) + (and n (do ((l var (cdr l)) (i 0 (1+ i))) + ((atom l) (and (null l) (= i n))) + (declare (fixnum i)))))) + (let ((step (mapcan #'(lambda (x) (list x `(pop ,listvar))) var))) + `(,other-endtest () () ,step ,first-endtest () () ,step))) + (t (let ((step `(,var ,listvar)) (pseudo `(,listvar ,list-step))) + `(,other-endtest ,step () ,pseudo + ,@(and (not (eq first-endtest other-endtest)) + `(,first-endtest ,step () ,pseudo))))))))))) + + +(defun loop-for-in (var val data-type) + (multiple-value-bind (list constantp list-value) (loop-constant-fold-if-possible val) + (let ((listvar (loop-gentemp 'loop-list-))) + (loop-make-iteration-variable var nil data-type) + (loop-make-variable listvar list 'list) + (multiple-value-bind (list-step step-function) (loop-list-step listvar) + #-LOOP-Prefer-POP (declare (ignore step-function)) + (let* ((first-endtest `(endp ,listvar)) + (other-endtest first-endtest) + (step `(,var (car ,listvar))) + (pseudo-step `(,listvar ,list-step))) + (when (and constantp (listp list-value)) + (setq first-endtest (null list-value))) + #+LOOP-Prefer-POP (when (eq step-function 'cdr) + (setq step `(,var (pop ,listvar)) pseudo-step nil)) + `(,other-endtest ,step () ,pseudo-step + ,@(and (not (eq first-endtest other-endtest)) + `(,first-endtest ,step () ,pseudo-step)))))))) + + +;;;; Iteration Paths + + +(defstruct (loop-path + (:copier nil) + (:predicate nil)) + names + preposition-groups + inclusive-permitted + function + user-data) + + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun add-loop-path (names function universe &key preposition-groups inclusive-permitted user-data) + (unless (listp names) (setq names (list names))) + ;; Can't do this due to CLOS bootstrapping problems. + #-(or Genera (and CLOE Source-Bootstrap)) (check-type universe loop-universe) + (let ((ht (loop-universe-path-keywords universe)) + (lp (make-loop-path + :names (mapcar #'symbol-name names) + :function function + :user-data user-data + :preposition-groups (mapcar #'(lambda (x) (if (listp x) x (list x))) preposition-groups) + :inclusive-permitted inclusive-permitted))) + (dolist (name names) (setf (gethash (symbol-name name) ht) lp)) + lp))) + + +;;; Note: path functions are allowed to use loop-make-variable, hack +;;; the prologue, etc. +(defun loop-for-being (var val data-type) + ;; FOR var BEING each/the pathname prep-phrases using-stuff... + ;; each/the = EACH or THE. Not clear if it is optional, so I guess we'll warn. + (let ((path nil) + (data nil) + (inclusive nil) + (stuff nil) + (initial-prepositions nil)) + (cond ((loop-tmember val '(:each :the)) (setq path (loop-pop-source))) + ((loop-tequal (car *loop-source-code*) :and) + (loop-pop-source) + (setq inclusive t) + (unless (loop-tmember (car *loop-source-code*) '(:its :each :his :her)) + (loop-error "~S found where ITS or EACH expected in LOOP iteration path syntax." + (car *loop-source-code*))) + (loop-pop-source) + (setq path (loop-pop-source)) + (setq initial-prepositions `((:in ,val)))) + (t (loop-error "Unrecognizable LOOP iteration path syntax. Missing EACH or THE?"))) + (cond ((not (symbolp path)) + (loop-error "~S found where a LOOP iteration path name was expected." path)) + ((not (setq data (loop-lookup-keyword path (loop-universe-path-keywords *loop-universe*)))) + (loop-error "~S is not the name of a LOOP iteration path." path)) + ((and inclusive (not (loop-path-inclusive-permitted data))) + (loop-error "\"Inclusive\" iteration is not possible with the ~S LOOP iteration path." path))) + (let ((fun (loop-path-function data)) + (preps (nconc initial-prepositions + (loop-collect-prepositional-phrases (loop-path-preposition-groups data) t))) + (user-data (loop-path-user-data data))) + (when (symbolp fun) (setq fun (symbol-function fun))) + (setq stuff (if inclusive + (apply fun var data-type preps :inclusive t user-data) + (apply fun var data-type preps user-data)))) + (when *loop-named-variables* + (loop-error "Unused USING variables: ~S." *loop-named-variables*)) + ;; STUFF is now (bindings prologue-forms . stuff-to-pass-back). Protect the system from the user + ;; and the user from himself. + (unless (member (length stuff) '(6 10)) + (loop-error "Value passed back by LOOP iteration path function for path ~S has invalid length." + path)) + (do ((l (car stuff) (cdr l)) (x)) ((null l)) + (if (atom (setq x (car l))) + (loop-make-iteration-variable x nil nil) + (loop-make-iteration-variable (car x) (cadr x) (caddr x)))) + (setq *loop-prologue* (nconc (reverse (cadr stuff)) *loop-prologue*)) + (cddr stuff))) + + + +;;;INTERFACE: Lucid, exported. +;;; i.e., this is part of our extended ansi-loop interface. +(defun named-variable (name) + (let ((tem (loop-tassoc name *loop-named-variables*))) + (declare (list tem)) + (cond ((null tem) (values (loop-gentemp) nil)) + (t (setq *loop-named-variables* (delete tem *loop-named-variables*)) + (values (cdr tem) t))))) + + +(defun loop-collect-prepositional-phrases (preposition-groups &optional USING-allowed initial-phrases) + (flet ((in-group-p (x group) (car (loop-tmember x group)))) + (do ((token nil) + (prepositional-phrases initial-phrases) + (this-group nil nil) + (this-prep nil nil) + (disallowed-prepositions + (mapcan #'(lambda (x) + (loop-copylist* + (find (car x) preposition-groups :test #'in-group-p))) + initial-phrases)) + (used-prepositions (mapcar #'car initial-phrases))) + ((null *loop-source-code*) (nreverse prepositional-phrases)) + (declare (symbol this-prep)) + (setq token (car *loop-source-code*)) + (dolist (group preposition-groups) + (when (setq this-prep (in-group-p token group)) + (return (setq this-group group)))) + (cond (this-group + (when (member this-prep disallowed-prepositions) + (loop-error + (if (member this-prep used-prepositions) + "A ~S prepositional phrase occurs multiply for some LOOP clause." + "Preposition ~S used when some other preposition has subsumed it.") + token)) + (setq used-prepositions (if (listp this-group) + (append this-group used-prepositions) + (cons this-group used-prepositions))) + (loop-pop-source) + (push (list this-prep (loop-get-form)) prepositional-phrases)) + ((and USING-allowed (loop-tequal token 'using)) + (loop-pop-source) + (do ((z (loop-pop-source) (loop-pop-source)) (tem)) (nil) + (when (cadr z) + (if (setq tem (loop-tassoc (car z) *loop-named-variables*)) + (loop-error + "The variable substitution for ~S occurs twice in a USING phrase,~@ + with ~S and ~S." + (car z) (cadr z) (cadr tem)) + (push (cons (car z) (cadr z)) *loop-named-variables*))) + (when (or (null *loop-source-code*) (symbolp (car *loop-source-code*))) + (return nil)))) + (t (return (nreverse prepositional-phrases))))))) + + +;;;; Master Sequencer Function + + +(defun loop-sequencer (indexv indexv-type indexv-user-specified-p + variable variable-type + sequence-variable sequence-type + step-hack default-top + prep-phrases) + (let ((endform nil) ;Form (constant or variable) with limit value. + (sequencep nil) ;T if sequence arg has been provided. + (testfn nil) ;endtest function + (test nil) ;endtest form. + (stepby (1+ (or (loop-typed-init indexv-type) 0))) ;Our increment. + (stepby-constantp t) + (step nil) ;step form. + (dir nil) ;Direction of stepping: NIL, :UP, :DOWN. + (inclusive-iteration nil) ;T if include last index. + (start-given nil) ;T when prep phrase has specified start + (start-value nil) + (start-constantp nil) + (limit-given nil) ;T when prep phrase has specified end + (limit-constantp nil) + (limit-value nil) + ) + (when variable (loop-make-iteration-variable variable nil variable-type)) + (do ((l prep-phrases (cdr l)) (prep) (form) (odir)) ((null l)) + (setq prep (caar l) form (cadar l)) + (case prep + ((:of :in) + (setq sequencep t) + (loop-make-variable sequence-variable form sequence-type)) + ((:from :downfrom :upfrom) + (setq start-given t) + (cond ((eq prep :downfrom) (setq dir ':down)) + ((eq prep :upfrom) (setq dir ':up))) + (multiple-value-setq (form start-constantp start-value) + (loop-constant-fold-if-possible form indexv-type)) + (loop-make-iteration-variable indexv form indexv-type)) + ((:upto :to :downto :above :below) + (cond ((loop-tequal prep :upto) (setq inclusive-iteration (setq dir ':up))) + ((loop-tequal prep :to) (setq inclusive-iteration t)) + ((loop-tequal prep :downto) (setq inclusive-iteration (setq dir ':down))) + ((loop-tequal prep :above) (setq dir ':down)) + ((loop-tequal prep :below) (setq dir ':up))) + (setq limit-given t) + (multiple-value-setq (form limit-constantp limit-value) + (loop-constant-fold-if-possible form indexv-type)) + (setq endform (if limit-constantp + `',limit-value + (loop-make-variable + (loop-gentemp 'loop-limit-) form indexv-type)))) + (:by + (multiple-value-setq (form stepby-constantp stepby) + (loop-constant-fold-if-possible form indexv-type)) + (unless stepby-constantp + (loop-make-variable (setq stepby (loop-gentemp 'loop-step-by-)) form indexv-type))) + (t (loop-error + "~S invalid preposition in sequencing or sequence path.~@ + Invalid prepositions specified in iteration path descriptor or something?" + prep))) + (when (and odir dir (not (eq dir odir))) + (loop-error "Conflicting stepping directions in LOOP sequencing path")) + (setq odir dir)) + (when (and sequence-variable (not sequencep)) + (loop-error "Missing OF or IN phrase in sequence path")) + ;; Now fill in the defaults. + (unless start-given + (loop-make-iteration-variable + indexv + (setq start-constantp t start-value (or (loop-typed-init indexv-type) 0)) + indexv-type)) + (cond ((member dir '(nil :up)) + (when (or limit-given default-top) + (unless limit-given + (loop-make-variable (setq endform (loop-gentemp 'loop-seq-limit-)) + nil indexv-type) + (push `(setq ,endform ,default-top) *loop-prologue*)) + (setq testfn (if inclusive-iteration '> '>=))) + (setq step (if (eql stepby 1) `(1+ ,indexv) `(+ ,indexv ,stepby)))) + (t (unless start-given + (unless default-top + (loop-error "Don't know where to start stepping.")) + (push `(setq ,indexv (1- ,default-top)) *loop-prologue*)) + (when (and default-top (not endform)) + (setq endform (loop-typed-init indexv-type) inclusive-iteration t)) + (when endform (setq testfn (if inclusive-iteration '< '<=))) + (setq step (if (eql stepby 1) `(1- ,indexv) `(- ,indexv ,stepby))))) + (when testfn (setq test (hide-variable-reference t indexv `(,testfn ,indexv ,endform)))) + (when step-hack + (setq step-hack `(,variable ,(hide-variable-reference indexv-user-specified-p indexv step-hack)))) + (let ((first-test test) (remaining-tests test)) + (when (and stepby-constantp start-constantp limit-constantp) + (when (setq first-test (funcall (symbol-function testfn) start-value limit-value)) + (setq remaining-tests t))) + `(() (,indexv ,(hide-variable-reference t indexv step)) ,remaining-tests ,step-hack + () () ,first-test ,step-hack)))) + + +;;;; Interfaces to the Master Sequencer + + + +(defun loop-for-arithmetic (var val data-type kwd) + (loop-sequencer + var (loop-check-data-type data-type 'number) t + nil nil nil nil nil nil + (loop-collect-prepositional-phrases + '((:from :upfrom :downfrom) (:to :upto :downto :above :below) (:by)) + nil (list (list kwd val))))) + + +(defun loop-sequence-elements-path (variable data-type prep-phrases + &key fetch-function size-function sequence-type element-type) + (multiple-value-bind (indexv indexv-user-specified-p) (named-variable 'index) + (let ((sequencev (named-variable 'sequence))) + #+Genera (when (and sequencev + (symbolp sequencev) + sequence-type + (subtypep sequence-type 'vector) + (not (member (the symbol sequencev) *loop-nodeclare*))) + (push `(sys:array-register ,sequencev) *loop-declarations*)) + (list* nil nil ; dummy bindings and prologue + (loop-sequencer + indexv 'fixnum indexv-user-specified-p + variable (or data-type element-type) + sequencev sequence-type + `(,fetch-function ,sequencev ,indexv) `(,size-function ,sequencev) + prep-phrases))))) + + +;;;; Builtin LOOP Iteration Paths + + +#|| +(loop for v being the hash-values of ht do (print v)) +(loop for k being the hash-keys of ht do (print k)) +(loop for v being the hash-values of ht using (hash-key k) do (print (list k v))) +(loop for k being the hash-keys of ht using (hash-value v) do (print (list k v))) +||# + +(defun loop-hash-table-iteration-path (variable data-type prep-phrases &key which) + (check-type which (member hash-key hash-value)) + (cond ((or (cdr prep-phrases) (not (member (caar prep-phrases) '(:in :of)))) + (loop-error "Too many prepositions!")) + ((null prep-phrases) (loop-error "Missing OF or IN in ~S iteration path."))) + (let ((ht-var (loop-gentemp 'loop-hashtab-)) + (next-fn (loop-gentemp 'loop-hashtab-next-)) + (dummy-predicate-var nil) + (post-steps nil)) + (multiple-value-bind (other-var other-p) + (named-variable (if (eq which 'hash-key) 'hash-value 'hash-key)) + ;;@@@@ named-variable returns a second value of T if the name was actually + ;; specified, so clever code can throw away the gensym'ed up variable if + ;; it isn't really needed. + ;;The following is for those implementations in which we cannot put dummy NILs + ;; into multiple-value-setq variable lists. + #-Genera (setq other-p t + dummy-predicate-var (loop-when-it-variable)) + (let* ((key-var nil) + (val-var nil) + (temp-val-var (loop-gentemp 'loop-hash-val-temp-)) + (temp-key-var (loop-gentemp 'loop-hash-key-temp-)) + (temp-predicate-var (loop-gentemp 'loop-hash-predicate-var-)) + (variable (or variable (loop-gentemp))) + (bindings `((,variable nil ,data-type) + (,ht-var ,(cadar prep-phrases)) + ,@(and other-p other-var `((,other-var nil)))))) + (if (eq which 'hash-key) + (setq key-var variable val-var (and other-p other-var)) + (setq key-var (and other-p other-var) val-var variable)) + (push `(with-hash-table-iterator (,next-fn ,ht-var)) *loop-wrappers*) + (when (consp key-var) + (setq post-steps `(,key-var ,(setq key-var (loop-gentemp 'loop-hash-key-temp-)) + ,@post-steps)) + (push `(,key-var nil) bindings)) + (when (consp val-var) + (setq post-steps `(,val-var ,(setq val-var (loop-gentemp 'loop-hash-val-temp-)) + ,@post-steps)) + (push `(,val-var nil) bindings)) + `(,bindings ;bindings + () ;prologue + () ;pre-test + () ;parallel steps + (not + (multiple-value-bind (,temp-predicate-var ,temp-key-var ,temp-val-var) + (,next-fn) + ;; We use M-V-BIND instead of M-V-SETQ because we only + ;; want to assign values to the key and val vars when we + ;; are in the hash table. When we reach the end, + ;; TEMP-PREDICATE-VAR is NIL, and so are temp-key-var and + ;; temp-val-var. This might break any type declarations + ;; on the key and val vars. + (when ,temp-predicate-var + (setq ,val-var ,temp-val-var) + (setq ,key-var ,temp-key-var)) + (setq ,dummy-predicate-var ,temp-predicate-var) + )) ;post-test + ,post-steps))))) + + +(defun loop-package-symbols-iteration-path (variable data-type prep-phrases &key symbol-types) + (cond ((and prep-phrases (cdr prep-phrases)) + (loop-error "Too many prepositions!")) + ((and prep-phrases (not (member (caar prep-phrases) '(:in :of)))) + (loop-error "Unknow preposition ~S" (caar prep-phrases)))) + (unless (symbolp variable) + (loop-error "Destructuring is not valid for package symbol iteration.")) + (let ((pkg-var (loop-gentemp 'loop-pkgsym-)) + (next-fn (loop-gentemp 'loop-pkgsym-next-)) + (variable (or variable (loop-gentemp))) + (pkg (or (cadar prep-phrases) '*package*))) + (push `(with-package-iterator (,next-fn ,pkg-var ,@symbol-types)) *loop-wrappers*) + `(((,variable nil ,data-type) (,pkg-var ,pkg)) + () + () + () + (not (multiple-value-setq (,(progn + ;;@@@@ If an implementation can get away without actually + ;; using a variable here, so much the better. + #+Genera NIL + #-Genera (loop-when-it-variable)) + ,variable) + (,next-fn))) + ()))) + +;;;; ANSI Loop + +(eval-when (:compile-toplevel :load-toplevel :execute) + + (defun make-ansi-loop-universe (extended-p) + (let ((w (make-standard-loop-universe + :keywords `((named (loop-do-named)) + (initially (loop-do-initially)) + (finally (loop-do-finally)) + (do (loop-do-do)) + (doing (loop-do-do)) + (return (loop-do-return)) + (collect (loop-list-collection list)) + (collecting (loop-list-collection list)) + (append (loop-list-collection append)) + (appending (loop-list-collection append)) + (nconc (loop-list-collection nconc)) + (nconcing (loop-list-collection nconc)) + (count (loop-sum-collection count ,*loop-real-data-type* fixnum)) + (counting (loop-sum-collection count ,*loop-real-data-type* fixnum)) + (sum (loop-sum-collection sum number number)) + (summing (loop-sum-collection sum number number)) + (maximize (loop-maxmin-collection max)) + (minimize (loop-maxmin-collection min)) + (maximizing (loop-maxmin-collection max)) + (minimizing (loop-maxmin-collection min)) + (always (loop-do-always t nil)) ; Normal, do always + (never (loop-do-always t t)) ; Negate the test on always. + (thereis (loop-do-thereis t)) + (while (loop-do-while nil :while)) ; Normal, do while + (until (loop-do-while t :until)) ; Negate the test on while + (when (loop-do-if when nil)) ; Normal, do when + (if (loop-do-if if nil)) ; synonymous + (unless (loop-do-if unless t)) ; Negate the test on when + (with (loop-do-with)) + (repeat (loop-do-repeat))) + :for-keywords '((= (loop-ansi-for-equals)) + (across (loop-for-across)) + (in (loop-for-in)) + (on (loop-for-on)) + (from (loop-for-arithmetic :from)) + (downfrom (loop-for-arithmetic :downfrom)) + (upfrom (loop-for-arithmetic :upfrom)) + (below (loop-for-arithmetic :below)) + (above (loop-for-arithmetic :above)) + (to (loop-for-arithmetic :to)) + (upto (loop-for-arithmetic :upto)) + (downto (loop-for-arithmetic :downto)) + (by (loop-for-arithmetic :by)) + (being (loop-for-being))) + :iteration-keywords '((for (loop-do-for)) + (as (loop-do-for))) + :type-symbols '(array atom bignum bit bit-vector character compiled-function + complex cons double-float fixnum float + function hash-table integer keyword list long-float + nil null number package pathname random-state + ratio rational readtable sequence short-float + simple-array simple-bit-vector simple-string + simple-vector single-float standard-char + stream string base-char + symbol t vector) + :type-keywords nil + :ansi (if extended-p :extended t)))) + (add-loop-path '(hash-key hash-keys) 'loop-hash-table-iteration-path w + :preposition-groups '((:of :in)) + :inclusive-permitted nil + :user-data '(:which hash-key)) + (add-loop-path '(hash-value hash-values) 'loop-hash-table-iteration-path w + :preposition-groups '((:of :in)) + :inclusive-permitted nil + :user-data '(:which hash-value)) + (add-loop-path '(symbol symbols) 'loop-package-symbols-iteration-path w + :preposition-groups '((:of :in)) + :inclusive-permitted nil + :user-data '(:symbol-types (:internal :external :inherited))) + (add-loop-path '(external-symbol external-symbols) 'loop-package-symbols-iteration-path w + :preposition-groups '((:of :in)) + :inclusive-permitted nil + :user-data '(:symbol-types (:external))) + (add-loop-path '(present-symbol present-symbols) 'loop-package-symbols-iteration-path w + :preposition-groups '((:of :in)) + :inclusive-permitted nil + :user-data '(:symbol-types (:internal :external))) + w)) + + + (defparameter *loop-ansi-universe* + (make-ansi-loop-universe nil)) + + (defun loop-standard-expansion (keywords-and-forms environment universe) + (if (and keywords-and-forms (symbolp (car keywords-and-forms))) + (loop-translate keywords-and-forms environment universe) + (let ((tag (gensym))) + `(block nil (tagbody ,tag (progn ,@keywords-and-forms) (go ,tag)))))) + + ) ;; eval-when + + +;;;INTERFACE: ANSI +(defmacro loop (&environment env &rest keywords-and-forms) + #+Genera (declare (compiler:do-not-record-macroexpansions) + (zwei:indentation . zwei:indent-loop)) + (loop-standard-expansion keywords-and-forms env *loop-ansi-universe*)) + +#+allegro +(defun excl::complex-loop-expander (body env) + (loop-standard-expansion body env *loop-ansi-universe*)) + +;; Replace the CL::LOOP macro with this macro for use with CLSQL +;; LOOP extensions +#+clisp +(eval-when (:compile-toplevel :load-toplevel :execute) + (shadowing-import '(loop loop-finish) (find-package "COMMON-LISP")) + (setf (ext:package-lock (find-package "COMMON-LISP")) t)) + diff --git a/sql/base-classes.lisp b/sql/base-classes.lisp new file mode 100644 index 0000000..344e11c --- /dev/null +++ b/sql/base-classes.lisp @@ -0,0 +1,57 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: base-classes.lisp +;;;; Purpose: Base classes for high-level SQL interface +;;;; Programmers: Kevin M. Rosenberg based on +;;;; original code by Pierre R. Mai +;;;; Date Started: Feb 2002 +;;;; +;;;; This file, part of CLSQL, is Copyright (c) 2002-2010 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 "Required to use connection pool.") + (database-type :initarg :database-type :initform :unknown + :reader database-type) + (encoding :initarg :encoding :initform nil + :documentation "External format character encoding.") + (state :initform :closed :reader database-state) + (autocommit :initform t :accessor database-autocommit) + (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) + (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))) + object) + +(setf (documentation 'database-name 'function) + "Returns the name of a database.") diff --git a/sql/cmucl-compat.lisp b/sql/cmucl-compat.lisp new file mode 100644 index 0000000..9ea2561 --- /dev/null +++ b/sql/cmucl-compat.lisp @@ -0,0 +1,101 @@ +;;;; -*- 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 +;;;; +;;;; This file, part of CLSQL, is Copyright (c) 2002-2010 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)) diff --git a/sql/command-object.lisp b/sql/command-object.lisp new file mode 100644 index 0000000..6af4bc8 --- /dev/null +++ b/sql/command-object.lisp @@ -0,0 +1,73 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: postgresql-socket-sql.sql +;;;; Purpose: High-level PostgreSQL interface using socket +;;;; Authors: Russ Tyndall (at Acceleration.net) based on original code by +;;;; Kevin M. Rosenberg based on original code by Pierre R. Mai +;;;; Created: Sep 2009 +;;;; +;;;; +;;;; $Id$ +;;;; +;;;; This file, part of CLSQL, is Copyright (c) 2002-2007 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 command-object () + ((expression :accessor expression :initarg :expression :initform nil + :documentation "query that refers to parameters using \"$1\", \"$2\", \"$n\". + These match positions in the parameters list.") + (parameters :accessor parameters :initarg :parameters :initform nil + :documentation "list of parameters") + (prepared-name :accessor prepared-name :initarg :prepared-name :initform "" + :documentation "If we want this to be a prepared statement, give it a name + to identify it to this session") + (has-been-prepared :accessor has-been-prepared :initarg :has-been-prepared :initform nil + :documentation "Have we already prepared this command object?") + )) + + +(defgeneric prepare-sql-parameter (sql-parameter) + (:documentation "This method is responsible for formatting parameters + as the database expects them (eg: :false is nil, nil is :null, dates are iso8601 strings)") + (:method (sql-parameter) + (typecase sql-parameter + (null :null) + (symbol + (if (member sql-parameter (list :false :F)) + nil + (princ-to-string sql-parameter))) + (clsql-sys:date (format-date nil sql-parameter :format :iso8601)) + (clsql-sys:wall-time (format-time nil sql-parameter :format :iso8601)) + (t sql-parameter)))) + +(defmethod initialize-instance :after ((o command-object) &key &allow-other-keys ) + ;; Inits parameter value coersion + (setf (parameters o) (parameters o))) + +(defmethod (setf parameters) (new (o command-object)) + " This causes the semantics to match cl-sql instead of cl-postgresql + " + (setf (slot-value o 'parameters) + (loop for p in new collecting (prepare-sql-parameter p)))) + +(defun reset-command-object (co) + "Resets the command object to have no name and to be unprepared + (This is useful if you want to run a command against a second database)" + (setf (prepared-name co) "" + (has-been-prepared co) nil)) + +(defun command-object (expression &optional parameters (prepared-name "")) + (make-instance 'command-object + :expression expression + :parameters parameters + :prepared-name prepared-name)) diff --git a/sql/conditions.lisp b/sql/conditions.lisp new file mode 100644 index 0000000..e198052 --- /dev/null +++ b/sql/conditions.lisp @@ -0,0 +1,170 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: conditions.lisp +;;;; Purpose: Error conditions for CLSQL +;;;; +;;;; This file, part of CLSQL, is Copyright (c) 2002-2010 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 *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.") + +;;; CommonSQL-compatible conditions + +(define-condition sql-condition () + ()) + +(define-condition sql-error (simple-error sql-condition) + ()) + +(define-condition sql-database-error (sql-error) + ((error-id :initarg :error-id + :initform nil + :reader sql-error-error-id) + (secondary-error-id :initarg :secondary-error-id + :initform nil + :reader sql-error-secondary-error-id) + (database-message :initarg :message + :initform nil + :reader sql-error-database-message) + (database :initarg :database + :initform nil + :reader sql-error-database)) + (:report (lambda (c stream) + (format stream "A database error occurred~@[ on database ~A~]: ~A / ~A~% ~A" + (sql-error-database c) + (sql-error-error-id c) + (sql-error-secondary-error-id c) + (sql-error-database-message c)))) + (:documentation "Used to signal an error in a CLSQL database interface.")) + +(define-condition sql-connection-error (sql-database-error) + ((database-type :initarg :database-type :initform nil + :reader sql-error-database-type) + (connection-spec :initarg :connection-spec :initform nil + :reader sql-error-connection-spec)) + (:report (lambda (c stream) + (format stream "While trying to connect to database ~A~% using database-type ~A:~% Error ~D / ~A~% has occurred." + (when (and (sql-error-connection-spec c) + (sql-error-database-type c)) + (database-name-from-spec + (sql-error-connection-spec c) + (sql-error-database-type c))) + (sql-error-database-type c) + (sql-error-error-id c) + (sql-error-database-message c)))) + (:documentation "Used to signal an error in connecting to a database.")) + +(define-condition sql-database-data-error (sql-database-error) + ((expression :initarg :expression :initarg nil + :reader sql-error-expression)) + (:report (lambda (c stream) + (format stream "While accessing database ~A~% with expression ~S:~% Error ~D / ~A~% has occurred." + (sql-error-database c) + (sql-error-expression c) + (sql-error-error-id c) + (sql-error-database-message c)))) + (:documentation "Used to signal an error with the SQL data + passed to a database.")) + +(define-condition sql-temporary-error (sql-database-error) + () + (:documentation "Used to signal an error when the database +cannot currently process a valid interaction because, for +example, it is still executing another command possibly issued by +another user.")) + +(define-condition sql-timeout-error (sql-connection-error) + () + (:documentation "Used to signal an error when the database +times out while processing some operation.")) + +(define-condition sql-fatal-error (sql-connection-error) + () + (:documentation "Used to signal an error when the database +connection is no longer usable.")) + +(define-condition sql-user-error (sql-error) + ((message :initarg :message + :initform "Unspecified error" + :reader sql-user-error-message)) + (:report (lambda (c stream) + (format stream "A CLSQL lisp code error occurred: ~A " + (sql-user-error-message c)))) + (:documentation "Used to signal lisp errors inside CLSQL.")) + + + +;; Signal conditions + +(defun signal-closed-database-error (database) + (error 'sql-fatal-error + :database database + :connection-spec (when database (connection-spec database)) + :database-type (when database (database-type database)) + :message "Database is closed.")) + +(defun signal-no-database-error (database) + (error 'sql-database-error + :database database + :message (format nil "~A is not a database." database))) + + +;;; CLSQL Extensions + +(define-condition sql-warning (warning sql-condition) + ((message :initarg :message :initform nil :reader sql-warning-message)) + (:report (lambda (c stream) + (format stream "~A" (sql-warning-message c))))) + +(define-condition sql-database-warning (sql-warning) + ((database :initarg :database :reader sql-warning-database)) + (:report (lambda (c stream) + (format stream + "While accessing database ~A~% Warning: ~A~% has occurred." + (sql-warning-database c) + (sql-warning-message c))))) + +(define-condition database-too-strange (sql-user-error) + () + (:documentation "Used to signal cases where CLSQL is going to fail at + mapping your database correctly")) + +(defun signal-database-too-strange (message) + (error 'database-too-strange :message message)) + + +(define-condition sql-value-conversion-error (error) + ((expected-type :accessor expected-type :initarg :expected-type :initform nil) + (value :accessor value :initarg :value :initform nil) + (database :accessor database :initarg :database :initform nil))) + +(defun error-converting-value (val type &optional (database *default-database*)) + (restart-case + (error (make-condition + 'sql-value-conversion-error + :expected-type type :value val :database database)) + (continue () + :report "Continue using the unconverted value" + (values val t)) + (use-value (new-val) + :report "Use a different value instead of this failed conversion" + (values new-val t) + ))) + +(defun maybe-error-converting-value + (new val type &optional (database *default-database*)) + (if (typep new type) + new + (error-converting-value + val type database))) diff --git a/sql/database.lisp b/sql/database.lisp new file mode 100644 index 0000000..299eadc --- /dev/null +++ b/sql/database.lisp @@ -0,0 +1,363 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; +;;;; 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) + +(defvar *default-encoding* + (or #+sbcl sb-impl::*default-external-format* + :utf-8)) + +(defvar *connect-if-exists* :error + "Default value for the if-exists keyword argument in calls to +CONNECT. Meaningful values are :new, :warn-new, :error, :warn-old +and :old.") + +;;TODO: this variable appears to be global, not thread specific and is +;; not protected when modifying the list. +(defvar *connected-databases* nil + "List of active database objects.") + +(defun connected-databases () + "Returns 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)) + "Returns the connected databases of type DB-TYPE whose names +match the string DATABASE. If DATABASE is a database object, it +is returned. If DB-TYPE is nil all databases matching the string +DATABASE are considered. If no matching databases are found and +ERRORP is nil then nil is returned. If ERRORP is nil and one or +more matching databases are found, then the most recently +connected database is returned as a first value and the number of +matching databases is returned as a second value. If no, or more +than one, matching databases are found and ERRORP is true, an +error is signalled." + (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." + 'sql-database-error + :message + (format nil "There exists ~A database called ~A." + (if (zerop count) "no" "more than one") + database))))) + (null + (error "A database must be specified rather than NIL.")))) + + +(defun connect (connection-spec + &key (if-exists *connect-if-exists*) + (make-default t) + (pool nil) + (database-type *default-database-type*) + (encoding *default-encoding*)) + "Connects to a database of the supplied DATABASE-TYPE which +defaults to *DEFAULT-DATABASE-TYPE*, using the type-specific +connection specification CONNECTION-SPEC. The value of IF-EXISTS, +which defaults to *CONNECT-IF-EXISTS*, determines what happens if +a connection to the database specified by CONNECTION-SPEC 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. +MAKE-DEFAULT is t by default which means that *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 'sql-database-error :message "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))) + :verbose nil)) + + (if pool + (let ((conn (acquire-from-pool connection-spec database-type pool encoding))) + (when make-default (setq *default-database* conn)) + conn) + (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 'sql-warning + :message + (format nil + "Created new connection ~A to database ~A~%, although there is an existing connection (~A)." + result (database-name result) old-db))) + (:error + (restart-case + (error 'sql-connection-error + :message + (format nil "There is an existing connection ~A to database ~A." + old-db + (database-name 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 'sql-warning + :message + (format nil + "Using existing connection ~A to database ~A." + old-db + (database-name 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)) + (setf (encoding result) encoding) + 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 instance, this object is closed. If DATABASE is a +string, then a connected database whose name matches DATABASE is +sought in the list of connected databases. If no matching +database is found and ERROR and DATABASE are both non-nil an +error is signaled, otherwise nil is returned. 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) + (with-process-lock ((conn-pool-lock (conn-pool database)) "Delete from pool") + (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) + ;;TODO: RACE COND: 2 threads disconnecting could stomp on *connected-databases* + (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))))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + +(defmacro check-connection-spec (connection-spec database-type template) + "Check the connection specification against the provided template, +and signal an sql-user-error if they don't match. This function +is called by database backends." + `(handler-case + (destructuring-bind ,template ,connection-spec + (declare (ignore ,@(remove-if + (lambda (x) (member x '(&key &rest &optional))) + template))) + t) + (error () + (error 'sql-user-error + :message + (format nil + "The connection specification ~A~%is invalid for database type ~A.~%The connection specification must conform to ~A" + ,connection-spec + ,database-type + (quote ,template)))))) + +(defun reconnect (&key (database *default-database*) (error nil) (force t)) + "Reconnects DATABASE which defaults to *DEFAULT-DATABASE* to +the underlying database management system. On success, t is +returned and the variable *DEFAULT-DATABASE* is set to the newly +reconnected database. If DATABASE is a database instance, this +object is closed. If DATABASE is a string, then a connected +database whose name matches DATABASE is sought in the list of +connected databases. If no matching database is found and ERROR +and DATABASE are both non-nil an error is signaled, otherwise nil +is returned. When the current database connection cannot be +closed, if FORCE is non-nil, as it is by default, the connection +is closed and errors are suppressed. If force is nil and the +database connection cannot be closed, an error is signalled." + (let ((db (etypecase database + (database database) + ((or string list) + (let ((db (find-database database :errorp nil))) + (when (null db) + (if (and database error) + (error 'sql-connection-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) :encoding (encoding db)))) + + +(defun status (&optional full) + "Prints information about the currently connected databases to +*STANDARD-OUTPUT*. The argument FULL is nil by default and a +value of t means that more detailed information about each +database is printed." + (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 *default-database-type*)) + "This function creates a database in the database system specified +by 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 *default-database-type*)) + "This function tests for the existence of a database in the database +system specified by 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 *default-database-type*)) + "This function destroys a database in the database system specified +by 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 *default-database-type*)) + "This function returns a list of databases existing in the database +system specified by DATABASE-TYPE." + (when (stringp connection-spec) + (setq connection-spec (string-to-list-connection-spec connection-spec))) + (database-list connection-spec database-type)) + +(defun encoding (db) + (or (when (typep db 'database) + (slot-value db 'encoding)) + *default-encoding*)) + +(defun (setf encoding) (encoding db) + (when (typep db 'database) + (setf (slot-value db 'encoding) encoding) + (when (eql (slot-value db 'state) :open) + (case (database-type db) + ;; FIXME: If database object is open then + ;; send command to SQL engine specifying the character + ;; encoding for the database + (:mysql + ) + ((:postgresql :postgresql-socket) + ))))) + +(defmacro with-database ((db-var connection-spec + &key make-default pool + (if-exists *connect-if-exists*) + (database-type *default-database-type*) + (encoding nil)) + &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. MAKE-DEFAULT has a default value of NIL." + `(let ((,db-var (connect ,connection-spec + :database-type ,database-type + :if-exists ,if-exists + :pool ,pool + :make-default ,make-default + :encoding ,encoding))) + (unwind-protect + (let ((,db-var ,db-var)) + (progn ,@body)) + (disconnect :database ,db-var)))) + +(defmacro with-default-database ((database) &rest body) + "Perform BODY with DATABASE bound as *default-database*." + `(progv '(*default-database*) + (list ,database) + ,@body)) diff --git a/sql/db-interface.lisp b/sql/db-interface.lisp new file mode 100644 index 0000000..3454a84 --- /dev/null +++ b/sql/db-interface.lisp @@ -0,0 +1,500 @@ +;;;; -*- 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 +;;;; +;;;; This file, part of CLSQL, is Copyright (c) 2002-2010 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)) + (:method (query-expression (database database) result-types field-names) + (declare (ignore query-expression result-types field-names)) + (warn "database-query not implemented for database type ~A." + (database-type 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)) + (:method (sql-expression (database database)) + (declare (ignore sql-expression)) + (warn "database-execute-command not implemented for database type ~A." + (database-type 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)) + (:method (query-expression (database database) &key full-set result-types) + (declare (ignore query-expression full-set result-types)) + (warn "database-query-result-set not implemented for database type ~A." + (database-type 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 sql-database-data-error.")) + +(defgeneric database-dump-result-set (result-set database) + (:method (result-set (database t)) + (declare (ignore result-set)) + (signal-no-database-error database)) + (:method (result-set (database database)) + (declare (ignore result-set)) + (warn "database-dump-result-set not implemented for database type ~A." + (database-type 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)) + (:method (result-set (database database) list) + (declare (ignore result-set list)) + (warn "database-store-next-row not implemented for database type ~A." + (database-type 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-probe 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-truncate (database) + (:method ((database t)) + (signal-no-database-error database)) + (:documentation "Remove all data from database.")) + +(defgeneric database-destroy (connection-spec type) + (:documentation + "Destroys (drops) 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-last-autoincrement-id (database table column) + (:documentation "Many databases have the notion of an auto-increment + id; i.e. a sequence implicitly on a table. This function should + return that ID." )) + + +(defgeneric database-start-transaction (database) + (:documentation "Start a transaction in DATABASE.") + (:method ((database t)) + (signal-no-database-error database))) + +(defgeneric database-commit-transaction (database) + (:documentation "Commit current transaction in DATABASE.") + (:method ((database t)) + (signal-no-database-error database))) + +(defgeneric database-abort-transaction (database) + (:documentation "Abort current transaction in DATABASE.") + (:method ((database t)) + (signal-no-database-error database))) + +(defgeneric database-get-type-specifier (type args database db-underlying-type) + (: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") + (:method ((database database) &key owner) + (declare (ignore owner)) + (warn "database-list-tables not implemented for database type ~A." + (database-type database))) + (:method ((database t) &key owner) + (declare (ignore owner)) + (signal-no-database-error database))) + +(defgeneric database-list-tables-and-sequences (database &key owner) + (:documentation "List all tables in the given database, may include seqeneces") + (:method ((database t) &key owner) + (declare (ignore owner)) + (signal-no-database-error database)) + (:method ((database database) &key owner) + (database-list-tables database :owner owner))) + +(defgeneric database-list-views (database &key owner) + (:documentation "List all views in the DATABASE.") + (:method ((database database) &key owner) + (declare (ignore owner)) + (warn "database-list-views not implemented for database type ~A." + (database-type database))) + (:method ((database t) &key owner) + (declare (ignore owner)) + (signal-no-database-error database))) + +(defgeneric database-list-indexes (database &key owner) + (:documentation "List all indexes in the DATABASE.") + (:method ((database database) &key owner) + (declare (ignore owner)) + (warn "database-list-indexes not implemented for database type ~A." + (database-type database))) + (:method ((database t) &key owner) + (declare (ignore owner)) + (signal-no-database-error database))) + +(defgeneric database-list-table-indexes (table database &key owner) + (:documentation "List all indexes for a table in the DATABASE.") + (:method (table (database database) &key owner) + (declare (ignore table owner)) + (warn "database-list-table-indexes not implemented for database type ~A." + (database-type database))) + (:method (table (database t) &key owner) + (declare (ignore table owner)) + (signal-no-database-error database))) + +(defgeneric database-list-attributes (table database &key owner) + (:documentation "List all attributes in TABLE.") + (:method (table (database database) &key owner) + (declare (ignore table owner)) + (warn "database-list-attributes not implemented for database type ~A." + (database-type database))) + (:method (table (database t) &key owner) + (declare (ignore table owner)) + (signal-no-database-error database))) + +(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.") + (:method (attribute table (database database) &key owner) + (declare (ignore attribute table owner)) + (warn "database-list-attribute-type not implemented for database type ~A." + (database-type database))) + (:method (attribute table (database t) &key owner) + (declare (ignore attribute table owner)) + (signal-no-database-error database))) + +(defgeneric database-add-attribute (table attribute database) + (:documentation "Add the attribute to the table.") + (:method (table attribute (database database)) + (declare (ignore table attribute)) + (warn "database-add-attribute not implemented for database type ~A." + (database-type database))) + (:method (table attribute (database t)) + (declare (ignore table attribute)) + (signal-no-database-error database))) + +(defgeneric database-rename-attribute (table oldatt newname database) + (:documentation "Rename the attribute in the table to NEWNAME.") + (:method (table oldatt newname (database database)) + (declare (ignore table oldatt newname)) + (warn "database-rename-attribute not implemented for database type ~A." + (database-type database))) + (:method (table oldatt newname (database t)) + (declare (ignore table oldatt newname)) + (signal-no-database-error database))) + +(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-use-fully-qualified-column-on-drop-index? (db-type) + (:method (db-type) + (declare (ignore db-type)) + nil) + (:documentation "NIL [default] if database-type does not require fully qualified 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-has-bigint? (db-type) + (:method (db-type) + (declare (ignore db-type)) + ;; SQL92 has bigint + t) + (:documentation "T [default] if database-type supports bigint.")) + +(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-type-has-union? (db-type) + (:method (db-type) + (declare (ignore db-type)) + t) + (:documentation "T [default] if database-type supports boolean UNION.")) + +(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.")) + +(defgeneric db-type-has-prepared-stmt? (db-type) + (:method ((db-type t)) + nil) + (:documentation "T if database backend supports prepared statements.")) + +(defgeneric db-type-has-intersect? (db-type) + (:method (db-type) + (declare (ignore db-type)) + t) + (:documentation "T [default] if database-type supports INTERSECT.")) + +(defgeneric db-type-has-except? (db-type) + (:method (db-type) + (declare (ignore db-type)) + t) + (:documentation "T [default] if database-type supports EXCEPT.")) + +(defgeneric db-type-has-auto-increment? (db-type) + (:method (db-type) + (declare (ignore db-type)) + nil) + (:documentation "NIL [default] if database-type supports auto-incrementing columns.")) + +;;; 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")) + +;; Prepared statements + +(defgeneric database-prepare (stmt types database result-types field-names) + (:method (stmt types (database t) result-types field-names) + (declare (ignore stmt types result-types field-names)) + (signal-no-database-error database)) + (:method (stmt types (database database) result-types field-names) + (declare (ignore stmt types result-types field-names)) + (error 'sql-database-error + :message + (format nil "DATABASE-PREPARE not implemented for ~S" database))) + (:documentation "Prepare a statement for later execution.")) + +(defgeneric database-bind-parameter (prepared-stmt position value) + (:method ((pstmt t) position value) + (declare (ignore position value)) + (error 'sql-database-error + :message + (format nil "database-bind-paremeter not implemented for ~S" pstmt))) + (:documentation "Bind a parameter for a prepared statement.")) + +(defgeneric database-run-prepared (prepared-stmt) + (:method ((pstmt t)) + (error 'sql-database-error + :message (format nil "database-run-prepared not specialized for ~S" pstmt))) + (:documentation "Execute a prepared statement.")) + +(defgeneric database-free-prepared (prepared-stmt) + (:method ((pstmt t)) + ;; nothing to do by default + nil) + (:documentation "Free the resources of a prepared statement.")) + +(defgeneric database-acquire-from-conn-pool (database) + (:documentation "Acquire a database connection from the pool. This +is a chance to test the connection for validity before returning it to +the user. If this function returns NIL or throws an error that +database connection is considered bad and we make a new one. + +Database objects have a chance to specialize, otherwise the default +method uses the database-underlying-type and tries to do something +appropriate.")) + +(defgeneric database-release-to-conn-pool (database) + (:documentation "Chance for the database to cleanup before it is + returned to the connection pool.")) + +;; 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))) + +(defvar *foreign-library-search-paths* nil + "A list of pathnames denoting directories where CLSQL will look +for foreign libraries \(in addition to the default places).") + +(defun push-library-path (path) + "Adds the pathspec PATH \(which should denote a directory) to +the list *FOREIGN-LIBRARY-SEARCH-PATHS*." + (pushnew path *foreign-library-search-paths* :test #'equal)) diff --git a/sql/decimals.lisp b/sql/decimals.lisp new file mode 100644 index 0000000..b8df6fc --- /dev/null +++ b/sql/decimals.lisp @@ -0,0 +1,419 @@ +;;; DECIMALS +;; +;; A decimal number parser and formatting package for Common Lisp. +;; +;; Author: Teemu Likonen <tlikonen@iki.fi> +;; +;; License: Public domain +;; +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + +(defpackage #:decimals + (:use #:cl) + (:export #:round-half-away-from-zero + #:format-decimal-number + #:parse-decimal-number + #:decimal-parse-error + #:define-decimal-formatter)) + +(in-package #:decimals) + + +(defun round-half-away-from-zero (number &optional (divisor 1)) + + "Divide _number_ by _divisor_ and round the result to the nearest integer. +If the result is half-way between two integers round away from zero. Two +values are returned: quotient and remainder. + +This is similar to `cl:round` function except that `cl:round` rounds to +an even integer when number is exactly between two integers. Examples: + + (round-half-away-from-zero 3/2) => 2, -1/2 + (round 3/2) => 2, -1/2 + + (round-half-away-from-zero 5/2) => 3, -1/2 + (round 5/2) => 2, 1/2" + + (if (zerop number) + (values 0 0) + (let ((quotient (if (plusp number) + (floor (+ (/ number divisor) 1/2)) + (ceiling (- (/ number divisor) 1/2))))) + (values quotient (- number (* quotient divisor)))))) + + +(defun divide-into-groups (string &key (separator #\Space) (from-end nil) + (group-digits 3)) + + (assert (and (integerp group-digits) + (plusp group-digits)) + (group-digits) + "The GROUP-DIGITS argument must be a positive integer") + + (setf separator (princ-to-string separator)) + + (if (zerop (length separator)) + string + (flet ((make-groups (string separator) + (loop :with length := (length string) + :with result := (make-array length :element-type 'character + :fill-pointer 0 :adjustable t) + :for c :across string + :for i :upfrom 1 + :do (vector-push-extend c result) + :if (and (zerop (rem i group-digits)) + (< i length)) + :do (loop :for c :across separator + :do (vector-push-extend c result)) + :finally (return result)))) + + (if from-end + (nreverse (make-groups (reverse string) (reverse separator))) + (make-groups string separator))))) + + +(defun decimal-round-split (number &key + (round-magnitude 0) + (rounder #'round-half-away-from-zero) + (positive-sign #\+) + (negative-sign #\-) + (zero-sign nil)) + + (assert (integerp round-magnitude) (round-magnitude) + "ROUND-MAGNITUDE argument must be an integer.") + + (when (floatp number) + (setf number (rational number))) + + (let ((divisor (expt 10 round-magnitude))) + (setf number (* divisor (funcall rounder number divisor)))) + + (let ((sign (cond ((plusp number) (or positive-sign "")) + ((minusp number) (or negative-sign "")) + (t (or zero-sign ""))))) + + (multiple-value-bind (integer fractional) + (truncate (abs number)) + (let ((fractional-string + (with-output-to-string (out) + (loop :with next := fractional + :with remainder + :repeat (abs round-magnitude) + :until (zerop next) + :do + (setf (values next remainder) (truncate (* next 10))) + (princ next out) + (setf next remainder))))) + (list (princ-to-string sign) + (princ-to-string integer) + fractional-string))))) + + +(defun string-align (string width &key (side :left) (char #\Space)) + (if (>= (length string) width) + string + (let ((result (make-string width :initial-element char))) + (ecase side + (:left (replace result string)) + (:right (replace result string + :start1 (- width (length string)))))))) + + +(defun format-decimal-number (number &key + (round-magnitude 0) + (rounder #'round-half-away-from-zero) + (decimal-separator #\.) + (integer-group-separator nil) + (integer-group-digits 3) + (integer-minimum-width 0) + (integer-pad-char #\Space) + (fractional-group-separator nil) + (fractional-group-digits 3) + (fractional-minimum-width 0) + (fractional-pad-char #\Space) + (show-trailing-zeros nil) + (positive-sign nil) + (negative-sign #\-) + (zero-sign nil)) + + "Apply specified decimal number formatting rules to _number_ and +return a formatted string. + +The second return value is (almost) the same formatted string divided +into four strings. It's a list of four strings: sign, integer part, +decimal separator and fractional part. Formatting arguments +_integer-minimum-width_ and _fractional-minimum-width_ do not apply to +the second return value. Everything else does. + +_Number_ must be of type `real`. This function uses `rational` types +internally. If the given _number_ is a `float` it is first turned into +`rational` by calling `cl:rational`. + +Formatting rules are specified with keyword arguments, as described +below. The default value is in parentheses. + + * `round-magnitude (0)` + + This is the order of magnitude used for rounding. The value must be + an integer and it is interpreted as a power of 10. + + * `show-trailing-zeros (nil)` + + If the value is non-nil print all trailing zeros in fractional part. + Examples: + + (format-decimal-number 1/5 :round-magnitude -3 + :show-trailing-zeros nil) + => \"0.2\" + + (format-decimal-number 1/5 :round-magnitude -3 + :show-trailing-zeros t) + => \"0.200\" + + * `rounder (#'round-half-away-from-zero)` + + The value must be a function (or a symbol naming a function). It is + used to round the number to the specified round magnitude. The + function must work like `cl:truncate`, `cl:floor`, `cl:ceiling` and + `cl:round`, that is, take two arguments, a number and a divisor, and + return the quotient as the first value. + + This package introduces another rounding function, + `round-half-away-from-zero`, which is used by default. See its + documentation for more information. + + * `decimal-separator (#\\.)` + + If the value is non-nil the `princ` output of the value will be + added between integer and fractional parts. Probably the most useful + types are `character` and `string`. + + * `integer-group-separator (nil)` + * `fractional-group-separator (nil)` + + If the value is non-nil the digits in integer or fractional parts + are put in groups. The `princ` output of the value will be added + between digit groups. + + * `integer-group-digits (3)` + * `fractional-group-digits (3)` + + The value is a positive integer defining the number of digits in + groups. + + * `integer-minimum-width (0)` + * `fractional-minimum-width (0)` + + Format integer or fractional part using minimum of this amount of + characters, possibly using some padding characters (see below). + _positive-sign_, _negative-sign_ or _zero-sign_ (see below) is + included when calculating the width of the integer part. Similarly + _decimal-separator_ is included when calculating the width of the + fractional part. + + * `integer-pad-char (#\\Space)` + * `fractional-pad-char (#\\Space)` + + The value is the padding character which is used to fill + _integer-minimum-width_ or _fractional-minimum-width_. + + * `positive-sign (nil)` + * `negative-sign (#\\-)` + * `zero-sign (nil)` + + If values are non-nil these are used as the leading sign for + positive, negative and zero numbers. The `princ` output of the value + is used." + + (destructuring-bind (sign integer fractional) + (decimal-round-split number + :round-magnitude round-magnitude + :rounder rounder + :positive-sign positive-sign + :negative-sign negative-sign + :zero-sign zero-sign) + + (setf decimal-separator (if decimal-separator + (princ-to-string decimal-separator) + "") + integer (divide-into-groups + integer + :separator (or integer-group-separator "") + :group-digits integer-group-digits + :from-end t) + fractional (divide-into-groups + (if (and show-trailing-zeros + (plusp (- (- (length fractional)) + round-magnitude))) + (replace (make-string (abs round-magnitude) + :initial-element #\0) + fractional) + fractional) + :separator (or fractional-group-separator "") + :group-digits fractional-group-digits + :from-end nil)) + + (values + (concatenate + 'string + (string-align (concatenate 'string sign integer) + integer-minimum-width + :side :right :char integer-pad-char) + (string-align (if (plusp (length fractional)) + (concatenate 'string decimal-separator fractional) + "") + fractional-minimum-width + :side :left :char fractional-pad-char)) + (list sign integer decimal-separator fractional)))) + + +(defmacro define-decimal-formatter (name &body keyword-arguments) + + "Define a decimal number formatter function to use with the `~/` +directive of `cl:format`. The valid format is this: + + (define-decimal-formatter name + (:keyword form) + ...) + +_Name_ is the symbol that names the function. _Keyword_ must be a valid +keyword argument for the `format-decimal-number` function (see its +documentation for more information). _Form_ is evaluated and the value +is used with the _keyword_ argument. Macro's side effect is that global +function _name_ is defined. It can be used with the `~/` directive of +`cl:format` function. + +Examples: + + (define-decimal-formatter my-formatter + (:round-magnitude -6) + (:decimal-separator \",\") + (:integer-group-separator \" \") + (:integer-minimum-width 4) + (:fractional-group-separator \" \") + (:fractional-minimum-width 10) + (:show-trailing-zeros t)) + => MY-FORMATTER + + (format nil \"~/my-formatter/\" 10/6) + => \" 1,666 667 \" + + (format nil \"~/my-formatter/\" 100/8) + => \" 12,500 000 \" + +The `~/` directive function call can optionally take up to three +arguments to override the defaults: + + ~round-magnitude,integer-minimum-width,fractional-minimum-width/FUNCTION/ + +For example: + + (format nil \"~-2,3,4/my-formatter/\" 10/6) + => \" 1,67 \"" + + (let ((key-arg (gensym))) + `(let ((,key-arg (list ,@(loop :for (keyword value) :in keyword-arguments + :do (assert (keywordp keyword) (keyword) + "Keyword required.") + :collect keyword :collect value)))) + + (defun ,name (stream number &optional colon-p at-sign-p + round-magnitude integer-minimum-width + fractional-minimum-width) + (declare (ignore colon-p at-sign-p)) + + (let ((args (copy-list ,key-arg))) + (when round-magnitude + (setf (getf args :round-magnitude) + round-magnitude)) + (when integer-minimum-width + (setf (getf args :integer-minimum-width) + integer-minimum-width)) + (when fractional-minimum-width + (setf (getf args :fractional-minimum-width) + fractional-minimum-width)) + (princ (apply #'format-decimal-number number args) stream)))))) + + +(defun number-string-to-integer (string) + (handler-case (parse-integer string) + (parse-error () nil))) + + +(defun number-string-to-fractional (string) + (when (every #'digit-char-p string) + (setf string (string-right-trim "0" string)) + (handler-case (/ (parse-integer string) + (expt 10 (length string))) + (parse-error () nil)))) + + +(define-condition decimal-parse-error (parse-error) + nil + (:report "Not a valid decimal number string.") + (:documentation + "Function `parse-decimal-number` signals this condition when it +couldn't parse a decimal number from string.")) + + +(defun parse-decimal-number (string &key + (decimal-separator #\.) + (positive-sign #\+) + (negative-sign #\-) + (start 0) (end nil)) + + "Examine _string_ (or its substring from _start_ to _end_) for a +decimal number. Assume that the decimal number is exact and return it as +a rational number. + +Rules for parsing: First all leading and trailing `#\\Space` characters +are stripped. The resulting string may start with a _positive-sign_ or a +_negative-sign_ character. The latter causes this function to assume a +negative number. The following characters in the string must include one +or more digit characters and it may include one _decimal-separator_ +character which separates integer and fractional parts. All other +characters are illegal. If these rules are not met a +`decimal-parse-error` condition is signaled. + +Examples: + + (parse-decimal-number \"0.2\") => 1/5 + (parse-decimal-number \".2\") => 1/5 + (parse-decimal-number \"+3.\") => 3 + (parse-decimal-number \" -7 \") => -7 + + (parse-decimal-number \"−12,345\" + :decimal-separator #\\, + :negative-sign #\\−) + => -2469/200" + + (setf string (string-trim " " (subseq string start end))) + (if (not (plusp (length string))) + (error 'decimal-parse-error) + (let ((sign 1)) + (cond ((char= (aref string 0) negative-sign) + (setf sign -1 + string (subseq string 1))) + ((char= (aref string 0) positive-sign) + (setf string (subseq string 1)))) + + (if (and (every (lambda (item) + (or (digit-char-p item) + (char= item decimal-separator))) + string) + (some #'digit-char-p string) + (<= 0 (count decimal-separator string) 1)) + + (let ((pos (position decimal-separator string))) + (* sign + (+ (or (number-string-to-integer (subseq string 0 pos)) + 0) + (if pos + (or (number-string-to-fractional + (subseq string (1+ pos))) + 0) + 0)))) + + (error 'decimal-parse-error))))) diff --git a/sql/expressions.lisp b/sql/expressions.lisp new file mode 100644 index 0000000..4f0baf1 --- /dev/null +++ b/sql/expressions.lisp @@ -0,0 +1,1247 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; +;;;; Classes defining SQL expressions and methods for formatting the +;;;; appropriate SQL commands. +;;;; +;;;; 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) + +(defvar +empty-string+ "''") + +(defvar +null-string+ "NULL") + +(defvar *sql-stream* nil + "stream which accumulates SQL output") + +(defclass %database-identifier () + ((escaped :accessor escaped :initarg :escaped :initform nil) + (unescaped :accessor unescaped :initarg :unescaped :initform nil)) + (:documentation + "A database identifier represents a string/symbol ready to be spliced + into a sql string. It keeps references to both the escaped and + unescaped versions so that unescaped versions can be compared to the + results of list-tables/views/attributes etc. It also allows you to be + sure that an identifier is escaped only once. + + (escaped-database-identifiers *any-reasonable-object*) should be called to + produce a string that is safe to splice directly into sql strings. + + (unescaped-database-identifier *any-reasonable-object*) is generally what + you pass to it with the exception that symbols have been + clsql-sys:sql-escape which converts to a string and changes - to _ (so + that unescaped can be compared to the results of eg: list-tables) + ")) + +(defmethod escaped ((it null)) it) +(defmethod unescaped ((it null)) it) + +(defun database-identifier-equal (i1 i2 &optional (database clsql-sys:*default-database*)) + (setf i1 (database-identifier i1 database) + i2 (database-identifier i2 database)) + (flet ((cast (i) + (if (symbolp (unescaped i)) + (sql-escape (unescaped i)) + (unescaped i)))) + (or ;; check for an exact match + (equal (escaped-database-identifier i1) + (escaped-database-identifier i2)) + ;; check for an inexact match if we had symbols in the mix + (string-equal (cast i1) (cast i2))))) + +(defun delistify-dsd (list) + "Some MOPs, like openmcl 0.14.2, cons attribute values in a list." + (if (and (listp list) (null (cdr list))) + (car list) + list)) + +(defun special-char-p (s) + "Check if a string has any special characters" + (loop for char across s + thereis (find char '(#\space #\, #\. #\! #\@ #\# #\$ #\% #\' #\" + #\^ #\& #\* #\| #\( #\) #\- #\+ #\< #\> + #\{ #\})))) + +(defun special-cased-symbol-p (sym) + "Should the symbols case be preserved, or should we convert to default casing" + (let ((name (symbol-name sym))) + (case (readtable-case *readtable*) + (:upcase (not (string= (string-upcase name) name))) + (:downcase (not (string= (string-downcase name) name))) + (t t)))) + +(defun %make-database-identifier (inp &optional database) + "We want to quote an identifier if it came to us as a string or if it has special characters + in it." + (labels ((%escape-identifier (inp &optional orig) + "Quote an identifier unless it is already quoted" + (cond + ;; already quoted + ((and (eql #\" (elt inp 0)) + (eql #\" (elt inp (- (length inp) 1)))) + (make-instance '%database-identifier :unescaped (or orig inp) :escaped inp)) + (T (make-instance + '%database-identifier :unescaped (or orig inp) :escaped + (concatenate + 'string "\"" (replace-all inp "\"" "\\\"") "\"")))))) + (typecase inp + (string (%escape-identifier inp)) + (%database-identifier inp) + (symbol + (let ((s (sql-escape inp))) + (if (and (not (eql '* inp)) (special-char-p s)) + (%escape-identifier + (if (special-cased-symbol-p inp) + s + (convert-to-db-default-case s database)) inp) + (make-instance '%database-identifier :escaped s :unescaped inp)) + ))))) + +(defun combine-database-identifiers (ids &optional (database clsql-sys:*default-database*) + &aux res all-sym? pkg) + "Create a new database identifier by combining parts in a reasonable way + " + (setf ids (mapcar #'database-identifier ids) + all-sym? (every (lambda (i) (symbolp (unescaped i))) ids) + pkg (when all-sym? (symbol-package (unescaped (first ids))))) + (labels ((cast ( i ) + (typecase i + (null nil) + (%database-identifier (cast (unescaped i))) + (symbol + (if all-sym? + (sql-escape i) + (convert-to-db-default-case (sql-escape i) database))) + (string i))) + (comb (i1 i2) + (setf i1 (cast i1) + i2 (cast i2)) + (if (and i1 i2) + (concatenate 'string (cast i1) "_" (cast i2)) + (or i1 i2)))) + (setf res (reduce #'comb ids)) + (database-identifier + (if all-sym? (intern res pkg) res) + database))) + +(defun escaped-database-identifier (name &optional database find-class-p) + (escaped (database-identifier name database find-class-p))) + +(defun unescaped-database-identifier (name &optional database find-class-p) + (unescaped (database-identifier name database find-class-p))) + +(defun sql-output (sql-expr &optional (database *default-database*)) + "Top-level call for generating SQL strings. Returns an SQL + string appropriate for DATABASE which corresponds to the + supplied lisp expression SQL-EXPR." + (with-output-to-string (*sql-stream*) + (output-sql sql-expr database))) + +(defmethod output-sql (expr database) + (write-string (database-output-sql expr database) *sql-stream*) + (values)) + + +(defvar *output-hash* + (make-weak-hash-table :test #'equal) + "For caching generated SQL strings, set to NIL to disable." + ) + +(defmethod output-sql :around ((sql t) database) + (if (null *output-hash*) + (call-next-method) + (let* ((hash-key (output-sql-hash-key sql database)) + (hash-value (when hash-key (gethash hash-key *output-hash*)))) + (cond ((and hash-key hash-value) + (write-string hash-value *sql-stream*)) + (hash-key + (let ((*sql-stream* (make-string-output-stream))) + (call-next-method) + (setf hash-value (get-output-stream-string *sql-stream*)) + (setf (gethash hash-key *output-hash*) hash-value)) + (write-string hash-value *sql-stream*)) + (t + (call-next-method)))))) + +(defmethod output-sql-hash-key (expr database) + (declare (ignore expr database)) + nil) + + +(defclass %sql-expression () + ()) + +(defmethod output-sql ((expr %sql-expression) database) + (declare (ignore database)) + (write-string +null-string+ *sql-stream*)) + +(defmethod print-object ((self %sql-expression) stream) + (print-unreadable-object + (self stream :type t) + (write-string (sql-output self) stream)) + self) + +;; For straight up strings + +(defclass sql (%sql-expression) + ((text + :initarg :string + :initform "")) + (:documentation "A literal SQL expression.")) + +(defmethod make-load-form ((sql sql) &optional environment) + (declare (ignore environment)) + (with-slots (text) + sql + `(make-instance 'sql :string ',text))) + +(defmethod output-sql ((expr sql) database) + (declare (ignore database)) + (write-string (slot-value expr 'text) *sql-stream*) + t) + +(defmethod print-object ((ident sql) stream) + (format stream "#<~S \"~A\">" + (type-of ident) + (sql-output ident nil)) + ident) + +;; For SQL Identifiers of generic type + +(defclass sql-ident (%sql-expression) + ((name + :initarg :name + :initform +null-string+)) + (:documentation "An SQL identifer.")) + +(defmethod make-load-form ((sql sql-ident) &optional environment) + (declare (ignore environment)) + (with-slots (name) + sql + `(make-instance 'sql-ident :name ',name))) + +(defmethod output-sql ((expr %database-identifier) database) + (write-string (escaped expr) *sql-stream*)) + +(defmethod output-sql ((expr sql-ident) database) + (with-slots (name) expr + (write-string (escaped-database-identifier name database) *sql-stream*)) + t) + +;; For SQL Identifiers for attributes + +(defclass sql-ident-attribute (sql-ident) + ((qualifier + :initarg :qualifier + :initform +null-string+) + (type + :initarg :type + :initform +null-string+)) + (:documentation "An SQL Attribute identifier.")) + +(defmethod collect-table-refs (sql) + (declare (ignore sql)) + nil) + +(defmethod collect-table-refs ((sql list)) + (loop for i in sql + appending (listify (collect-table-refs i)))) + +(defmethod collect-table-refs ((sql sql-ident-attribute)) + (let ((qual (slot-value sql 'qualifier))) + (when qual + ;; going to be used as a table, search classes + (list (make-instance + 'sql-ident-table + :name (database-identifier qual nil t)))))) + +(defmethod make-load-form ((sql sql-ident-attribute) &optional environment) + (declare (ignore environment)) + (with-slots (qualifier type name) + sql + `(make-instance 'sql-ident-attribute :name ',name + :qualifier ',qualifier + :type ',type))) + +(defmethod output-sql-hash-key ((expr sql-ident-attribute) database) + (with-slots (qualifier name type) + expr + (list (and database (database-underlying-type database)) + 'sql-ident-attribute + (unescaped-database-identifier qualifier) + (unescaped-database-identifier name) type))) + +;; For SQL Identifiers for tables + +(defclass sql-ident-table (sql-ident) + ((alias + :initarg :table-alias :initform nil)) + (:documentation "An SQL table identifier.")) + +(defmethod make-load-form ((sql sql-ident-table) &optional environment) + (declare (ignore environment)) + (with-slots (alias name) + sql + `(make-instance 'sql-ident-table :name ',name :table-alias ',alias))) + +(defmethod collect-table-refs ((sql sql-ident-table)) + (list sql)) + +(defmethod output-sql ((expr sql-ident-table) database) + (with-slots (name alias) expr + (flet ((p (s) ;; the etypecase is in sql-escape too + (write-string + (escaped-database-identifier s database) + *sql-stream*))) + (p name) + (when alias + (princ #\space *sql-stream*) + (p alias)))) + t) + +(defmethod output-sql ((expr sql-ident-attribute) database) +;;; KMR: The TYPE field is used by CommonSQL for type conversion -- it +;;; should not be output in SQL statements + (let ((*print-pretty* nil)) + (with-slots (qualifier name type) expr + (format *sql-stream* "~@[~a.~]~a" + (when qualifier + ;; check for classes + (escaped-database-identifier qualifier database T)) + (escaped-database-identifier name database)) + t))) + +(defmethod output-sql-hash-key ((expr sql-ident-table) database) + (with-slots (name alias) + expr + (list (and database (database-underlying-type database)) + 'sql-ident-table + (unescaped-database-identifier name) + (unescaped-database-identifier alias)))) + +(defclass sql-relational-exp (%sql-expression) + ((operator + :initarg :operator + :initform nil) + (sub-expressions + :initarg :sub-expressions + :initform nil)) + (:documentation "An SQL relational expression.")) + +(defmethod make-load-form ((self sql-relational-exp) &optional environment) + (make-load-form-saving-slots self + :slot-names '(operator sub-expressions) + :environment environment)) + +(defmethod collect-table-refs ((sql sql-relational-exp)) + (let ((tabs nil)) + (dolist (exp (slot-value sql 'sub-expressions)) + (let ((refs (collect-table-refs exp))) + (if refs (setf tabs (append refs tabs))))) + (remove-duplicates tabs :test #'database-identifier-equal))) + + + + +;; Write SQL for relational operators (like 'AND' and 'OR'). +;; should do arity checking of subexpressions + +(defun %write-operator (operator database) + (typecase operator + (string (write-string operator *sql-stream*)) + (symbol (write-string (symbol-name operator) *sql-stream*)) + (T (output-sql operator database)))) + +(defmethod output-sql ((expr sql-relational-exp) database) + (with-slots (operator sub-expressions) expr + ;; we do this as two runs so as not to emit confusing superflous parentheses + ;; The first loop renders all the child outputs so that we can skip anding with + ;; empty output (which causes sql errors) + ;; the next loop simply emits each sub-expression with the appropriate number of + ;; parens and operators + (flet ((trim (sub) + (string-trim +whitespace-chars+ + (with-output-to-string (*sql-stream*) + (output-sql sub database))))) + (let ((str-subs (loop for sub in sub-expressions + for str-sub = (trim sub) + when (and str-sub (> (length str-sub) 0)) + collect str-sub))) + (case (length str-subs) + (0 nil) + (1 (write-string (first str-subs) *sql-stream*)) + (t + (write-char #\( *sql-stream*) + (write-string (first str-subs) *sql-stream*) + (loop for str-sub in (rest str-subs) + do + (write-char #\Space *sql-stream*) + ;; do this so that symbols can be output as database identifiers + ;; rather than allowing symbols to inject sql + (%write-operator operator database) + (write-char #\Space *sql-stream*) + (write-string str-sub *sql-stream*)) + (write-char #\) *sql-stream*)) + )))) + t) + +(defclass sql-upcase-like (sql-relational-exp) + () + (:documentation "An SQL 'like' that upcases its arguments.")) + +(defmethod output-sql ((expr sql-upcase-like) database) + (flet ((write-term (term) + (write-string "upper(" *sql-stream*) + (output-sql term database) + (write-char #\) *sql-stream*))) + (with-slots (sub-expressions) + expr + (let ((subs (if (consp (car sub-expressions)) + (car sub-expressions) + sub-expressions))) + (write-char #\( *sql-stream*) + (do ((sub subs (cdr sub))) + ((null (cdr sub)) (write-term (car sub))) + (write-term (car sub)) + (write-string " LIKE " *sql-stream*)) + (write-char #\) *sql-stream*)))) + t) + +(defclass sql-assignment-exp (sql-relational-exp) + () + (:documentation "An SQL Assignment expression.")) + + +(defmethod output-sql ((expr sql-assignment-exp) database) + (with-slots (operator sub-expressions) + expr + (do ((sub sub-expressions (cdr sub))) + ((null (cdr sub)) (output-sql (car sub) database)) + (output-sql (car sub) database) + (write-char #\Space *sql-stream*) + (%write-operator operator database) + (write-char #\Space *sql-stream*))) + t) + +(defclass sql-value-exp (%sql-expression) + ((modifier + :initarg :modifier + :initform nil) + (components + :initarg :components + :initform nil)) + (:documentation + "An SQL value expression.") + ) + +(defmethod collect-table-refs ((sql sql-value-exp)) + (let ((tabs nil)) + (if (listp (slot-value sql 'components)) + (progn + (dolist (exp (slot-value sql 'components)) + (let ((refs (collect-table-refs exp))) + (if refs (setf tabs (append refs tabs))))) + (remove-duplicates tabs :test #'database-identifier-equal)) + nil))) + +(defmethod output-sql ((expr sql-value-exp) database) + (with-slots (modifier components) + expr + (if modifier + (progn + (write-char #\( *sql-stream*) + (cond + ((sql-operator modifier) + (%write-operator modifier database)) + ((or (stringp modifier) (symbolp modifier)) + (write-string + (escaped-database-identifier modifier) + *sql-stream*)) + (t (output-sql modifier database))) + (write-char #\Space *sql-stream*) + (output-sql components database) + (write-char #\) *sql-stream*)) + (output-sql components database)))) + +(defclass sql-typecast-exp (sql-value-exp) + () + (:documentation "An SQL typecast expression.")) + +(defmethod output-sql ((expr sql-typecast-exp) database) + (with-slots (components) + expr + (output-sql components database))) + +(defmethod collect-table-refs ((sql sql-typecast-exp)) + (when (slot-value sql 'components) + (collect-table-refs (slot-value sql 'components)))) + +(defclass sql-function-exp (%sql-expression) + ((name + :initarg :name + :initform nil) + (args + :initarg :args + :initform nil)) + (:documentation + "An SQL function expression.")) + +(defmethod collect-table-refs ((sql sql-function-exp)) + (let ((tabs nil)) + (dolist (exp (slot-value sql 'args)) + (let ((refs (collect-table-refs exp))) + (if refs (setf tabs (append refs tabs))))) + (remove-duplicates tabs :test #'database-identifier-equal))) +(defvar *in-subselect* nil) + +(defmethod output-sql ((expr sql-function-exp) database) + (with-slots (name args) + expr + (typecase name + ((or string symbol) + (write-string (escaped-database-identifier name) *sql-stream*)) + (t (output-sql name database))) + (let ((*in-subselect* nil)) ;; aboid double parens + (when args (output-sql args database)))) + t) + + +(defclass sql-between-exp (sql-function-exp) + () + (:documentation "An SQL between expression.")) + +(defmethod output-sql ((expr sql-between-exp) database) + (with-slots (args) + expr + (output-sql (first args) database) + (write-string " BETWEEN " *sql-stream*) + (output-sql (second args) database) + (write-string " AND " *sql-stream*) + (output-sql (third args) database)) + t) + +(defclass sql-query-modifier-exp (%sql-expression) + ((modifier :initarg :modifier :initform nil) + (components :initarg :components :initform nil)) + (:documentation "An SQL query modifier expression.")) + +(defmethod output-sql ((expr sql-query-modifier-exp) database) + (with-slots (modifier components) + expr + (%write-operator modifier database) + (write-string " " *sql-stream*) + (%write-operator (car components) database) + (when components + (mapc #'(lambda (comp) + (write-string ", " *sql-stream*) + (output-sql comp database)) + (cdr components)))) + t) + +(defclass sql-set-exp (%sql-expression) + ((operator + :initarg :operator + :initform nil) + (sub-expressions + :initarg :sub-expressions + :initform nil)) + (:documentation "An SQL set expression.")) + +(defmethod collect-table-refs ((sql sql-set-exp)) + (let ((tabs nil)) + (dolist (exp (slot-value sql 'sub-expressions)) + (let ((refs (collect-table-refs exp))) + (if refs (setf tabs (append refs tabs))))) + (remove-duplicates tabs :test #'database-identifier-equal))) + +(defmethod output-sql ((expr sql-set-exp) database) + (with-slots (operator sub-expressions) + expr + (let ((subs (if (consp (car sub-expressions)) + (car sub-expressions) + sub-expressions))) + (when (= (length subs) 1) + (%write-operator operator database) + (write-char #\Space *sql-stream*)) + (do ((sub subs (cdr sub))) + ((null (cdr sub)) (output-sql (car sub) database)) + (output-sql (car sub) database) + (write-char #\Space *sql-stream*) + (%write-operator operator database) + (write-char #\Space *sql-stream*)))) + t) + +(defclass sql-query (%sql-expression) + ((selections + :initarg :selections + :initform nil) + (all + :initarg :all + :initform nil) + (flatp + :initarg :flatp + :initform nil) + (set-operation + :initarg :set-operation + :initform nil) + (distinct + :initarg :distinct + :initform nil) + (from + :initarg :from + :initform nil) + (where + :initarg :where + :initform nil) + (group-by + :initarg :group-by + :initform nil) + (having + :initarg :having + :initform nil) + (limit + :initarg :limit + :initform nil) + (offset + :initarg :offset + :initform nil) + (order-by + :initarg :order-by + :initform nil) + (inner-join + :initarg :inner-join + :initform nil) + (on + :initarg :on + :initform nil)) + (:documentation "An SQL SELECT query.")) + +(defclass sql-object-query (%sql-expression) + ((objects + :initarg :objects + :initform nil) + (flatp + :initarg :flatp + :initform nil) + (exp + :initarg :exp + :initform nil) + (refresh + :initarg :refresh + :initform nil))) + +(defmethod collect-table-refs ((sql sql-query)) + (remove-duplicates + (collect-table-refs (slot-value sql 'where)) + :test #'database-identifier-equal)) + +(defvar *select-arguments* + '(:all :database :distinct :flatp :from :group-by :having :order-by + :set-operation :where :offset :limit :inner-join :on + ;; below keywords are not a SQL argument, but these keywords may terminate select + :caching :refresh)) + +(defun query-arg-p (sym) + (member sym *select-arguments*)) + +(defun query-get-selections (select-args) + "Return two values: the list of select-args up to the first keyword, +uninclusive, and the args from that keyword to the end." + (let ((first-key-arg (position-if #'query-arg-p select-args))) + (if first-key-arg + (values (subseq select-args 0 first-key-arg) + (subseq select-args first-key-arg)) + select-args))) + +(defun make-query (&rest args) + (flet ((select-objects (target-args) + (and target-args + (every #'(lambda (arg) + (and (symbolp arg) + (find-class arg nil))) + target-args)))) + (multiple-value-bind (selections arglist) + (query-get-selections args) + (if (select-objects selections) + (destructuring-bind (&key flatp refresh &allow-other-keys) arglist + (make-instance 'sql-object-query :objects selections + :flatp flatp :refresh refresh + :exp arglist)) + (destructuring-bind (&key all flatp set-operation distinct from where + group-by having order-by + offset limit inner-join on &allow-other-keys) + arglist + (if (null selections) + (error "No target columns supplied to select statement.")) + (if (null from) + (error "No source tables supplied to select statement.")) + (make-instance 'sql-query :selections selections + :all all :flatp flatp :set-operation set-operation + :distinct distinct :from from :where where + :limit limit :offset offset + :group-by group-by :having having :order-by order-by + :inner-join inner-join :on on)))))) + +(defun output-sql-where-clause (where database) + "ensure that we do not output a \"where\" sql keyword when we will + not output a clause. Also sets *in-subselect* to use SQL + parentheticals as needed." + (when where + (let ((where-out (string-trim + '(#\newline #\space #\tab #\return) + (with-output-to-string (*sql-stream*) + (let ((*in-subselect* t)) + (output-sql where database)))))) + (when (> (length where-out) 0) + (write-string " WHERE " *sql-stream*) + (write-string where-out *sql-stream*))))) + +(defmethod output-sql ((query sql-query) database) + (with-slots (distinct selections from where group-by having order-by + limit offset inner-join on all set-operation) + query + (when *in-subselect* + (write-string "(" *sql-stream*)) + (write-string "SELECT " *sql-stream*) + (when all + (write-string " ALL " *sql-stream*)) + (when (and distinct (not all)) + (write-string " DISTINCT " *sql-stream*) + (unless (eql t distinct) + (write-string " ON " *sql-stream*) + (output-sql distinct database) + (write-char #\Space *sql-stream*))) + (when (and limit (eql :mssql (database-underlying-type database))) + (write-string " TOP " *sql-stream*) + (output-sql limit database) + (write-string " " *sql-stream*)) + (let ((*in-subselect* t)) + (output-sql (apply #'vector selections) database)) + (when from + (write-string " FROM " *sql-stream*) + (typecase from + (list (output-sql + (apply #'vector + (remove-duplicates from :test #'database-identifier-equal)) + database)) + (string (write-string + (escaped-database-identifier from database) + *sql-stream*)) + (t (let ((*in-subselect* t)) + (output-sql from database))))) + (when inner-join + (write-string " INNER JOIN " *sql-stream*) + (output-sql inner-join database)) + (when on + (write-string " ON " *sql-stream*) + (output-sql on database)) + (output-sql-where-clause where database) + (when group-by + (write-string " GROUP BY " *sql-stream*) + (if (listp group-by) + (do ((order group-by (cdr order))) + ((null order)) + (let ((item (car order))) + (typecase item + (cons + (output-sql (car item) database) + (format *sql-stream* " ~A" (cadr item))) + (t + (output-sql item database))) + (when (cdr order) + (write-char #\, *sql-stream*)))) + (output-sql group-by database))) + (when having + (write-string " HAVING " *sql-stream*) + (output-sql having database)) + (when order-by + (write-string " ORDER BY " *sql-stream*) + (if (listp order-by) + (do ((order order-by (cdr order))) + ((null order)) + (let ((item (car order))) + (typecase item + (cons + (output-sql (car item) database) + (format *sql-stream* " ~A" (cadr item))) + (t + (output-sql item database))) + (when (cdr order) + (write-char #\, *sql-stream*)))) + (output-sql order-by database))) + (when (and limit (not (eql :mssql (database-underlying-type database)))) + (write-string " LIMIT " *sql-stream*) + (output-sql limit database)) + (when offset + (write-string " OFFSET " *sql-stream*) + (output-sql offset database)) + (when *in-subselect* + (write-string ")" *sql-stream*)) + (when set-operation + (write-char #\Space *sql-stream*) + (output-sql set-operation database))) + t) + +(defmethod output-sql ((query sql-object-query) database) + (declare (ignore database)) + (with-slots (objects) + query + (when objects + (format *sql-stream* "(~{~A~^ ~})" objects)))) + + +;; INSERT + +(defclass sql-insert (%sql-expression) + ((into + :initarg :into + :initform nil) + (attributes + :initarg :attributes + :initform nil) + (values + :initarg :values + :initform nil) + (query + :initarg :query + :initform nil)) + (:documentation + "An SQL INSERT statement.")) + +(defmethod output-sql ((ins sql-insert) database) + (with-slots (into attributes values query) + ins + (write-string "INSERT INTO " *sql-stream*) + (output-sql + (typecase into + (string (sql-expression :table into)) + (t into)) + database) + (when attributes + (write-char #\Space *sql-stream*) + (output-sql attributes database)) + (when values + (write-string " VALUES " *sql-stream*) + (let ((clsql-sys::*in-subselect* t)) + (output-sql values database))) + (when query + (write-char #\Space *sql-stream*) + (output-sql query database))) + t) + +;; DELETE + +(defclass sql-delete (%sql-expression) + ((from + :initarg :from + :initform nil) + (where + :initarg :where + :initform nil)) + (:documentation + "An SQL DELETE statement.")) + +(defmethod output-sql ((stmt sql-delete) database) + (with-slots (from where) + stmt + (write-string "DELETE FROM " *sql-stream*) + (typecase from + ((or symbol string) (write-string (sql-escape from) *sql-stream*)) + (t (output-sql from database))) + (output-sql-where-clause where database)) + t) + +;; UPDATE + +(defclass sql-update (%sql-expression) + ((table + :initarg :table + :initform nil) + (attributes + :initarg :attributes + :initform nil) + (values + :initarg :values + :initform nil) + (where + :initarg :where + :initform nil)) + (:documentation "An SQL UPDATE statement.")) + +(defmethod output-sql ((expr sql-update) database) + (with-slots (table where attributes values) + expr + (flet ((update-assignments () + (mapcar #'(lambda (a b) + (make-instance 'sql-assignment-exp + :operator '= + :sub-expressions (list a b))) + attributes values))) + (write-string "UPDATE " *sql-stream*) + (output-sql table database) + (write-string " SET " *sql-stream*) + (let ((clsql-sys::*in-subselect* t)) + (output-sql (apply #'vector (update-assignments)) database)) + (output-sql-where-clause where database))) + t) + +;; CREATE TABLE + +(defclass sql-create-table (%sql-expression) + ((name + :initarg :name + :initform nil) + (columns + :initarg :columns + :initform nil) + (modifiers + :initarg :modifiers + :initform nil) + (transactions + :initarg :transactions + :initform nil)) + (:documentation + "An SQL CREATE TABLE statement.")) + +;; Here's a real warhorse of a function! + +(declaim (inline listify)) +(defun listify (x) + (if (listp x) + x + (list x))) + +(defmethod output-sql ((stmt sql-create-table) database) + (flet ((output-column (column-spec) + (destructuring-bind (name type &optional db-type &rest constraints) + column-spec + (let ((type (listify type))) + (output-sql name database) + (write-char #\Space *sql-stream*) + (write-string + (if (stringp db-type) db-type ; override definition + (database-get-type-specifier (car type) (cdr type) database + (database-underlying-type database))) + *sql-stream*) + (let ((constraints (database-constraint-statement + (if (and db-type (symbolp db-type)) + (cons db-type constraints) + constraints) + database))) + (when constraints + (write-string " " *sql-stream*) + (write-string constraints *sql-stream*))))))) + (with-slots (name columns modifiers transactions) + stmt + (write-string "CREATE TABLE " *sql-stream*) + (write-string (escaped-database-identifier name database) *sql-stream*) + (write-string " (" *sql-stream*) + (do ((column columns (cdr column))) + ((null (cdr column)) + (output-column (car column))) + (output-column (car column)) + (write-string ", " *sql-stream*)) + (when modifiers + (do ((modifier (listify modifiers) (cdr modifier))) + ((null modifier)) + (write-string ", " *sql-stream*) + (write-string (car modifier) *sql-stream*))) + (write-char #\) *sql-stream*) + (when (and (eq :mysql (database-underlying-type database)) + transactions + (db-type-transaction-capable? :mysql database)) + (write-string " ENGINE=innodb" *sql-stream*)))) + t) + + +;; CREATE VIEW + +(defclass sql-create-view (%sql-expression) + ((name :initarg :name :initform nil) + (column-list :initarg :column-list :initform nil) + (query :initarg :query :initform nil) + (with-check-option :initarg :with-check-option :initform nil)) + (:documentation "An SQL CREATE VIEW statement.")) + +(defmethod output-sql ((stmt sql-create-view) database) + (with-slots (name column-list query with-check-option) stmt + (write-string "CREATE VIEW " *sql-stream*) + (output-sql name database) + (when column-list (write-string " " *sql-stream*) + (output-sql (listify column-list) database)) + (write-string " AS " *sql-stream*) + (output-sql query database) + (when with-check-option (write-string " WITH CHECK OPTION" *sql-stream*)))) + + +;; +;; DATABASE-OUTPUT-SQL +;; + +(defmethod database-output-sql ((str string) database) + (declare (optimize (speed 3) (safety 1) + #+cmu (extensions:inhibit-warnings 3))) + (let ((len (length str))) + (declare (type fixnum len)) + (cond ((zerop len) + +empty-string+) + ((and (null (position #\' str)) + (null (position #\\ str))) + (concatenate 'string "'" str "'")) + (t + (let ((buf (make-string (+ (* len 2) 2) :initial-element #\'))) + (declare (simple-string buf)) + (do* ((i 0 (incf i)) + (j 1 (incf j))) + ((= i len) (subseq buf 0 (1+ j))) + (declare (type fixnum i j)) + (let ((char (aref str i))) + (declare (character char)) + (cond ((char= char #\') + (setf (aref buf j) #\') + (incf j) + (setf (aref buf j) #\')) + ((and (char= char #\\) + ;; MTP: only escape backslash with pgsql/mysql + (member (database-underlying-type database) + '(:postgresql :mysql) + :test #'eq)) + (setf (aref buf j) #\\) + (incf j) + (setf (aref buf j) #\\)) + (t + (setf (aref buf j) char)))))))))) + +(let ((keyword-package (symbol-package :foo))) + (defmethod database-output-sql ((sym symbol) database) + (if (null sym) + +null-string+ + (if (equal (symbol-package sym) keyword-package) + (database-output-sql (symbol-name sym) database) + (escaped-database-identifier sym))))) + +(defmethod database-output-sql ((tee (eql t)) database) + (if database + (let ((val (database-output-sql-as-type 'boolean t database (database-type database)))) + (when val + (typecase val + (string (format nil "'~A'" val)) + (integer (format nil "~A" val))))) + "'Y'")) + +#+nil(defmethod database-output-sql ((tee (eql t)) database) + (declare (ignore database)) + "'Y'") + +(defmethod database-output-sql ((num number) database) + (declare (ignore database)) + (number-to-sql-string num)) + +(defmethod database-output-sql ((arg list) database) + (if (null arg) + +null-string+ + (format nil "(~{~A~^,~})" (mapcar #'(lambda (val) + (sql-output val database)) + arg)))) + +(defmethod database-output-sql ((arg vector) database) + (format nil "~{~A~^,~}" (map 'list #'(lambda (val) + (sql-output val database)) + arg))) + +(defmethod output-sql-hash-key ((arg vector) database) + (list 'vector (map 'list (lambda (arg) + (or (output-sql-hash-key arg database) + (return-from output-sql-hash-key nil))) + arg))) + +(defmethod database-output-sql ((self wall-time) database) + (declare (ignore database)) + (db-timestring self)) + +(defmethod database-output-sql ((self date) database) + (declare (ignore database)) + (db-datestring self)) + +(defmethod database-output-sql ((self duration) database) + (declare (ignore database)) + (format nil "'~a'" (duration-timestring self))) + +#+ignore +(defmethod database-output-sql ((self money) database) + (database-output-sql (slot-value self 'odcl::units) database)) + +(defmethod database-output-sql (thing database) + (if (or (null thing) + (eq 'null thing)) + +null-string+ + (error 'sql-user-error + :message + (format nil + "No type conversion to SQL for ~A is defined for DB ~A." + (type-of thing) (type-of database))))) + + +;; +;; Column constraint types and conversion to SQL +;; +(defmethod database-constraint-statement (constraint-list database) + (make-constraints-description constraint-list database)) + +;; KEEP THIS SYNCED WITH database-translate-constraint +(defparameter +auto-increment-names+ + '(:auto-increment :auto_increment :autoincrement :identity)) + +(defmethod database-translate-constraint (constraint database) + (case constraint + (:not-null "NOT NULL") + (:primary-key "PRIMARY KEY") + ((:auto-increment :auto_increment :autoincrement :identity) + (ecase (database-underlying-type database) + (:mssql "IDENTITY (1,1)") + ((:sqlite :sqlite3) "PRIMARY KEY AUTOINCREMENT") + (:mysql "AUTO_INCREMENT") + ;; this is modeled as a datatype instead of a constraint + (:postgresql ""))) + ;; everything else just get the name + (T (string-upcase (symbol-name constraint))))) + +(defun make-constraints-description (constraint-list database + &aux (rest constraint-list) constraint) + (when constraint-list + (flet ((next () + (setf constraint (first rest) + rest (rest rest)) + constraint)) + (with-output-to-string (s) + (loop while (next) + do (unless (keywordp constraint) + (setf constraint (intern (symbol-name constraint) :keyword))) + (write-string (database-translate-constraint constraint database) s) + (when (eql :default constraint) (princ (next) s)) + (write-char #\space s) + ))))) + +(defmethod database-identifier ( name &optional database find-class-p + &aux cls) + "A function that takes whatever you give it, recursively coerces it, + and returns a database-identifier. + + (escaped-database-identifiers *any-reasonable-object*) should be called to + produce a string that is safe to splice directly into sql strings. + + This function should NOT throw errors when database is nil + + find-class-p should be T if we want to search for classes + and check their use their view table. Should be used + on symbols we are sure indicate tables + + + ;; metaclasses has further typecases of this, so that it will + ;; load less painfully (try-recompiles) in SBCL + + " + (flet ((flatten-id (id) + "if we have multiple pieces that we need to represent as + db-id lets do that by rendering out the id, then creating + a new db-id with that string as escaped" + (let ((s (sql-output id database))) + (make-instance '%database-identifier :escaped s :unescaped s)))) + (setf name (dequote name)) + (etypecase name + (null nil) + (string (%make-database-identifier name database)) + (symbol + ;; if this is being used as a table, we should check + ;; for a class with this name and use the identifier specified + ;; on it + (if (and find-class-p (setf cls (find-standard-db-class name))) + (database-identifier cls) + (%make-database-identifier name database))) + (%database-identifier name) + ;; we know how to deref this without further escaping + (sql-ident-table + (with-slots ((inner-name name) alias) name + (if alias + (flatten-id name) + (database-identifier inner-name)))) + ;; if this is a single name we can derefence it + (sql-ident-attribute + (with-slots (qualifier (inner-name name)) name + (if qualifier + (flatten-id name) + (database-identifier inner-name)))) + (sql-ident + (with-slots ((inner-name name)) name + (database-identifier inner-name))) + ;; dont know how to handle this really :/ + (%sql-expression (flatten-id name)) + ))) + +(defun %clsql-subclauses (clauses) + "a helper for dealing with lists of sql clauses" + (loop for c in clauses + when c + collect (typecase c + (string (clsql-sys:sql-expression :string c)) + (T c)))) + +(defun clsql-ands (clauses) + "Correctly creates a sql 'and' expression for the clauses + ignores any nil clauses + returns a single child expression if there is only one + returns an 'and' expression if there are many + returns nil if there are no children" + (let ((ex (%clsql-subclauses clauses))) + (when ex + (case (length ex) + (1 (first ex)) + (t (apply #'clsql-sys:sql-and ex)))))) + +(defun clsql-and (&rest clauses) + "Correctly creates a sql 'and' expression for the clauses + ignores any nil clauses + returns a single child expression if there is only one + returns an 'and' expression if there are many + returns nil if there are no children" + (clsql-ands clauses)) + +(defun clsql-ors (clauses) + "Correctly creates a sql 'or' expression for the clauses + ignores any nil clauses + returns a single child expression if there is only one + returns an 'or' expression if there are many + returns nil if there are no children" + (let ((ex (%clsql-subclauses clauses))) + (when ex + (case (length ex) + (1 (first ex)) + (t (apply #'clsql-sys:sql-or ex)))))) + +(defun clsql-or (&rest clauses) + "Correctly creates a sql 'or' expression for the clauses + ignores any nil clauses + returns a single child expression if there is only one + returns an 'or' expression if there are many + returns nil if there are no children" + (clsql-ors clauses)) + + +(defclass sql-escape-string-exp (%sql-expression) + ((string + :initarg :string + :initform nil)) + (:documentation + "An escaped string string expression (postgresql E'stuff') .")) + +(defmethod output-sql ((exp sql-escape-string-exp) database) + (with-slots (string) exp + (when string + (write-char #\E *sql-stream*) + (output-sql string database)))) diff --git a/sql/fddl.lisp b/sql/fddl.lisp new file mode 100644 index 0000000..c4fc195 --- /dev/null +++ b/sql/fddl.lisp @@ -0,0 +1,437 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; +;;;; The CLSQL Functional Data Definition Language (FDDL) +;;;; including functions for schema manipulation. Currently supported +;;;; SQL objects include tables, views, indexes, attributes and +;;;; sequences. +;;;; +;;;; 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) + + +;; Truncate database + +(defun truncate-database (&key (database *default-database*)) + "Drops all tables, views, indexes and sequences in DATABASE which +defaults to *DEFAULT-DATABASE*." + (unless (typep database 'database) + (signal-no-database-error database)) + (unless (is-database-open database) + (database-reconnect database)) + (when (eq :oracle (database-type database)) + (ignore-errors (execute-command "PURGE RECYCLEBIN" :database database))) + (when (db-type-has-views? (database-underlying-type database)) + (dolist (view (list-views :database database)) + (drop-view view :database database))) + (dolist (table (list-tables :database database)) + (drop-table table :database database)) + (dolist (index (list-indexes :database database)) + (drop-index index :database database)) + (dolist (seq (list-sequences :database database)) + (drop-sequence seq :database database)) + (when (eq :oracle (database-type database)) + (ignore-errors (execute-command "PURGE RECYCLEBIN" :database database))) + (values)) + + +;; Tables + +(defun create-table (name description &key (database *default-database*) + (constraints nil) (transactions t)) + "Creates a table called NAME, which may be a string, symbol or +SQL table identifier, in DATABASE which defaults to +*DEFAULT-DATABASE*. DESCRIPTION is a list whose elements are +lists containing the attribute names, types, and other +constraints such as not-null or primary-key for each column in +the table. CONSTRAINTS is a string representing an SQL table +constraint expression or a list of such strings. With MySQL +databases, if TRANSACTIONS is t an InnoDB table is created which +supports transactions." + (execute-command + (make-instance 'sql-create-table + :name name + :columns description + :modifiers constraints + :transactions transactions) + :database database)) + +(defun drop-table (name &key (if-does-not-exist :error) + (database *default-database*) + (owner nil)) + "Drops the table called NAME from DATABASE which defaults to +*DEFAULT-DATABASE*. If the table does not exist and +IF-DOES-NOT-EXIST is :ignore then DROP-TABLE returns nil whereas +an error is signalled if IF-DOES-NOT-EXIST is :error." + (ecase if-does-not-exist + (:ignore + (unless (table-exists-p name :database database :owner owner) + (return-from drop-table nil))) + (:error + t)) + + (let ((expr (concatenate 'string "DROP TABLE " (escaped-database-identifier name database)))) + ;; Fixme: move to clsql-oracle + (when (and (find-package 'clsql-oracle) + (eq :oracle (database-type database)) + (eql 10 (slot-value database + (intern (symbol-name '#:major-server-version) + (symbol-name '#:clsql-oracle))))) + (setq expr (concatenate 'string expr " PURGE"))) + + (execute-command expr :database database))) + +(defun list-tables (&key (owner nil) (database *default-database*)) + "Returns a list of strings representing table names in DATABASE +which defaults to *DEFAULT-DATABASE*. OWNER is nil by default +which means that only tables owned by users are listed. If OWNER +is a string denoting a user name, only tables owned by OWNER are +listed. If OWNER is :all then all tables are listed." + (database-list-tables database :owner owner)) + +(defmethod %table-exists-p (name (database T) &key owner ) + (unless database (setf database *default-database*)) + (let ((name (database-identifier name database)) + (tables (list-tables :owner owner :database database))) + (when (member name tables :test #'database-identifier-equal) + t))) + +(defun table-exists-p (name &key (owner nil) (database *default-database*)) + "Tests for the existence of an SQL table called NAME in DATABASE +which defaults to *DEFAULT-DATABASE*. OWNER is nil by default +which means that only tables owned by users are examined. If +OWNER is a string denoting a user name, only tables owned by +OWNER are examined. If OWNER is :all then all tables are +examined." + (%table-exists-p name database :owner owner)) + + +;; Views + +(defun create-view (name &key as column-list (with-check-option nil) + (database *default-database*)) + "Creates a view called NAME in DATABASE which defaults to +*DEFAULT-DATABASE*. The view is created using the query AS and +the columns of the view may be specified using the COLUMN-LIST +parameter. The WITH-CHECK-OPTION is nil by default but if it has +a non-nil value, then all insert/update commands on the view are +checked to ensure that the new data satisfy the query AS." + (let* ((view-name (database-identifier name)) + (stmt (make-instance 'sql-create-view + :name view-name + :column-list column-list + :query as + :with-check-option with-check-option))) + (execute-command stmt :database database))) + +(defun drop-view (name &key (if-does-not-exist :error) + (database *default-database*)) + "Drops the view called NAME from DATABASE which defaults to +*DEFAULT-DATABASE*. If the view does not exist and +IF-DOES-NOT-EXIST is :ignore then DROP-VIEW returns nil whereas +an error is signalled if IF-DOES-NOT-EXIST is :error." + (ecase if-does-not-exist + (:ignore + (unless (view-exists-p name :database database) + (return-from drop-view))) + (:error + t)) + (let ((expr (concatenate 'string "DROP VIEW " (escaped-database-identifier name database)))) + (execute-command expr :database database))) + +(defun list-views (&key (owner nil) (database *default-database*)) + "Returns a list of strings representing view names in DATABASE +which defaults to *DEFAULT-DATABASE*. OWNER is nil by default +which means that only views owned by users are listed. If OWNER +is a string denoting a user name, only views owned by OWNER are +listed. If OWNER is :all then all views are listed." + (database-list-views database :owner owner)) + +(defun view-exists-p (name &key (owner nil) (database *default-database*)) + "Tests for the existence of an SQL view called NAME in DATABASE +which defaults to *DEFAULT-DATABASE*. OWNER is nil by default +which means that only views owned by users are examined. If OWNER +is a string denoting a user name, only views owned by OWNER are +examined. If OWNER is :all then all views are examined." + (when (member (database-identifier name database) + (list-views :owner owner :database database) + :test #'database-identifier-equal) + t)) + + +;; Indexes + +(defun create-index (name &key on (unique nil) attributes + (database *default-database*)) + "Creates an index called NAME on the table specified by ON in +DATABASE which default to *DEFAULT-DATABASE*. The table +attributes to use in constructing the index NAME are specified by +ATTRIBUTES. The UNIQUE argument is nil by default but if it has a +non-nil value then the indexed attributes must have unique +values." + (let* ((index-name (escaped-database-identifier name database)) + (table-name (escaped-database-identifier on database)) + (attributes (mapcar #'(lambda (a) (escaped-database-identifier a database)) + (listify attributes))) + (stmt (format nil "CREATE ~A INDEX ~A ON ~A (~{~A~^, ~})" + (if unique "UNIQUE" "") + index-name table-name attributes))) + (execute-command stmt :database database))) + +(defun drop-index (name &key (if-does-not-exist :error) + (on nil) + (database *default-database*)) + "Drops the index called NAME in DATABASE which defaults to +*DEFAULT-DATABASE*. If the index does not exist and +IF-DOES-NOT-EXIST is :ignore then DROP-INDEX returns nil whereas +an error is signalled if IF-DOES-NOT-EXIST is :error. The +argument ON allows the optional specification of a table to drop +the index from." + (ecase if-does-not-exist + (:ignore + (unless (index-exists-p name :database database) + (return-from drop-index))) + (:error t)) + (let* ((db-type (database-underlying-type database)) + (on (when on (escaped-database-identifier on database))) + (index-name (escaped-database-identifier name database)) + (index-identifier + (cond ((db-type-use-fully-qualified-column-on-drop-index? db-type) + (format nil "~A.~A" on index-name)) + ((db-type-use-column-on-drop-index? db-type) + (format nil "~A ON ~A" index-name on)) + (t index-name)))) + (execute-command (format nil "DROP INDEX ~A" index-identifier) + :database database))) + +(defun list-indexes (&key (owner nil) (database *default-database*) (on nil)) + "Returns a list of strings representing index names in DATABASE +which defaults to *DEFAULT-DATABASE*. OWNER is nil by default +which means that only indexes owned by users are listed. If OWNER +is a string denoting a user name, only indexes owned by OWNER are +listed. If OWNER is :all then all indexes are listed. The keyword +argument ON limits the results to indexes on the specified +tables. Meaningful values for ON are nil (the default) which +means that all tables are considered, a string, symbol or SQL +expression representing a table name in DATABASE or a list of +such table identifiers." + (if (null on) + (database-list-indexes database :owner owner) + (let ((tables (typecase on + (cons on) + (t (list on))))) + (reduce + #'append + (mapcar #'(lambda (table) + (database-list-table-indexes table database :owner owner)) + tables))))) + +(defun index-exists-p (name &key (owner nil) (database *default-database*)) + "Tests for the existence of an SQL index called NAME in DATABASE +which defaults to *DEFAULT-DATABASE*. OWNER is nil by default +which means that only indexes owned by users are examined. If +OWNER is a string denoting a user name, only indexes owned by +OWNER are examined. If OWNER is :all then all indexes are +examined." + (when (member (database-identifier name database) + (list-indexes :owner owner :database database) + :test #'database-identifier-equal) + t)) + +;; Attributes + +(defvar *cache-table-queries-default* nil + "Specifies the default behaivour for caching of attribute + types. Meaningful values are t, nil and :flush as described for + the action argument to CACHE-TABLE-QUERIES.") + +(defun cache-table-queries (table &key (action nil) (database *default-database*)) + "Controls the caching of attribute type information on the +table specified by TABLE in DATABASE which defaults to +*DEFAULT-DATABASE*. ACTION specifies the caching behaviour to +adopt. If its value is t then attribute type information is +cached whereas if its value is nil then attribute type +information is not cached. If ACTION is :flush then all existing +type information in the cache for TABLE is removed, but caching +is still enabled. TABLE may be a string representing a table for +which the caching action is to be taken while the caching action +is applied to all tables if TABLE is t. Alternativly, when TABLE +is :default, the default caching action specified by +*CACHE-TABLE-QUERIES-DEFAULT* is applied to all table for which a +caching action has not been explicitly set." + (with-slots (attribute-cache) database + (cond + ((stringp table) + (multiple-value-bind (val found) (gethash table attribute-cache) + (cond + ((and found (eq action :flush)) + (setf (gethash table attribute-cache) (list t nil))) + ((and found (eq action t)) + (setf (gethash table attribute-cache) (list t (second val)))) + ((and found (null action)) + (setf (gethash table attribute-cache) (list nil nil))) + ((not found) + (setf (gethash table attribute-cache) (list action nil)))))) + ((eq table t) + (maphash (lambda (k v) + (cond + ((eq action :flush) + (setf (gethash k attribute-cache) (list t nil))) + ((null action) + (setf (gethash k attribute-cache) (list nil nil))) + ((eq t action) + (setf (gethash k attribute-cache) (list t (second v)))))) + attribute-cache)) + ((eq table :default) + (maphash (lambda (k v) + (when (eq (first v) :unspecified) + (cond + ((eq action :flush) + (setf (gethash k attribute-cache) (list t nil))) + ((null action) + (setf (gethash k attribute-cache) (list nil nil))) + ((eq t action) + (setf (gethash k attribute-cache) (list t (second v))))))) + attribute-cache)))) + (values)) + + +(defun list-attributes (name &key (owner nil) (database *default-database*)) + "Returns a list of strings representing the attributes of table +NAME in DATABASE which defaults to *DEFAULT-DATABASE*. OWNER is +nil by default which means that only attributes owned by users +are listed. If OWNER is a string denoting a user name, only +attributes owned by OWNER are listed. If OWNER is :all then all +attributes are listed." + (database-list-attributes + (database-identifier name database) + database + :owner owner)) + +(defun attribute-type (attribute table &key (owner nil) + (database *default-database*)) + "Returns a keyword representing the vendor-specific field type +of the supplied attribute ATTRIBUTE in the table specified by +TABLE in DATABASE which defaults to *DEFAULT-DATABASE*. OWNER is +nil by default which means that the attribute specified by +ATTRIBUTE, if it exists, must be user owned else nil is +returned. If OWNER is a string denoting a user name, the +attribute, if it exists, must be owned by OWNER else nil is +returned, whereas if OWNER is :all then the attribute, if it +exists, will be returned regardless of its owner." + (database-attribute-type (database-identifier attribute database) + (database-identifier table database) + database + :owner owner)) + +(defun list-attribute-types (table &key (owner nil) + (database *default-database*)) + "Returns a list containing information about the SQL types of +each of the attributes in the table specified by TABLE in +DATABASE which has a default value of *DEFAULT-DATABASE*. OWNER +is nil by default which means that only attributes owned by users +are listed. If OWNER is a string denoting a user name, only +attributes owned by OWNER are listed. If OWNER is :all then all +attributes are listed. The elements of the returned list are +lists where the first element is the name of the attribute, the +second element is its SQL type, the third is the type precision, +the fourth is the scale of the attribute and the fifth is 1 if +the attribute accepts null values and otherwise 0." + (with-slots (attribute-cache) database + (let ((table-ident (database-identifier table database))) + (multiple-value-bind (val found) + (gethash table attribute-cache) + (if (and found (second val)) + (second val) + (let ((types (mapcar #'(lambda (attribute) + (cons attribute + (multiple-value-list + (database-attribute-type + (database-identifier attribute + database) + table-ident + database + :owner owner)))) + (list-attributes table :database database + :owner owner)))) + (cond + ((and (not found) (eq t *cache-table-queries-default*)) + (setf (gethash table attribute-cache) + (list :unspecified types))) + ((and found (eq t (first val)) + (setf (gethash table attribute-cache) + (list t types))))) + types)))))) + + +;; Sequences + +(defun create-sequence (name &key (database *default-database*)) + "Creates a sequence called NAME in DATABASE which defaults to +*DEFAULT-DATABASE*." + (let ((sequence-name (database-identifier name database))) + (database-create-sequence sequence-name database)) + (values)) + +(defun drop-sequence (name &key (if-does-not-exist :error) + (database *default-database*)) + "Drops the sequence called NAME from DATABASE which defaults to +*DEFAULT-DATABASE*. If the sequence does not exist and +IF-DOES-NOT-EXIST is :ignore then DROP-SEQUENCE returns nil +whereas an error is signalled if IF-DOES-NOT-EXIST is :error." + (ecase if-does-not-exist + (:ignore + (unless (sequence-exists-p name :database database) + (return-from drop-sequence))) + (:error t)) + (database-drop-sequence name database) + (values)) + +(defun list-sequences (&key (owner nil) (database *default-database*)) + "Returns a list of strings representing sequence names in +DATABASE which defaults to *DEFAULT-DATABASE*. OWNER is nil by +default which means that only sequences owned by users are +listed. If OWNER is a string denoting a user name, only sequences +owned by OWNER are listed. If OWNER is :all then all sequences +are listed." + (database-list-sequences database :owner owner)) + +(defun sequence-exists-p (name &key (owner nil) + (database *default-database*)) + "Tests for the existence of an SQL sequence called NAME in +DATABASE which defaults to *DEFAULT-DATABASE*. OWNER is nil by +default which means that only sequences owned by users are +examined. If OWNER is a string denoting a user name, only +sequences owned by OWNER are examined. If OWNER is :all then all +sequences are examined." + (let ((seqs (list-sequences :owner owner :database database)) + ;; handle symbols, we know the db will return strings + (n1 (database-identifier name database)) + (n2 (%sequence-name-to-table name database))) + (when (or (member n1 seqs :test #'database-identifier-equal) + (member n2 seqs :test #'database-identifier-equal)) + t))) + +(defun sequence-next (name &key (database *default-database*)) + "Increment and return the next value in the sequence called + NAME in DATABASE which defaults to *DEFAULT-DATABASE*." + (database-sequence-next (database-identifier name database) database)) + +(defun set-sequence-position (name position &key (database *default-database*)) + "Explicitly set the the position of the sequence called NAME in +DATABASE, which defaults to *DEFAULT-DATABASE*, to POSITION which +is returned." + (database-set-sequence-position (database-identifier name database) + position database)) + +(defun sequence-last (name &key (database *default-database*)) + "Return the last value allocated in the sequence called NAME in DATABASE + which defaults to *DEFAULT-DATABASE*." + (database-sequence-last (database-identifier name database) database)) + diff --git a/sql/fdml.lisp b/sql/fdml.lisp new file mode 100644 index 0000000..5e248ce --- /dev/null +++ b/sql/fdml.lisp @@ -0,0 +1,515 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; +;;;; The CLSQL Functional Data Manipulation Language (FDML). +;;;; +;;;; 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) + +;; some helpers to make dealing with attribute-value-pairs a bit more structured +(defclass attribute-value-pair () + ((attribute :accessor attribute :initarg :attribute :initform nil) + (db-value :accessor db-value :initarg :db-value :initform nil)) + (:documentation "Represents an attribute-sql-expression and its value, used + to pass to insert/update. Was previously a two list")) + +(defun make-attribute-value-pair (slot-def value database) + (check-slot-type slot-def value) + (make-instance + 'attribute-value-pair + :attribute (sql-expression :attribute (database-identifier slot-def database)) + :db-value (db-value-from-slot slot-def value database))) + +(defun to-attributes-and-values (av-pairs) + (etypecase (first av-pairs) + (list + (loop for (a v) in av-pairs + collect a into attributes + collect v into db-values + finally (return (values attributes db-values)))) + (attribute-value-pair + (loop for pair in av-pairs + collecting (attribute pair) into attributes + collecting (db-value pair) into db-values + finally (return (values attributes db-values)))))) + +;;; Basic operations on databases + +(defmethod database-query-result-set ((expr %sql-expression) database + &key full-set result-types) + (database-query-result-set (sql-output expr database) database + :full-set full-set :result-types result-types)) + +(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)) + +(defmethod execute-command ((expr %sql-expression) + &key (database *default-database*)) + (execute-command (sql-output expr database) :database database) + (values)) + +(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)))) + +(defmethod query ((expr %sql-expression) &key (database *default-database*) + (result-types :auto) (flatp nil) (field-names t)) + (query (sql-output expr database) :database database :flatp flatp + :result-types result-types :field-names field-names)) + +(defmethod query ((expr sql-object-query) &key (database *default-database*) + (result-types :auto) (flatp nil) (field-names t)) + (declare (ignore result-types field-names)) + (apply #'select (append (slot-value expr 'objects) + (slot-value expr 'exp) + (when (slot-value expr 'refresh) + (list :refresh (sql-output expr database))) + (when (or flatp (slot-value expr 'flatp) ) + (list :flatp t)) + (list :database database)))) + + +(defun print-query (query-exp &key titles (formats t) (sizes t) (stream t) + (database *default-database*)) + "Prints a tabular report of the results returned by the SQL +query QUERY-EXP, which may be a symbolic SQL expression or a +string, in DATABASE which defaults to *DEFAULT-DATABASE*. The +report is printed onto STREAM which has a default value of t +which means that *STANDARD-OUTPUT* is used. The TITLE argument, +which defaults to nil, allows the specification of a list of +strings to use as column titles in the tabular output. SIZES +accepts a list of column sizes, one for each column selected by +QUERY-EXP, to use in formatting the tabular report. The default +value of t means that minimum sizes are computed. FORMATS is a +list of format strings to be used for printing each column +selected by QUERY-EXP. The default value of FORMATS is t meaning +that ~A is used to format all columns or ~VA if column sizes are +used." + (flet ((compute-sizes (data) + (mapcar #'(lambda (x) + (apply #'max (mapcar #'(lambda (y) + (if (null y) 3 (length y))) + x))) + (apply #'mapcar (cons #'list data)))) + (format-record (record control sizes) + (format stream "~&~?" control + (if (null sizes) record + (mapcan #'(lambda (s f) (list s f)) sizes record))))) + (let* ((query-exp (etypecase query-exp + (string query-exp) + (sql-query (sql-output query-exp database)))) + (data (query query-exp :database database :result-types nil + :field-names nil)) + (sizes (if (or (null sizes) (listp sizes)) sizes + (compute-sizes (if titles (cons titles data) data)))) + (formats (if (or (null formats) (not (listp formats))) + (make-list (length (car data)) :initial-element + (if (null sizes) "~A " "~VA ")) + formats)) + (control-string (format nil "~{~A~}" formats))) + (when titles (format-record titles control-string sizes)) + (dolist (d data (values)) (format-record d control-string sizes))))) + +(defun insert-records (&key (into nil) + (attributes nil) + (values nil) + (av-pairs nil) + (query nil) + (database *default-database*)) + "Inserts records into the table specified by INTO in DATABASE +which defaults to *DEFAULT-DATABASE*. There are five ways of +specifying the values inserted into each row. + +In the first VALUES contains a list of values to insert and ATTRIBUTES, +AV-PAIRS and QUERY are nil. This can be used when values are supplied for all +attributes in INTO. + +In the second, ATTRIBUTES is a list of column names, VALUES is a corresponding +list of values and AV-PAIRS and QUERY are nil. + +In the third, ATTRIBUTES, VALUES and QUERY are nil and AV-PAIRS is a list +of (attribute value) pairs, or attribute-value-pair objects. + +In the fourth, VALUES, AV-PAIRS and ATTRIBUTES are nil and QUERY is a symbolic +SQL query expression in which the selected columns also exist in INTO. + +In the fifth method, VALUES and AV-PAIRS are nil and ATTRIBUTES is a list of +column names and QUERY is a symbolic SQL query expression which returns values +for the specified columns." + (let ((stmt (make-sql-insert :into into :attrs attributes + :vals values :av-pairs av-pairs + :subquery query))) + (execute-command stmt :database database))) + +(defun make-sql-insert (&key (into nil) + (attrs nil) + (vals nil) + (av-pairs nil) + (subquery nil)) + (unless into + (error 'sql-user-error :message ":into keyword not supplied")) + (let ((insert (make-instance 'sql-insert :into (database-identifier into nil)))) + (with-slots (attributes values query) insert + + (cond ((and vals (not attrs) (not query) (not av-pairs)) + (setf values vals)) + + ((and vals attrs (not subquery) (not av-pairs)) + (setf attributes attrs) + (setf values vals)) + + ((and av-pairs (not vals) (not attrs) (not subquery)) + (multiple-value-setq (attributes values) + (to-attributes-and-values av-pairs))) + + ((and subquery (not vals) (not attrs) (not av-pairs)) + (setf query subquery)) + + ((and subquery attrs (not vals) (not av-pairs)) + (setf attributes attrs) + (setf query subquery)) + + (t (error 'sql-user-error + :message "bad or ambiguous keyword combination."))) + insert))) + +(defun delete-records (&key (from nil) + (where nil) + (database *default-database*)) + "Deletes records satisfying the SQL expression WHERE from the +table specified by FROM in DATABASE specifies a database which +defaults to *DEFAULT-DATABASE*." + (let ((stmt (make-instance 'sql-delete :from (database-identifier from database) :where where))) + (execute-command stmt :database database))) + +(defun update-records (table &key (attributes nil) + (values nil) + (av-pairs nil) + (where nil) + (database *default-database*)) + "Updates the attribute values of existing records satsifying +the SQL expression WHERE in the table specified by TABLE in +DATABASE which defaults to *DEFAULT-DATABASE*. There are three +ways of specifying the values to update for each row. In the +first, VALUES contains a list of values to use in the update and +ATTRIBUTES and AV-PAIRS are nil. This can be used when values are +supplied for all attributes in TABLE. In the second, ATTRIBUTES +is a list of column names, VALUES is a corresponding list of +values and AV-PAIRS is nil. In the third, ATTRIBUTES and VALUES +are nil and AV-PAIRS is an alist of (attribute value) pairs." + (when av-pairs + (multiple-value-setq (attributes values) + (to-attributes-and-values av-pairs))) + (let ((stmt (make-instance 'sql-update :table (database-identifier table database) + :attributes attributes + :values values + :where where))) + (execute-command stmt :database database))) + + +;;; Iteration + +(defmacro do-query (((&rest args) query-expression + &key (database '*default-database*) (result-types :auto)) + &body body) + "Repeatedly executes BODY within a binding of ARGS on the +fields of each row selected by the SQL query QUERY-EXPRESSION, +which may be a string or a symbolic SQL expression, in DATABASE +which defaults to *DEFAULT-DATABASE*. The values returned by the +execution of BODY are returned. RESULT-TYPES is a list of symbols +which specifies the lisp type for each field returned by +QUERY-EXPRESSION. If RESULT-TYPES is nil all results are returned +as strings whereas the default value of :auto means that the lisp +types are automatically computed for each field." + (let ((result-set (gensym "RESULT-SET-")) + (qe (gensym "QUERY-EXPRESSION-")) + (columns (gensym "COLUMNS-")) + (row (gensym "ROW-")) + (db (gensym "DB-")) + (last-form-eval (gensym "LFE-"))) + `(let ((,qe ,query-expression) + (,db ,database)) + (typecase ,qe + (sql-object-query + (dolist (,row (query ,qe :database ,db)) + (destructuring-bind ,args + ,row + ,@body))) + (t + ;; Functional query + (multiple-value-bind (,result-set ,columns) + (database-query-result-set ,qe ,db + :full-set nil + :result-types ,result-types) + (when ,result-set + (unwind-protect + (do ((,row (make-list ,columns)) + (,last-form-eval nil)) + ((not (database-store-next-row ,result-set ,db ,row)) + ,last-form-eval) + (destructuring-bind ,args ,row + (setq ,last-form-eval + (progn + ,@body)))) + (database-dump-result-set ,result-set ,db))))))))) + +(defun map-query (output-type-spec function query-expression + &key (database *default-database*) + (result-types :auto)) + "Map the function FUNCTION over the attribute values of each +row selected by the SQL query QUERY-EXPRESSION, which may be a +string or a symbolic SQL expression, in DATABASE which defaults +to *DEFAULT-DATABASE*. The results of the function are collected +as specified in OUTPUT-TYPE-SPEC and returned like in +MAP. RESULT-TYPES is a list of symbols which specifies the lisp +type for each field returned by QUERY-EXPRESSION. If RESULT-TYPES +is nil all results are returned as strings whereas the default +value of :auto means that the lisp types are automatically +computed for each field." + (typecase query-expression + (sql-object-query + (map output-type-spec #'(lambda (x) (apply function x)) + (query query-expression))) + (t + ;; Functional query + (macrolet ((type-specifier-atom (type) + `(if (atom ,type) ,type (car ,type)))) + (case (type-specifier-atom output-type-spec) + ((nil) + (map-query-for-effect function query-expression database + result-types)) + (list + (map-query-to-list function query-expression database result-types)) + ((simple-vector simple-string vector string array simple-array + bit-vector simple-bit-vector base-string + simple-base-string) + (map-query-to-simple output-type-spec function query-expression + database result-types)) + (t + (funcall #'map-query + (cmucl-compat:result-type-or-lose output-type-spec t) + function query-expression :database database + :result-types result-types))))))) + +(defun map-query-for-effect (function query-expression database result-types) + (multiple-value-bind (result-set columns) + (database-query-result-set query-expression database :full-set nil + :result-types result-types) + (let ((flatp (and (= columns 1) + (typep query-expression 'sql-query) + (slot-value query-expression 'flatp)))) + (when result-set + (unwind-protect + (do ((row (make-list columns))) + ((not (database-store-next-row result-set database row)) + nil) + (if flatp + (apply function row) + (funcall function row))) + (database-dump-result-set result-set database)))))) + +(defun map-query-to-list (function query-expression database result-types) + (multiple-value-bind (result-set columns) + (database-query-result-set query-expression database :full-set nil + :result-types result-types) + (let ((flatp (and (= columns 1) + (typep query-expression 'sql-query) + (slot-value query-expression 'flatp)))) + (when result-set + (unwind-protect + (let ((result (list nil))) + (do ((row (make-list columns)) + (current-cons result (cdr current-cons))) + ((not (database-store-next-row result-set database row)) + (cdr result)) + (rplacd current-cons + (list (if flatp + (apply function row) + (funcall function (copy-list row))))))) + (database-dump-result-set result-set database)))))) + +(defun map-query-to-simple (output-type-spec function query-expression database result-types) + (multiple-value-bind (result-set columns rows) + (database-query-result-set query-expression database :full-set t + :result-types result-types) + (let ((flatp (and (= columns 1) + (typep query-expression 'sql-query) + (slot-value query-expression 'flatp)))) + (when result-set + (unwind-protect + (if rows + ;; We know the row count in advance, so we allocate once + (do ((result + (cmucl-compat:make-sequence-of-type output-type-spec rows)) + (row (make-list columns)) + (index 0 (1+ index))) + ((not (database-store-next-row result-set database row)) + result) + (declare (fixnum index)) + (setf (aref result index) + (if flatp + (apply function row) + (funcall function (copy-list row))))) + ;; Database can't report row count in advance, so we have + ;; to grow and shrink our vector dynamically + (do ((result + (cmucl-compat:make-sequence-of-type output-type-spec 100)) + (allocated-length 100) + (row (make-list columns)) + (index 0 (1+ index))) + ((not (database-store-next-row result-set database row)) + (cmucl-compat:shrink-vector result index)) + (declare (fixnum allocated-length index)) + (when (>= index allocated-length) + (setq allocated-length (* allocated-length 2) + result (adjust-array result allocated-length))) + (setf (aref result index) + (if flatp + (apply function row) + (funcall function (copy-list 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)))))) + + +;;; 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)) + + +;;; Prepared statements + +(defun prepare-sql (sql-stmt types &key (database *default-database*) (result-types :auto) field-names) + "Prepares a SQL statement for execution. TYPES contains a +list of types corresponding to the input parameters. Returns a +prepared-statement object. + +A type can be + :int + :double + :null + (:blob n) + (:string n) +" + (unless (db-type-has-prepared-stmt? (database-type database)) + (error 'sql-user-error + :message + (format nil + "Database backend type ~:@(~A~) does not support prepared statements." + (database-type database)))) + + (database-prepare sql-stmt types database result-types field-names)) + +(defun bind-parameter (prepared-stmt position value) + "Sets the value of a parameter is in prepared statement." + (database-bind-parameter prepared-stmt position value) + value) + +(defun run-prepared-sql (prepared-stmt) + "Execute the prepared sql statment. All input parameters must be bound." + (database-run-prepared prepared-stmt)) + +(defun free-prepared-sql (prepared-stmt) + "Delete the objects associated with a prepared statement." + (database-free-prepared prepared-stmt)) diff --git a/sql/generic-odbc.lisp b/sql/generic-odbc.lisp new file mode 100644 index 0000000..706e4cf --- /dev/null +++ b/sql/generic-odbc.lisp @@ -0,0 +1,263 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; +;;;; Generic ODBC layer, used by db-odbc and db-aodbc backends +;;;; +;;;; 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 generic-odbc-database (database) + ((dbi-package :initarg :dbi-package :reader dbi-package) + (odbc-conn :initarg :odbc-conn :initform nil :accessor odbc-conn) + (disconnect-fn :reader disconnect-fn) + (sql-fn :reader sql-fn) + (close-query-fn :reader close-query-fn) + (fetch-row :reader fetch-row-fn) + (list-all-database-tables-fn :reader list-all-database-tables-fn) + (list-all-table-columns-fn :reader list-all-table-columns-fn) + (odbc-db-type :accessor database-odbc-db-type :initarg :odbc-db-type )) + (:documentation "Encapsulate same behavior across odbc and aodbc backends.")) + +(defmethod initialize-instance :after ((db generic-odbc-database) + &rest all-keys) + (declare (ignore all-keys)) + (unless (slot-boundp db 'dbi-package) + (error "dbi-package not specified.")) + (let ((pkg (slot-value db 'dbi-package))) + (unless pkg + (error "dbi-package is nil.")) + (setf (slot-value db 'disconnect-fn) + (intern (symbol-name '#:disconnect) pkg) + (slot-value db 'sql-fn) + (intern (symbol-name '#:sql) pkg) + (slot-value db 'close-query-fn) + (intern (symbol-name '#:close-query) pkg) + (slot-value db 'fetch-row) + (intern (symbol-name '#:fetch-row) pkg) + (slot-value db 'list-all-database-tables-fn) + (intern (symbol-name '#:list-all-database-tables) pkg) + (slot-value db 'list-all-table-columns-fn) + (intern (symbol-name '#:list-all-table-columns) pkg)))) + +;;; Type methods + +(defmethod database-get-type-specifier ((type symbol) args database + (db-type (eql :mssql))) + "Special database types for MSSQL backends" + (declare (ignore database db-type args)) + (case type + (wall-time "DATETIME") + (date "SMALLDATETIME") + ((generalized-boolean boolean) "BIT") + ((longchar text) "ntext") + ((varchar string) + (if args + (format nil "NVARCHAR(~A)" (car args)) + (format nil "NVARCHAR(~D)" *default-string-length*))) + (t (call-next-method)))) + +;;; Generation of SQL strings from lisp expressions + +(defmethod database-output-sql ((tee (eql t)) (database generic-odbc-database)) + (case (database-underlying-type database) + (:mssql "1") + (t "'Y'"))) + +;;; Database backend capabilities + +(defmethod db-type-use-fully-qualified-column-on-drop-index? ((db-type (eql :mssql))) + t) + +(defmethod db-type-has-boolean-where? ((db-type (eql :mssql))) + nil) + +(defmethod db-type-has-intersect? ((db-type (eql :mssql))) + nil) + +(defmethod db-type-has-except? ((db-type (eql :mssql))) + nil) + +;;; Backend methods + +(defmethod database-disconnect ((database generic-odbc-database)) + (funcall (disconnect-fn database) (odbc-conn database)) + (setf (odbc-conn database) nil) + t) + +(defmethod database-query (query-expression (database generic-odbc-database) + result-types field-names) + (handler-case + (funcall (sql-fn database) + query-expression :db (odbc-conn database) + :result-types result-types + :column-names field-names) + #+ignore + (error () + (error 'sql-database-data-error + :database database + :expression query-expression + :message "Query failed")))) + + +(defmethod database-execute-command (sql-expression (database generic-odbc-database)) + (handler-case + (funcall (sql-fn database) + sql-expression :db (odbc-conn database)) + #+ignore + (sql-error (e) + (error e)) + #+ignore + (error () + (error 'sql-database-data-error + :database database + :expression sql-expression + :message "Execute command failed")))) + + +(defstruct odbc-result-set + (query nil) + (types nil) + (full-set nil :type boolean)) + + + + +(defmethod database-query-result-set ((query-expression string) + (database generic-odbc-database) + &key full-set result-types) + (handler-case + (multiple-value-bind (query column-names) + (funcall (sql-fn database) + query-expression + :db (odbc-conn database) + :row-count nil + :column-names t + :query t + :result-types result-types) + (values + (make-odbc-result-set :query query :full-set full-set + :types result-types) + (length column-names) + nil ;; not able to return number of rows with odbc + )) + (error () + (error 'sql-database-data-error + :database database + :expression query-expression + :message "Query result set failed")))) + +(defmethod database-dump-result-set (result-set (database generic-odbc-database)) + (funcall (close-query-fn database) (odbc-result-set-query result-set)) + t) + +(defmethod database-store-next-row (result-set + (database generic-odbc-database) + list) + (let ((row (funcall (fetch-row-fn database) + (odbc-result-set-query result-set) nil 'eof))) + (if (eq row 'eof) + nil + (progn + (loop for elem in row + for rest on list + do + (setf (car rest) elem)) + list)))) + + +(defun %database-list-* (database type owner) + "Internal function used by database-list-tables and +database-list-views" + (multiple-value-bind (rows col-names) + (funcall (list-all-database-tables-fn database) :db (odbc-conn database)) + (declare (ignore col-names)) + ;; http://msdn.microsoft.com/en-us/library/ms711831%28VS.85%29.aspx + ;; TABLE_SCHEM is hard-coded in second column by ODBC Driver Manager + ;; TABLE_NAME in third column, TABLE_TYPE in fourth column + (loop for (category schema name ttype . rest) in rows + when (and (string-equal type ttype) + (or (null owner) (string-equal owner schema)) + ;; unless requesting by name, skip system schema + (not (and (null owner) + (member schema '("information_schema" "sys") + :test #'string-equal))) + ;; skip system specific tables in mssql2000 + (not (and (eql :mssql (database-underlying-type database)) + (member name '("dtproperties" "sysconstraints" + "syssegments") + :test #'string-equal)))) + collect name))) + +(defmethod database-list-tables ((database generic-odbc-database) + &key (owner nil)) + "Since ODBC doesn't expose the owner we use that parameter to filter +on schema since that's what tends to be exposed. Some DBs like mssql +2000 conflate the two so at least there it works nicely." + (%database-list-* database "TABLE" owner)) + + +(defmethod database-list-views ((database generic-odbc-database) + &key (owner nil)) + "Since ODBC doesn't expose the owner we use that parameter to filter +on schema since that's what tends to be exposed. Some DBs like mssql +2000 conflate the two so at least there it works nicely." + (%database-list-* database "VIEW" owner)) + + +(defmethod database-list-attributes ((table %database-identifier) (database generic-odbc-database) + &key (owner nil) + &aux (table (unescaped-database-identifier table))) + (declare (ignore owner)) + (multiple-value-bind (rows col-names) + (funcall (list-all-table-columns-fn database) table + :db (odbc-conn database)) + (declare (ignore col-names)) + ;; COLUMN_NAME is hard-coded by odbc spec as fourth position + (loop for row in rows + collect (fourth row)))) + +(defmethod database-attribute-type ((attribute %database-identifier) (table %database-identifier) + (database generic-odbc-database) + &key (owner nil) + &aux (table (unescaped-database-identifier table)) + (attribute (unescaped-database-identifier attribute))) + (declare (ignore owner)) + (multiple-value-bind (rows col-names) + (funcall (list-all-table-columns-fn database) table + :db (odbc-conn database)) + (declare (ignore col-names)) + ;; COLUMN_NAME is hard-coded by odbc spec as fourth position + ;; TYPE_NAME is the sixth column + ;; PRECISION/COLUMN_SIZE is the seventh column + ;; SCALE/DECIMAL_DIGITS is the ninth column + ;; NULLABLE is the eleventh column + (loop for row in rows + when (string-equal attribute (fourth row)) + do + (let ((size (seventh row)) + (precision (ninth row)) + (scale (nth 10 row))) + (return (values (ensure-keyword (sixth row)) + (when size (parse-integer size)) + (when precision (parse-integer precision)) + (when scale (parse-integer scale)))))))) + +(defmethod database-last-auto-increment-id + ((database generic-odbc-database) table column) + (case (database-underlying-type database) + (:mssql + (first (clsql:query "SELECT SCOPE_IDENTITY()" + :flatp t + :database database + :result-types '(:int)))) + (t (if (next-method-p) + (call-next-method))))) + +(defmethod clsql-sys:db-type-has-auto-increment? ((db-underlying-type (eql :mssql))) + t) diff --git a/sql/generic-postgresql.lisp b/sql/generic-postgresql.lisp new file mode 100644 index 0000000..13d4f77 --- /dev/null +++ b/sql/generic-postgresql.lisp @@ -0,0 +1,429 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; +;;;; Generic postgresql layer, used by db-postgresql and db-postgresql-socket +;;;; +;;;; 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 generic-postgresql-database (database) + ((has-table-pg_roles :type boolean :reader has-table-pg_roles :initform nil)) + (:documentation "Encapsulate same behavior across postgresql and postgresql-socket backends.")) + + + +;; Object functions + +(defmethod database-get-type-specifier ((type symbol) args database + (db-type (eql :postgresql))) + "Special database types for POSTGRESQL backends" + (declare (ignore database db-type)) + (case type + (wall-time ;; TODO: why is this WITHOUT... + "TIMESTAMP WITHOUT TIME ZONE") + (string + ;; TODO: the default to CHAR here seems specious as the PG docs claim + ;; that char is slower than varchar + (if args + (format nil "CHAR(~A)" (car args)) + "VARCHAR")) + (number + (cond + ((and (consp args) (= (length args) 2)) + (format nil "NUMERIC(~D,~D)" (first args) (second args))) + ((and (consp args) (= (length args) 1)) + (format nil "NUMERIC(~D)" (first args))) + (t "NUMERIC"))) + ((tinyint smallint) "INT2") + (t (call-next-method)))) + +;;; Backend functions + +(defun owner-clause (owner) + (cond + ((stringp owner) + (format + nil + " AND (relowner=(SELECT usesysid FROM pg_user WHERE (usename='~A')))" + owner)) + ((null owner) + (format nil " AND (relowner<>(SELECT usesysid FROM pg_user WHERE usename='postgres'))")) + (t ""))) + +(defun has-table (name database) + (let ((name-retrieved + (caar (database-query + (format nil "SELECT relname FROM pg_class WHERE relname='~A'" + name) + database nil nil)))) + (if (and (stringp name-retrieved) (plusp (length name-retrieved))) + t + nil))) + +(defmethod slot-unbound (class (obj generic-postgresql-database) + (slot (eql 'has-table-pg_roles))) + ;; Lazily cache slot value + (declare (ignore class)) + (setf (slot-value obj 'has-table-pg_roles) (has-table "pg_roles" obj))) + +(defun database-list-objects-of-type (database type owner) + (mapcar #'car + (database-query + (format nil + (if (and (has-table-pg_roles database) + (not (eq owner :all))) + " + SELECT c.relname + FROM pg_catalog.pg_class c + LEFT JOIN pg_catalog.pg_roles r ON r.oid = c.relowner + LEFT JOIN pg_catalog.pg_namespace n ON n.oid = c.relnamespace + WHERE c.relkind IN ('~A','') + AND n.nspname NOT IN ('pg_catalog', 'pg_toast') + AND pg_catalog.pg_table_is_visible(c.oid) + ~A" + "SELECT relname FROM pg_class WHERE (relkind = +'~A')~A") + type + (owner-clause owner)) + database nil nil))) + +(defmethod database-list-tables ((database generic-postgresql-database) + &key (owner nil)) + (database-list-objects-of-type database "r" owner)) + +(defmethod database-list-views ((database generic-postgresql-database) + &key (owner nil)) + (database-list-objects-of-type database "v" owner)) + +(defmethod database-list-indexes ((database generic-postgresql-database) + &key (owner nil)) + (database-list-objects-of-type database "i" owner)) + + +(defmethod database-list-table-indexes (table (database generic-postgresql-database) + &key (owner nil)) + (let ((indexrelids + (database-query + (format + nil + "select indexrelid from pg_index where indrelid=(select relfilenode from pg_class where LOWER(relname)='~A'~A)" + (string-downcase (unescaped-database-identifier table)) + (owner-clause owner)) + database :auto nil)) + (result nil)) + (dolist (indexrelid indexrelids (nreverse result)) + (push + (caar (database-query + (format nil "select relname from pg_class where relfilenode='~A'" + (car indexrelid)) + database nil nil)) + result)))) + +(defmethod database-list-attributes ((table %database-identifier) + (database generic-postgresql-database) + &key (owner nil)) + (let* ((table (unescaped-database-identifier table)) + (owner-clause + (cond ((stringp owner) + (format nil " AND (relowner=(SELECT usesysid FROM pg_user WHERE usename='~A'))" owner)) + ((null owner) " AND (not (relowner=1))") + (t ""))) + (result + (mapcar #'car + (database-query + (format nil "SELECT attname FROM pg_class,pg_attribute WHERE pg_class.oid=attrelid AND attisdropped = FALSE AND relname='~A'~A" + (string-downcase table) + owner-clause) + database nil nil)))) + (if result + (remove-if #'(lambda (it) (member it '("cmin" + "cmax" + "xmax" + "xmin" + "oid" + "ctid" + ;; kmr -- added tableoid + "tableoid") :test #'equal)) + result)))) + +(defmethod database-attribute-type ((attribute %database-identifier) + (table %database-identifier) + (database generic-postgresql-database) + &key (owner nil) + &aux (table (unescaped-database-identifier table)) + (attribute (unescaped-database-identifier attribute))) + (let ((row (car (database-query + (format nil "SELECT pg_type.typname,pg_attribute.attlen,pg_attribute.atttypmod,pg_attribute.attnotnull FROM pg_type,pg_class,pg_attribute WHERE pg_class.oid=pg_attribute.attrelid AND pg_class.relname='~A' AND pg_attribute.attname='~A' AND pg_attribute.atttypid=pg_type.oid~A" + (string-downcase table) + (string-downcase attribute) + (owner-clause owner)) + database nil nil)))) + (when row + (destructuring-bind (typname attlen atttypmod attnull) row + (setf attlen (%get-int attlen) + atttypmod (%get-int atttypmod)) + (let ((coltype (ensure-keyword typname)) + (colnull (typecase attnull + (string (if (string-equal "f" attnull) 1 0)) + (null 1) + (T 0))) + collen + colprec) + (setf (values collen colprec) + (case coltype + ((:numeric :decimal) + (if (= -1 atttypmod) + (values nil nil) + (values (ash (- atttypmod 4) -16) + (boole boole-and (- atttypmod 4) #xffff)))) + (otherwise + (values + (cond ((and (= -1 attlen) (= -1 atttypmod)) nil) + ((= -1 attlen) (- atttypmod 4)) + (t attlen)) + nil)))) + (values coltype collen colprec colnull)))))) + +(defmethod database-create-sequence (sequence-name + (database generic-postgresql-database)) + (let ((cmd (concatenate + 'string "CREATE SEQUENCE " (escaped-database-identifier sequence-name database)))) + (database-execute-command cmd database))) + +(defmethod database-drop-sequence (sequence-name + (database generic-postgresql-database)) + (database-execute-command + (concatenate 'string "DROP SEQUENCE " (escaped-database-identifier sequence-name database)) + database)) + +(defmethod database-list-sequences ((database generic-postgresql-database) + &key (owner nil)) + (database-list-objects-of-type database "S" owner)) + +(defmethod database-set-sequence-position (name (position integer) + (database generic-postgresql-database)) + (values + (%get-int + (caar + (database-query + (format nil "SELECT SETVAL ('~A', ~A)" (escaped-database-identifier name) position) + database nil nil))))) + +(defmethod database-sequence-next (sequence-name + (database generic-postgresql-database)) + (values + (%get-int + (caar + (database-query + (concatenate 'string "SELECT NEXTVAL ('" (escaped-database-identifier sequence-name) "')") + database nil nil))))) + +(defmethod database-sequence-last (sequence-name (database generic-postgresql-database)) + (values + (%get-int + (caar + (database-query + (concatenate 'string "SELECT LAST_VALUE FROM " (escaped-database-identifier sequence-name)) + database nil nil))))) + +(defmethod auto-increment-sequence-name (table column (database generic-postgresql-database)) + (let* ((sequence-name (or (database-identifier (slot-value column 'autoincrement-sequence)) + (combine-database-identifiers + (list table column 'seq) + database)))) + (when (search "'" (escaped-database-identifier sequence-name) + :test #'string-equal) + (signal-database-too-strange + "PG Sequence names shouldnt contain single quotes for the sake of sanity")) + sequence-name)) + +(defmethod database-last-auto-increment-id ((database generic-postgresql-database) table column) + (let ((seq-name (auto-increment-sequence-name table column database))) + (first (clsql:query (format nil "SELECT currval ('~a')" + (escaped-database-identifier seq-name)) + :flatp t + :database database + :result-types '(:int))))) + +(defmethod database-generate-column-definition + (class slotdef (database generic-postgresql-database)) + (when (member (view-class-slot-db-kind slotdef) '(:base :key)) + (let ((cdef + (list (sql-expression :attribute (database-identifier slotdef database)) + (specified-type slotdef) + (view-class-slot-db-type slotdef))) + (const (listify (view-class-slot-db-constraints slotdef))) + (seq (auto-increment-sequence-name class slotdef database))) + (when seq + (setf const (remove :auto-increment const)) + (unless (member :default const) + (let* ((next (format nil " nextval('~a')" (escaped-database-identifier seq)))) + (setf const (append const (list :default next)))))) + (append cdef const)))) + +(defmethod database-add-autoincrement-sequence + ((self standard-db-class) (database generic-postgresql-database)) + (let ((ordered-slots (slots-for-possibly-normalized-class self))) + (dolist (slotdef ordered-slots) + ;; ensure that referenceed sequences actually exist before referencing them + (let ((sequence-name (auto-increment-sequence-name self slotdef database))) + (when (and sequence-name + (not (sequence-exists-p sequence-name :database database))) + (create-sequence sequence-name :database database)))))) + +(defmethod database-remove-autoincrement-sequence + ((table standard-db-class) + (database generic-postgresql-database)) + (let ((ordered-slots (slots-for-possibly-normalized-class table))) + (dolist (slotdef ordered-slots) + ;; ensure that referenceed sequences are dropped with the table + (let ((sequence-name (auto-increment-sequence-name table slotdef database))) + (when sequence-name (drop-sequence sequence-name)))))) + +(defun postgresql-database-list (connection-spec type) + (destructuring-bind (host name &rest other-args) connection-spec + (declare (ignore name)) + (let ((database (database-connect (list* host "template1" other-args) + type))) + (unwind-protect + (progn + (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-sys::state) :closed)))))) + +(defmethod database-list (connection-spec (type (eql :postgresql))) + (postgresql-database-list connection-spec type)) + +(defmethod database-list (connection-spec (type (eql :postgresql-socket))) + (postgresql-database-list connection-spec type)) + +#+nil +(defmethod database-describe-table ((database generic-postgresql-database) table) + ;; MTP: LIST-ATTRIBUTE-TYPES currently executes separate queries for + ;; each attribute. It would be more efficient to have a single SQL + ;; query return the type data for all attributes. This code is + ;; retained as an example of how to do this for PostgreSQL. + (database-query + (format nil "select a.attname, t.typname + from pg_class c, pg_attribute a, pg_type t + where c.relname = '~a' + and a.attnum > 0 + and a.attrelid = c.oid + and a.atttypid = t.oid" + (sql-escape (string-downcase table))) + database :auto nil)) + +;;; Prepared statements + +(defvar *next-prepared-id-num* 0) +(defun next-prepared-id () + (let ((num (incf *next-prepared-id-num*))) + (format nil "CLSQL_PS_~D" num))) + +(defclass postgresql-stmt () + ((database :initarg :database :reader database) + (id :initarg :id :reader id) + (bindings :initarg :bindings :reader bindings) + (field-names :initarg :field-names :accessor stmt-field-names) + (result-types :initarg :result-types :reader result-types))) + +(defun clsql-type->postgresql-type (type) + (cond + ((in type :int :integer) "INT4") + ((in type :short) "INT2") + ((in type :bigint) "INT8") + ((in type :float :double :number) "NUMERIC") + ((and (consp type) (in (car type) :char :varchar)) "VARCHAR") + (t + (error 'sql-user-error + :message + (format nil "Unknown clsql type ~A." type))))) + +(defun prepared-sql-to-postgresql-sql (sql) + ;; FIXME: Convert #\? to "$n". Don't convert within strings + (declare (simple-string sql)) + (with-output-to-string (out) + (do ((len (length sql)) + (param 0) + (in-str nil) + (pos 0 (1+ pos))) + ((= len pos)) + (declare (fixnum len param pos)) + (let ((c (schar sql pos))) + (declare (character c)) + (cond + ((or (char= c #\") (char= c #\')) + (setq in-str (not in-str)) + (write-char c out)) + ((and (char= c #\?) (not in-str)) + (write-char #\$ out) + (write-string (write-to-string (incf param)) out)) + (t + (write-char c out))))))) + +(defmethod database-prepare (sql-stmt types (database generic-postgresql-database) result-types field-names) + (let ((id (next-prepared-id))) + (database-execute-command + (format nil "PREPARE ~A (~{~A~^,~}) AS ~A" + id + (mapcar #'clsql-type->postgresql-type types) + (prepared-sql-to-postgresql-sql sql-stmt)) + database) + (make-instance 'postgresql-stmt + :id id + :database database + :result-types result-types + :field-names field-names + :bindings (make-list (length types))))) + +(defmethod database-bind-parameter ((stmt postgresql-stmt) position value) + (setf (nth (1- position) (bindings stmt)) value)) + +(defun binding-to-param (binding) + (typecase binding + (string + (concatenate 'string "'" (sql-escape-quotes binding) "'")) + (t + binding))) + +(defmethod database-run-prepared ((stmt postgresql-stmt)) + (with-slots (database id bindings field-names result-types) stmt + (let ((query (format nil "EXECUTE ~A (~{~A~^,~})" + id (mapcar #'binding-to-param bindings)))) + (cond + ((and field-names (not (consp field-names))) + (multiple-value-bind (res names) + (database-query query database result-types field-names) + (setf field-names names) + (values res names))) + (field-names + (values (nth-value 0 (database-query query database result-types nil)) + field-names)) + (t + (database-query query database result-types field-names)))))) + +;;; Capabilities + +(defmethod db-type-has-fancy-math? ((db-type (eql :postgresql))) + t) + +(defmethod db-type-default-case ((db-type (eql :postgresql))) + :lower) + +(defmethod db-type-has-prepared-stmt? ((db-type (eql :postgresql))) + t) + +(defmethod db-type-has-prepared-stmt? ((db-type (eql :postgresql-socket))) + t) + +(defmethod db-type-has-auto-increment? ((db-type (eql :postgresql))) + t) diff --git a/sql/generics.lisp b/sql/generics.lisp new file mode 100644 index 0000000..6ca064a --- /dev/null +++ b/sql/generics.lisp @@ -0,0 +1,212 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: generics.lisp +;;;; Purpose: Generic function definitions for DB interfaces +;;;; Author: Kevin M. Rosenberg +;;;; Created: Apr 2004 +;;;; +;;;; This file, part of CLSQL, is Copyright (c) 2004-2010 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) + + +;; FDML +(defgeneric choose-database-for-instance (object &optional database) + (:documentation "Used by the oodml functions to select which + database object to use. Chooses the database associated with the + object primarily, falls back to the database provided as an argument + or the *DEFAULT-DATABASE*.")) + +(defgeneric execute-command (expression &key database) + (:documentation + "Executes the SQL command EXPRESSION, which may be an SQL +expression or a string representing any SQL statement apart from +a query, on the supplied DATABASE which defaults to +*DEFAULT-DATABASE*.")) + + +(defgeneric query (query-expression &key database result-types flatp field-names) + (:documentation + "Executes the SQL query expression QUERY-EXPRESSION, which may +be an SQL expression or a string, on the supplied DATABASE which +defaults to *DEFAULT-DATABASE*. RESULT-TYPES is a list of symbols +which specifies the lisp type for each field returned by +QUERY-EXPRESSION. If RESULT-TYPES is nil all results are returned +as strings whereas the default value of :auto means that the lisp +types are automatically computed for each field. FIELD-NAMES is t +by default which means that the second value returned is a list +of strings representing the columns selected by +QUERY-EXPRESSION. If FIELD-NAMES is nil, the list of column names +is not returned as a second value. FLATP has a default value of +nil which means that the results are returned as a list of +lists. If FLATP is t and only one result is returned for each +record selected by QUERY-EXPRESSION, the results are returned as +elements of a list.")) + + +;; OODML + +(defgeneric update-record-from-slot (object slot &key database) + (:documentation + "Updates the value stored in the column represented by the +slot, specified by the CLOS slot name SLOT, of View Class +instance OBJECT. DATABASE defaults to *DEFAULT-DATABASE* and +specifies the database in which the update is made only if OBJECT +is not associated with a database. In this case, a record is +created in DATABASE and the attribute represented by SLOT is +initialised from the value of the supplied slots with other +attributes having default values. Furthermore, OBJECT becomes +associated with DATABASE.")) + +(defgeneric update-record-from-slots (object slots &key database) + (:documentation + "Updates the values stored in the columns represented by the +slots, specified by the CLOS slot names SLOTS, of View Class +instance OBJECT. DATABASE defaults to *DEFAULT-DATABASE* and +specifies the database in which the update is made only if OBJECT +is not associated with a database. In this case, a record is +created in the appropriate table of DATABASE and the attributes +represented by SLOTS are initialised from the values of the +supplied slots with other attributes having default +values. Furthermore, OBJECT becomes associated with DATABASE.")) + +(defgeneric update-records-from-instance (object &key database) + (:documentation + "Using an instance of a View Class, OBJECT, update the table +that stores its instance data. DATABASE defaults to +*DEFAULT-DATABASE* and specifies the database in which the update +is made only if OBJECT is not associated with a database. In this +case, a record is created in the appropriate table of DATABASE +using values from the slot values of OBJECT, and OBJECT becomes +associated with DATABASE.")) + +(defgeneric delete-instance-records (object &key database) + (:documentation + "Deletes the records represented by OBJECT in the appropriate +table of the database associated with OBJECT. If OBJECT is not +yet associated with a database, an error is signalled.")) + +(defgeneric update-instance-from-records (object &key database) + (:documentation + "Updates the slot values of the View Class instance OBJECT +using the attribute values of the appropriate table of DATABASE +which defaults to the database associated with OBJECT or, if +OBJECT is not associated with a database, *DEFAULT-DATABASE*. +Join slots are updated but instances of the class on which the +join is made are not updated.")) + +(defgeneric update-slot-from-record (object slot &key database) + (:documentation + "Updates the slot value, specified by the CLOS slot name SLOT, +of the View Class instance OBJECT using the attribute values of +the appropriate table of DATABASE which defaults to the database +associated with OBJECT or, if OBJECT is not associated with a +database, *DEFAULT-DATABASE*. Join slots are updated but +instances of the class on which the join is made are not +updated.")) + +(defgeneric instance-refreshed (object) + (:documentation + "Provides a hook which is called within an object oriented +call to SELECT with a non-nil value of REFRESH when the View +Class instance OBJECT has been updated from the database. A +method specialised on STANDARD-DB-OBJECT is provided which has no +effects. Methods specialised on particular View Classes can be +used to specify any operations that need to be made on View +Classes instances which have been updated in calls to SELECT.")) + +(defgeneric update-slot-with-null (instance slotdef) + (:documentation "Called to update a slot when its column has a NULL +value. If nulls are allowed for the column, the slot's value will be +nil, otherwise its value will be set to the result of calling +DATABASE-NULL-VALUE on the type of the slot.")) + +(defgeneric database-pkey-constraint (class database) + ) +(defgeneric %install-class (class database &key transactions) + ) +(defgeneric database-generate-column-definition (class slotdef database) + ) +(defgeneric update-slot-from-db (instance slotdef val) + ) +(defgeneric key-value-from-db (slotdef value database) + ) +(defgeneric get-slot-values-from-view (obj slotdeflist values) + ) +(defgeneric database-output-sql-as-type (type val database db-type) + ) +(defgeneric read-sql-value (val type database db-type) + ) +(defgeneric database-add-autoincrement-sequence (class database) + (:method (class database) nil) + (:documentation "If a database needs to add a sequence for its + autoincrement to work, this is where it should go. Default is + that it doesnt so just return nil")) +(defgeneric database-remove-autoincrement-sequence (class database) + (:method (class database) nil) + (:documentation "If a database needs to add a sequence for its + autoincrement to work, this is where it should go. Default is + that it doesnt so just return nil")) +(defgeneric auto-increment-sequence-name (class slotdef database) + (:documentation "The sequence name to create for this autoincremnt column on this class + if returns nil, there is no associated sequence ")) + +(defmethod auto-increment-sequence-name :around (class slot database) + (when (auto-increment-column-p slot database) + (call-next-method))) + +(defgeneric database-last-auto-increment-id (database table column) + ) + + + +;; Generation of SQL strings from lisp expressions + +(defgeneric output-sql (expr database) + (:documentation "Writes an SQL string appropriate for DATABASE + and corresponding to the lisp expression EXPR to + *SQL-STREAM*. The function SQL-OUTPUT is a top-level call for + generating SQL strings which initialises *SQL-STREAM*, calls + OUTPUT-SQL and reads the generated SQL string from + *SQL-STREAM*.")) + +(defgeneric database-output-sql (expr database) + (:documentation "Returns an SQL string appropriate for DATABASE + and corresponding to the lisp expression + EXPR. DATABASE-OUTPUT-SQL is called by OUTPUT-SQL when no more + specific method exists for EXPR.")) + +(defgeneric output-sql-hash-key (expr database) + (:documentation "Returns a list (or other object suitable for +use as the key of an EQUAL hash table) which uniquely identifies +the arguments EXPR and DATABASE.")) + +(defgeneric collect-table-refs (sql) + ) + +(defgeneric database-constraint-statement (constraints database) + ) + +(defgeneric database-translate-constraint (constraint database) + (:documentation "Given a column constraint returns its +database-specific name. For example, auto-increment constraints can +have different names in different database engines.")) + +(defgeneric filter-select-list ( view-class clsql-sys::select-list database) + (:documentation + "Gives fine grained control over sql to be executed and mapped to slots + called with a dummy instance (so that class precedence can be used)") + ) + +(defgeneric view-classes-and-storable-slots (view-class &key to-database-p) + (:documentation "A method that collects all the classes and storable slots + that need to be read from or written to the database. + to-database-p should be T if we are writing this object to the database + and nil when we are reading this object from the database")) diff --git a/sql/initialize.lisp b/sql/initialize.lisp new file mode 100644 index 0000000..cc827bb --- /dev/null +++ b/sql/initialize.lisp @@ -0,0 +1,61 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: initialize.lisp +;;;; Purpose: Initializion routines for db backend +;;;; Programmers: Kevin M. Rosenberg +;;;; Date Started: May 2002 +;;;; +;;;; This file, part of CLSQL, is Copyright (c) 2002-2010 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 + "Designates the default database type which is initialised by + the function INITIALISE-DATABASE-TYPE.") + +(defvar *initialized-database-types* nil + "A list of database types which have currently been initialised +by calling INITIALIZE-DATABASE-TYPE.") + +(defun initialize-database-type (&key (database-type *default-database-type*)) + "Initializes the supplied DATABASE-TYPE, if it is not already +initialized, as indicated by *INITIALIZED-DATABASE-TYPES* and +returns DATABASE-TYPE. *DEFAULT-DATABASE-TYPE* is set to +DATABASE-TYPE and, if DATABASE-TYPE has not been initialised, it +is added to *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*) + (setf *default-database-type* database-type) + database-type)) + diff --git a/sql/kmr-mop.lisp b/sql/kmr-mop.lisp new file mode 100644 index 0000000..f355282 --- /dev/null +++ b/sql/kmr-mop.lisp @@ -0,0 +1,101 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: kmr-mop.lisp +;;;; Purpose: MOP support for multiple-implementions +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Apr 2003 +;;;; +;;;; This file imports MOP symbols into the CLSQL-MOP package and then +;;;; re-exports into CLSQL-SYS them to hide differences in +;;;; MOP implementations. +;;;; +;;;; This file was extracted from the KMRCL utilities +;;;; ************************************************************************* + +(in-package #:clsql-sys) + +#+lispworks +(defun intern-eql-specializer (slot) + `(eql ,slot)) + +(defmacro process-class-option (metaclass slot-name &optional required) + #+lispworks + `(defmethod clos:process-a-class-option ((class ,metaclass) + (name (eql ,slot-name)) + value) + (when (and ,required (null value)) + (error "metaclass ~A class slot ~A must have a value" (quote ,metaclass) name)) + (list name `',value)) + #-lispworks + (declare (ignore metaclass slot-name required)) + ) + +(defmacro process-slot-option (metaclass slot-name) + #+lispworks + `(defmethod clos:process-a-slot-option ((class ,metaclass) + (option (eql ,slot-name)) + value + already-processed-options + slot) + (list* option `',value already-processed-options)) + #-lispworks + (declare (ignore metaclass slot-name)) + ) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defclass %slot-order-test-class () + ((a) + (b))) + (finalize-inheritance (find-class '%slot-order-test-class)) + (let ((slots (class-slots (find-class '%slot-order-test-class)))) + (ecase (slot-definition-name (first slots)) + (a) + (b (pushnew :mop-slot-order-reversed cl:*features*))))) + +(defun ordered-class-slots (class) + #+mop-slot-order-reversed (reverse (class-slots class)) + #-mop-slot-order-reversed (class-slots class)) + +(defun ordered-class-direct-slots (class) + "Gets an ordered list of direct class slots" + ;; NB: this used to return effective-slot-definitions in direct + ;; opposition to the function name. Not sure why + (setf class (to-class class)) + #+mop-slot-order-reversed (reverse (class-direct-slots class)) + #-mop-slot-order-reversed (class-direct-slots class)) + +(defun find-slot-if (class predicate &optional direct? recurse?) + "Looks up a direct-slot-definition by name" + (setf class (to-class class)) + (labels ((find-it (class) + (let* ((slots (if direct? + (ordered-class-direct-slots class) + (ordered-class-slots class))) + (it (find-if predicate slots))) + (or it + (when recurse? + (loop for sup in (class-direct-superclasses class) + for rtn = (find-it sup) + until rtn + finally (return rtn))))))) + (find-it class))) + +(defun find-slot-by-name (class slot-name &optional direct? recurse?) + "Looks up a direct-slot-definition by name" + (setf class (to-class class) + slot-name (to-slot-name slot-name)) + (find-slot-if class (lambda (slot-def) (eql (to-slot-name slot-def) slot-name)) + direct? recurse?)) + +;; Lispworks has symbol for slot rather than the slot instance +(defun %svuc-slot-name (slot) + #+lispworks slot + #-lispworks (slot-definition-name slot)) + +(defun %svuc-slot-object (slot class) + (declare (ignorable class)) + #+lispworks (clos:find-slot-definition slot class) + #-lispworks slot) + diff --git a/sql/loop-extension.lisp b/sql/loop-extension.lisp new file mode 100644 index 0000000..32a356c --- /dev/null +++ b/sql/loop-extension.lisp @@ -0,0 +1,247 @@ +;;;; -*- 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-2006 Kevin Rosenberg and (c) 1999-2001 Pierre R. Mai +;;;; +;;;; ************************************************************************* + +(in-package #:clsql-sys) + +#+(or allegro sbcl) +(eval-when (:compile-toplevel :load-toplevel :execute) + (defpackage #:ansi-loop + (:import-from #+sbcl #:sb-loop #+allegro #:excl + #:*loop-epilogue* + #:*loop-ansi-universe* + #:add-loop-path))) + +#+(or allegro sbcl) +(defun ansi-loop::loop-gentemp (&optional (pref 'loopva-)) + (gensym (string pref))) + +#+clisp +(eval-when (:compile-toplevel :load-toplevel :execute) + (when (find-package "ANSI-LOOP") (push :clisp-aloop cl:*features*))) + +#+(or allegro clisp-aloop cmu openmcl sbcl scl) +(defun loop-record-iteration-path (variable data-type prep-phrases) + (let ((in-phrase nil) + (from-phrase nil)) + (loop for (prep . rest) in prep-phrases + do + (case prep + ((:in :of) + (when in-phrase + (error 'clsql:sql-user-error + :message + (format nil + "Duplicate OF or IN iteration path: ~S." + (cons prep rest)))) + (setq in-phrase rest)) + ((:from) + (when from-phrase + (error 'clsql:sql-user-error + :message + (format nil + "Duplicate FROM iteration path: ~S." + (cons prep rest)))) + (setq from-phrase rest)) + (t + (error 'clsql:sql-user-error + :message + (format nil"Unknown preposition: ~S." prep))))) + (unless in-phrase + (error 'clsql:sql-user-error + :message "Missing OF or IN iteration path.")) + (unless from-phrase + (setq from-phrase '(*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 (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 + (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 t) + (,step-var nil)) + ((multiple-value-bind (%rs %cols) + (database-query-result-set ,query-var ,db-var :result-types :auto) + (setq ,result-set-var %rs ,step-var (make-list %cols)))) + () + () + (not (database-store-next-row ,result-set-var ,db-var ,step-var)) + (,variable ,step-var) + (not ,result-set-var) + () + (not (database-store-next-row ,result-set-var ,db-var ,step-var)) + (,variable ,step-var))))))) + +#+(or allegro clisp-aloop cmu openmcl sbcl scl) +(ansi-loop::add-loop-path '(record records tuple tuples) + 'loop-record-iteration-path + ansi-loop::*loop-ansi-universe* + :preposition-groups '((:of :in) (:from)) + :inclusive-permitted nil) + + +#+lispworks +(cl-user::define-loop-method (loop::record loop::records loop::tuple loop::tuples) + clsql-loop-method + (loop::in loop::of loop::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 iter-var-data-type 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 'loop::in) (eq prep 'loop::of)) + (when in-phrase + (error 'clsql:sql-user-error + :message + (format nil "Duplicate OF or IN iteration path: ~S." + (cons prep rest)))) + (setq in-phrase rest)) + ((eq prep 'loop::from) + (when from-phrase + (error 'clsql:sql-user-error + :message + (format nil "Duplicate FROM iteration path: ~S." + (cons prep rest)))) + (setq from-phrase rest)) + (t + (error 'clsql:sql-user-error + :message (format nil "Unknown preposition: ~S." prep))))) + (unless in-phrase + (error 'clsql:sql-user-error + :message "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) + () + ())))))) + + +#+clisp-aloop +(eval-when (:compile-toplevel :load-toplevel :execute) + (setq cl:*features* (delete :clisp-aloop cl:*features*))) + diff --git a/sql/metaclasses.lisp b/sql/metaclasses.lisp new file mode 100644 index 0000000..9aa7dd9 --- /dev/null +++ b/sql/metaclasses.lisp @@ -0,0 +1,641 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; +;;;; CLSQL metaclass for standard-db-objects created in the OODDL. +;;;; +;;;; 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) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (when (>= (length (generic-function-lambda-list + (ensure-generic-function + 'compute-effective-slot-definition))) + 3) + (pushnew :kmr-normal-cesd cl:*features*)) + + (when (>= (length (generic-function-lambda-list + (ensure-generic-function + 'direct-slot-definition-class))) + 3) + (pushnew :kmr-normal-dsdc cl:*features*)) + + (when (>= (length (generic-function-lambda-list + (ensure-generic-function + 'effective-slot-definition-class))) + 3) + (pushnew :kmr-normal-esdc cl:*features*))) + + +;; ------------------------------------------------------------ +;; metaclass: view-class + +(defclass standard-db-class (standard-class) + ((view-table + :accessor view-table + :initarg :view-table) + (definition + :accessor object-definition + :initarg :definition + :initform nil) + (key-slots + :accessor key-slots + :initform nil) + (normalizedp + :accessor normalizedp + :initform nil) + (class-qualifier + :accessor view-class-qualifier + :initarg :qualifier + :initform nil)) + (:documentation "Metaclass for all CLSQL View Classes.")) + +;;; Lispworks 4.2 and before requires special processing of extra slot and class options + +(defvar +extra-slot-options+ '(:column :db-kind :db-type :db-reader :void-value :db-constraints + :db-writer :db-info)) +(defvar +extra-class-options+ '(:base-table)) + +#+lispworks +(dolist (slot-option +extra-slot-options+) + (eval `(process-slot-option standard-db-class ,slot-option))) + +#+lispworks +(dolist (class-option +extra-class-options+) + (eval `(process-class-option standard-db-class ,class-option))) + +(defmethod validate-superclass ((class standard-db-class) + (superclass standard-class)) + t) + +(defun table-name-from-arg (arg) + (cond ((symbolp arg) + (intern (sql-escape arg))) + ((typep arg 'sql-ident) + (if (symbolp (slot-value arg 'name)) + (intern (sql-escape (slot-value arg 'name))) + (sql-escape (slot-value arg 'name)))) + ((stringp arg) + (sql-escape arg)))) + +(defun remove-keyword-arg (arglist akey) + (let ((mylist arglist) + (newlist ())) + (labels ((pop-arg (alist) + (let ((arg (pop alist)) + (val (pop alist))) + (unless (equal arg akey) + (setf newlist (append (list arg val) newlist))) + (when alist (pop-arg alist))))) + (pop-arg mylist)) + newlist)) + +(defun set-view-table-slot (class base-table) + (setf (view-table class) + (table-name-from-arg (or (and base-table + (if (listp base-table) + (car base-table) + base-table)) + (class-name class))))) + +(defmethod initialize-instance :around ((class standard-db-class) + &rest all-keys + &key direct-superclasses base-table + qualifier normalizedp + &allow-other-keys) + (let ((root-class (find-class 'standard-db-object nil)) + (vmc 'standard-db-class)) + (setf (view-class-qualifier class) + (car qualifier)) + (if root-class + (if (some #'(lambda (super) (typep super vmc)) + direct-superclasses) + (call-next-method) + (apply #'call-next-method + class + :direct-superclasses (append (list root-class) + direct-superclasses) + (remove-keyword-arg all-keys :direct-superclasses))) + (call-next-method)) + (set-view-table-slot class base-table) + (setf (normalizedp class) (car normalizedp)) + (register-metaclass class (nth (1+ (position :direct-slots all-keys)) + all-keys)))) + +(defmethod reinitialize-instance :around ((class standard-db-class) + &rest all-keys + &key base-table normalizedp + direct-superclasses qualifier + &allow-other-keys) + (let ((root-class (find-class 'standard-db-object nil)) + (vmc 'standard-db-class)) + (set-view-table-slot class base-table) + (setf (normalizedp class) (car normalizedp)) + (setf (view-class-qualifier class) + (car qualifier)) + (if (and root-class (not (equal class root-class))) + (if (some #'(lambda (super) (typep super vmc)) + direct-superclasses) + (call-next-method) + (apply #'call-next-method + class + :direct-superclasses (append (list root-class) + direct-superclasses) + (remove-keyword-arg all-keys :direct-superclasses))) + (call-next-method))) + (register-metaclass class (nth (1+ (position :direct-slots all-keys)) + all-keys)) + class) + + +(defun get-keywords (keys list) + (flet ((extract (key) + (let ((pos (position key list))) + (when pos + (nth (1+ pos) list))))) + (mapcar #'extract keys))) + +(defun describe-db-layout (class) + (flet ((not-db-col (col) + (not (member (nth 2 col) '(nil :base :key)))) + (frob-slot (slot) + (let ((type (slot-definition-type slot))) + (if (eq type t) + (setq type nil)) + (list (slot-value slot 'name) + type + (slot-value slot 'db-kind) + (and (slot-boundp slot 'column) + (slot-value slot 'column)))))) + (let ((all-slots (mapcar #'frob-slot (ordered-class-slots class)))) + (setq all-slots (remove-if #'not-db-col all-slots)) + (setq all-slots (stable-sort all-slots #'string< :key #'car)) + ;;(mapcar #'dink-type all-slots) + all-slots))) + +(defun register-metaclass (class slots) + (labels ((not-db-col (col) + (not (member (nth 2 col) '(nil :base :key)))) + (frob-slot (slot) + (get-keywords '(:name :type :db-kind :column) slot))) + (let ((all-slots (mapcar #'frob-slot slots))) + (setq all-slots (remove-if #'not-db-col all-slots)) + (setq all-slots (stable-sort all-slots #'string< :key #'car)) + (setf (object-definition class) all-slots)) + #-(or sbcl allegro) + (setf (key-slots class) (remove-if-not (lambda (slot) + (eql (slot-value slot 'db-kind) + :key)) + (slots-for-possibly-normalized-class class))))) + +#+(or sbcl allegro) +(defmethod finalize-inheritance :after ((class standard-db-class)) + (setf (key-slots class) (remove-if-not (lambda (slot) + (eql (slot-value slot 'db-kind) + :key)) + (slots-for-possibly-normalized-class class)))) + +;; return the deepest view-class ancestor for a given view class + +(defun base-db-class (classname) + (let* ((class (find-class classname)) + (db-class (find-class 'standard-db-object))) + (loop + (let ((cds (class-direct-superclasses class))) + (cond ((null cds) + (error "not a db class")) + ((member db-class cds) + (return (class-name class)))) + (setq class (car cds)))))) + +(defun db-ancestors (classname) + (let ((class (find-class classname)) + (db-class (find-class 'standard-db-object))) + (labels ((ancestors (class) + (let ((scs (class-direct-superclasses class))) + (if (member db-class scs) + (list class) + (append (list class) (mapcar #'ancestors scs)))))) + (ancestors class)))) + +(defclass view-class-slot-definition-mixin () + ((column + :accessor view-class-slot-column + :initarg :column + :documentation + "The name of the SQL column this slot is stored in. Defaults to +the slot name.") + (db-kind + :accessor view-class-slot-db-kind + :initarg :db-kind + :initform :base + ;; openmcl 0.14.2 stores the value as list in the DSD + ;; :type (or list keyword) + #-openmcl :type #-openmcl keyword + :documentation + "The kind of DB mapping which is performed for this slot. :base +indicates the slot maps to an ordinary column of the DB view. :key +indicates that this slot corresponds to part of the unique keys for +this view, :join indicates ... and :virtual indicates that this slot +is an ordinary CLOS slot. Defaults to :base.") + (db-reader + :accessor view-class-slot-db-reader + :initarg :db-reader + :initform nil + :documentation + "If a string, then when reading values from the DB, the string +will be used for a format string, with the only value being the value +from the database. The resulting string will be used as the slot +value. If a function then it will take one argument, the value from +the database, and return the value that should be put into the slot.") + (db-writer + :accessor view-class-slot-db-writer + :initarg :db-writer + :initform nil + :documentation + "If a string, then when reading values from the slot for the DB, +the string will be used for a format string, with the only value being +the value of the slot. The resulting string will be used as the +column value in the DB. If a function then it will take one argument, +the value of the slot, and return the value that should be put into +the database.") + (db-type + :accessor view-class-slot-db-type + :initarg :db-type + :initform nil + :documentation + "A string which will be used as the type specifier for this slots +column definition in the database.") + (db-constraints + :accessor view-class-slot-db-constraints + :initarg :db-constraints + :initform nil + :documentation + "A keyword symbol representing a single SQL column constraint or list of such symbols.") + (void-value + :accessor view-class-slot-void-value + :initarg :void-value + :initform nil + :documentation + "Value to store if the SQL value is NULL. Default is NIL.") + (db-info + :accessor view-class-slot-db-info + :initarg :db-info + :documentation "Description of the join.") + (specified-type + :accessor specified-type + :initarg specified-type + :initform nil + :documentation "Internal slot storing the :type specified by user.") + (autoincrement-sequence + :accessor view-class-slot-autoincrement-sequence + :initarg :autoincrement-sequence + :initform nil + :documentation "A string naming the (possibly automatically generated) sequence +for a slot with an :auto-increment constraint."))) + +(defparameter *db-info-lambda-list* + '(&key join-class + home-key + foreign-key + (key-join nil) + (target-slot nil) + (retrieval :immmediate) + (set nil))) + +(defun parse-db-info (db-info-list) + (destructuring-bind + (&key join-class home-key key-join foreign-key (delete-rule nil) + (target-slot nil) (retrieval :deferred) (set t)) + db-info-list + (let ((ih (make-hash-table :size 6))) + (if join-class + (setf (gethash :join-class ih) join-class) + (error "Must specify :join-class in :db-info")) + (if home-key + (setf (gethash :home-key ih) home-key) + (error "Must specify :home-key in :db-info")) + (when delete-rule + (setf (gethash :delete-rule ih) delete-rule)) + (if foreign-key + (setf (gethash :foreign-key ih) foreign-key) + (error "Must specify :foreign-key in :db-info")) + (when key-join + (setf (gethash :key-join ih) t)) + (when target-slot + (setf (gethash :target-slot ih) target-slot)) + (when set + (setf (gethash :set ih) set)) + (when retrieval + (progn + (setf (gethash :retrieval ih) retrieval) + (if (eql retrieval :immediate) + (setf (gethash :set ih) nil)))) + ih))) + +(defclass view-class-direct-slot-definition (view-class-slot-definition-mixin + standard-direct-slot-definition) + ()) + +(defclass view-class-effective-slot-definition (view-class-slot-definition-mixin + standard-effective-slot-definition) + ()) + +(defmethod direct-slot-definition-class ((class standard-db-class) + #+kmr-normal-dsdc &rest + initargs) + (declare (ignore initargs)) + (find-class 'view-class-direct-slot-definition)) + +(defmethod effective-slot-definition-class ((class standard-db-class) + #+kmr-normal-esdc &rest + initargs) + (declare (ignore initargs)) + (find-class 'view-class-effective-slot-definition)) + +#+openmcl +(when (not (symbol-function 'compute-class-precedence-list)) + (eval + (defun compute-class-precedence-list (class) + (class-precedence-list class)))) + +#-mop-slot-order-reversed +(defmethod compute-slots ((class standard-db-class)) + "Need to sort order of class slots so they are the same across +implementations." + (let ((slots (call-next-method)) + desired-sequence + output-slots) + (dolist (c (compute-class-precedence-list class)) + (dolist (s (class-direct-slots c)) + (let ((name (slot-definition-name s))) + (unless (find name desired-sequence) + (push name desired-sequence))))) + (dolist (desired desired-sequence) + (let ((slot (find desired slots :key #'slot-definition-name))) + (assert slot) + (push slot output-slots))) + output-slots)) + +(defun compute-lisp-type-from-specified-type (specified-type db-constraints) + "Computes the Lisp type for a user-specified type." + (let ((type + (cond + ((consp specified-type) + (let* ((first (first specified-type)) + (name (etypecase first + (symbol (symbol-name first)) + (string first)))) + (cond + ((or (string-equal name "string") + (string-equal name "varchar") + (string-equal name "char")) + 'string) + (t + specified-type)))) + ((eq (ensure-keyword specified-type) :bigint) + 'integer) + ((eq (ensure-keyword specified-type) :char) + 'character) + ((eq (ensure-keyword specified-type) :varchar) + 'string) + (t + specified-type)))) + (if (and type (not (member :not-null (listify db-constraints)))) + `(or null ,type) + (or type t)))) + +;; Compute the slot definition for slots in a view-class. Figures out +;; what kind of database value (if any) is stored there, generates and +;; verifies the column name. + +(declaim (inline delistify)) +(defun delistify (list) + "Some MOPs, like openmcl 0.14.2, cons attribute values in a list." + (if (listp list) + (car list) + list)) + +(declaim (inline delistify-dsd)) +;; there is an :after method below too +(defmethod initialize-instance :around + ((obj view-class-direct-slot-definition) + &rest initargs &key db-constraints db-kind type &allow-other-keys) + (when (and (not db-kind) (member :primary-key (listify db-constraints))) + (warn "Slot ~S constrained to be :primary-key, but not marked as :db-kind :key" + (slot-definition-name obj))) + (apply #'call-next-method obj + 'specified-type type + :type (if (and (eql db-kind :virtual) (null type)) + t + (compute-lisp-type-from-specified-type + type db-constraints)) + initargs)) + +(defun compute-column-name (arg) + (database-identifier arg nil)) + +(defun %convert-db-info-to-hash (slot-def) + ;; I wonder if this slot option and the previous could be merged, + ;; so that :base and :key remain keyword options, but :db-kind + ;; :join becomes :db-kind (:join <db info .... >)? + (setf (slot-value slot-def 'db-info) + (when (slot-boundp slot-def 'db-info) + (let ((info (view-class-slot-db-info slot-def))) + (etypecase info + (hash-table info) + (atom info) + (list + (cond ((and (> (length info) 1) + (atom (car info))) + (parse-db-info info)) + ((and (= 1 (length info)) + (listp (car info))) + (parse-db-info (car info))) + (t info)))))))) + +(defmethod initialize-instance :after + ((obj view-class-direct-slot-definition) + &key &allow-other-keys) + (setf (view-class-slot-column obj) (compute-column-name obj) + (view-class-slot-autoincrement-sequence obj) + (dequote + (view-class-slot-autoincrement-sequence obj))) + (%convert-db-info-to-hash obj)) + +(defmethod compute-effective-slot-definition ((class standard-db-class) + #+kmr-normal-cesd slot-name + direct-slots) + #+kmr-normal-cesd (declare (ignore slot-name)) + + ;; KMR: store the user-specified type and then compute + ;; real Lisp type and store it + (let ((dsd (car direct-slots))) + (let ((esd (call-next-method))) + (typecase dsd + (view-class-slot-definition-mixin + (setf (slot-value esd 'column) (compute-column-name dsd)) + + (macrolet + ((safe-copy-value (name &optional default) + (let ((fn (intern (format nil "~A~A" 'view-class-slot- name )))) + `(setf (slot-value esd ',name) + (or (when (slot-boundp dsd ',name) + (delistify-dsd (,fn dsd))) + ,default))))) + (safe-copy-value autoincrement-sequence) + (safe-copy-value db-type) + (safe-copy-value void-value) + (safe-copy-value db-reader) + (safe-copy-value db-writer) + ;; :db-kind slot value defaults to :base (store slot value in + ;; database) + (safe-copy-value db-kind :base) + (safe-copy-value db-constraints) + (safe-copy-value db-info) + (%convert-db-info-to-hash esd)) + + (setf (specified-type esd) + (delistify-dsd (specified-type dsd))) + ;; In older SBCL's the type-check-function is computed at + ;; defclass expansion, which is too early for the CLSQL type + ;; conversion to take place. This gets rid of it. It's ugly + ;; but it's better than nothing -wcp10/4/10. + #+(and sbcl #.(cl:if (cl:and (cl:find-package :sb-pcl) + (cl:find-symbol "%TYPE-CHECK-FUNCTION" :sb-pcl)) + '(cl:and) '(cl:or))) + (setf (slot-value esd 'sb-pcl::%type-check-function) nil) + + ) + ;; all other slots + (t + (unless (typep esd 'view-class-effective-slot-definition) + (warn "Non view-class-direct-slot object with non-view-class-effective-slot-definition in compute-effective-slot-definition") + + (let ((type-predicate #+openmcl (slot-value esd 'ccl::type-predicate))) + #-openmcl (declare (ignore type-predicate)) + #-(or clisp sbcl) (change-class esd 'view-class-effective-slot-definition + #+allegro :name + #+allegro (slot-definition-name dsd)) + #+openmcl (setf (slot-value esd 'ccl::type-predicate) + type-predicate))) + + ;; has no column name if it is not a database column + (setf (slot-value esd 'column) nil) + (setf (slot-value esd 'db-info) nil) + (setf (slot-value esd 'db-kind) :virtual) + (setf (specified-type esd) (slot-definition-type dsd))) + ) + esd))) + +(defun slotdefs-for-slots-with-class (slots class) + (let ((result nil)) + (dolist (s slots) + (let ((c (slotdef-for-slot-with-class s class))) + (if c (setf result (cons c result))))) + result)) + +(defun slotdef-for-slot-with-class (slot class) + (typecase slot + (standard-slot-definition slot) + (symbol (find-slot-by-name class slot)))) + +#+ignore +(eval-when (:compile-toplevel :load-toplevel :execute) + #+kmr-normal-cesd + (setq cl:*features* (delete :kmr-normal-cesd cl:*features*)) + #+kmr-normal-dsdc + (setq cl:*features* (delete :kmr-normal-dsdc cl:*features*)) + #+kmr-normal-esdc + (setq cl:*features* (delete :kmr-normal-esdc cl:*features*)) + ) + +(defmethod database-identifier ( (name standard-db-class) + &optional database find-class-p) + "the majority of this function is in expressions.lisp + this is here to make loading be less painful (try-recompiles) in SBCL" + (declare (ignore find-class-p)) + (database-identifier (view-table name) database)) + +(defmethod database-identifier ((name view-class-slot-definition-mixin) + &optional database find-class-p) + (declare (ignore find-class-p)) + (database-identifier + (if (slot-boundp name 'column) + (delistify-dsd (view-class-slot-column name)) + (slot-definition-name name)) + database)) + +(defun find-standard-db-class (name &aux cls) + (and (setf cls (ignore-errors (find-class name))) + (typep cls 'standard-db-class) + cls)) + +(defun slots-for-possibly-normalized-class (class) + "Get the slots for this class, if normalized this is only the direct slots + otherwiese its all the slots" + (if (normalizedp class) + (ordered-class-direct-slots class) + (ordered-class-slots class))) + + +(defun key-slot-p (slot-def) + "takes a slot def and returns whether or not it is a key" + (eql :key (view-class-slot-db-kind slot-def))) + +(defun join-slot-p (slot-def) + "takes a slot def and returns whether or not it is a join slot" + (eql :join (view-class-slot-db-kind slot-def))) + +(defun join-slot-info-value (slot-def key) + "Get the join-slot db-info value associated with a key" + (when (join-slot-p slot-def) + (let ((dbi (view-class-slot-db-info slot-def))) + (when dbi (gethash key dbi))))) + +(defun join-slot-retrieval-method (slot-def) + "if this is a join slot return the retrieval param in the db-info" + (join-slot-info-value slot-def :retrieval)) + +(defun join-slot-class-name (slot-def) + "get the join class name for a given join slot" + (join-slot-info-value slot-def :join-class)) + +(defun join-slot-class (slot-def) + "Get the join class for a given join slot" + (let ((c (join-slot-class-name slot-def))) + (when c (find-class c)))) + +(defun key-or-base-slot-p (slot-def) + "takes a slot def and returns whether or not it is a key" + (member (view-class-slot-db-kind slot-def) '(:key :base))) + +(defun direct-normalized-slot-p (class slot-name) + "Is this a normalized class and if so is the slot one of our direct slots?" + (setf slot-name (to-slot-name slot-name)) + (and (typep class 'standard-db-class) + (normalizedp class) + (member slot-name (ordered-class-direct-slots class) + :key #'slot-definition-name))) + +(defun not-direct-normalized-slot-p (class slot-name) + "Is this a normalized class and if so is the slot not one of our direct slots?" + (setf slot-name (to-slot-name slot-name)) + (and (typep class 'standard-db-class) + (normalizedp class) + (not (member slot-name (ordered-class-direct-slots class) + :key #'slot-definition-name)))) + +(defun slot-has-default-p (slot) + "returns nil if the slot does not have a default constraint" + (let* ((constraints + (when (typep slot '(or view-class-direct-slot-definition + view-class-effective-slot-definition)) + (listify (view-class-slot-db-constraints slot))))) + (member :default constraints))) + diff --git a/sql/ooddl.lisp b/sql/ooddl.lisp new file mode 100644 index 0000000..5832283 --- /dev/null +++ b/sql/ooddl.lisp @@ -0,0 +1,248 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; +;;;; The CLSQL Object Oriented Data Definitional Language (OODDL) +;;;; +;;;; 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 standard-db-object () + ((view-database :initform nil :initarg :view-database :reader view-database + :db-kind :virtual)) + (:metaclass standard-db-class) + (:documentation "Superclass for all CLSQL View Classes.")) + +(defparameter *default-string-length* 255 + "The length of a string which does not have a user-specified length.") + +(defvar *db-auto-sync* nil + "A non-nil value means that creating View Class instances or + setting their slots automatically creates/updates the + corresponding records in the underlying database.") + +(defvar *db-deserializing* nil) +(defvar *db-initializing* nil) + +(defmethod slot-value-using-class ((class standard-db-class) instance slot-def) + "When a slot is unbound but should contain a join object or a value from a + normalized view-class, then retrieve and set those slots, so the value can + be returned" + (declare (optimize (speed 3))) + (unless *db-deserializing* + (let* ((slot-name (%svuc-slot-name slot-def)) + (slot-object (%svuc-slot-object slot-def class))) + (unless (slot-boundp instance slot-name) + (let ((*db-deserializing* t)) + (cond + ((join-slot-p slot-def) + (setf (slot-value instance slot-name) + (if (view-database instance) + (fault-join-slot class instance slot-object) + ;; TODO: you could in theory get a join object even if + ;; its joined-to object was not in the database + nil + ))) + ((not-direct-normalized-slot-p class slot-def) + (if (view-database instance) + (update-fault-join-normalized-slot class instance slot-def) + (setf (slot-value instance slot-name) nil)))))))) + (call-next-method)) + +(defmethod (setf slot-value-using-class) (new-value (class standard-db-class) + instance slot-def) + "Handle auto syncing values to the database if *db-auto-sync* is t" + (declare (ignore new-value)) + (let* ((slot-name (%svuc-slot-name slot-def)) + (slot-object (%svuc-slot-object slot-def class)) + (slot-kind (view-class-slot-db-kind slot-object))) + (prog1 + (call-next-method) + (when (and *db-auto-sync* + (not *db-initializing*) + (not *db-deserializing*) + (not (eql slot-kind :virtual))) + (update-record-from-slot instance slot-name))))) + +(defmethod initialize-instance ((object standard-db-object) + &rest all-keys &key &allow-other-keys) + (declare (ignore all-keys)) + (let ((*db-initializing* t)) + (call-next-method) + (when (and *db-auto-sync* + (not *db-deserializing*)) + (update-records-from-instance object)))) + +;; +;; Build the database tables required to store the given view class +;; + +(defun create-view-from-class (view-class-name + &key (database *default-database*) + (transactions t)) + "Creates a table as defined by the View Class VIEW-CLASS-NAME +in DATABASE which defaults to *DEFAULT-DATABASE*." + (let ((tclass (find-class view-class-name))) + (if tclass + (let ((*default-database* database) + (pclass (car (class-direct-superclasses tclass)))) + (when (and (normalizedp tclass) (not (table-exists-p pclass))) + (create-view-from-class (class-name pclass) + :database database :transactions transactions)) + (%install-class tclass database :transactions transactions)) + (error "Class ~s not found." view-class-name))) + (values)) + +(defmethod auto-increment-column-p (slotdef &optional (database clsql-sys:*default-database*)) + (declare (ignore database)) + (or (intersection + +auto-increment-names+ + (listify (view-class-slot-db-constraints slotdef))) + (slot-value slotdef 'autoincrement-sequence))) + +(defmethod %install-class ((self standard-db-class) database + &key (transactions t)) + (let ((schemadef '()) + (ordered-slots (slots-for-possibly-normalized-class self))) + (dolist (slotdef ordered-slots) + (let ((res (database-generate-column-definition self slotdef database))) + (when res + (push res schemadef)))) + (if (not schemadef) + (unless (normalizedp self) + (error "Class ~s has no :base slots" self)) + (progn + (database-add-autoincrement-sequence self database) + (create-table (sql-expression :table (database-identifier self database)) + (nreverse schemadef) + :database database + :transactions transactions + :constraints (database-pkey-constraint self database)) + (push self (database-view-classes database))))) + t) + +(defmethod database-pkey-constraint ((class standard-db-class) database) + ;; Keylist will always be a list of escaped-indentifier + (let ((keylist (mapcar #'(lambda (x) (escaped-database-identifier x database)) + (keyslots-for-class class))) + (table (escaped (combine-database-identifiers + (list class 'PK) + database)))) + (when keylist + (format nil "CONSTRAINT ~A PRIMARY KEY (~{~A~^,~})" table + keylist)))) + +(defmethod database-generate-column-definition (class slotdef database) + (declare (ignore class)) + (when (key-or-base-slot-p slotdef) + (let ((cdef + (list (sql-expression :attribute (database-identifier slotdef database)) + (specified-type slotdef)))) + (setf cdef (append cdef (list (view-class-slot-db-type slotdef)))) + (let ((const (view-class-slot-db-constraints slotdef))) + (when const + (setq cdef (append cdef (listify const))))) + cdef))) + + +;; +;; Drop the tables which store the given view class +;; + +(defun drop-view-from-class (view-class-name &key (database *default-database*) + (owner nil)) + "Removes a table defined by the View Class VIEW-CLASS-NAME from +DATABASE which defaults to *DEFAULT-DATABASE*." + (let ((tclass (find-class view-class-name))) + (if tclass + (let ((*default-database* database)) + (%uninstall-class tclass :owner owner)) + (error "Class ~s not found." view-class-name))) + (values)) + +(defun %uninstall-class (self &key + (database *default-database*) + (owner nil)) + (drop-table (sql-expression :table (database-identifier self database)) + :if-does-not-exist :ignore + :database database + :owner owner) + (database-remove-autoincrement-sequence self database) + (setf (database-view-classes database) + (remove self (database-view-classes database)))) + + +;; +;; List all known view classes +;; + +(defun list-classes (&key (test #'identity) + (root-class (find-class 'standard-db-object)) + (database *default-database*)) + "Returns a list of all the View Classes which are connected to +DATABASE, which defaults to *DEFAULT-DATABASE*, and which descend +from the class ROOT-CLASS and which satisfy the function TEST. By +default ROOT-CLASS is STANDARD-DB-OBJECT and TEST is IDENTITY." + (flet ((find-superclass (class) + (member root-class (class-precedence-list class)))) + (let ((view-classes (and database (database-view-classes database)))) + (when view-classes + (remove-if #'(lambda (c) (or (not (funcall test c)) + (not (find-superclass c)))) + view-classes))))) + +;; +;; Define a new view class +;; + +(defmacro def-view-class (class supers slots &rest cl-options) + "Creates a View Class called CLASS whose slots SLOTS can map +onto the attributes of a table in a database. If SUPERS is nil +then the superclass of CLASS will be STANDARD-DB-OBJECT, +otherwise SUPERS is a list of superclasses for CLASS which must +include STANDARD-DB-OBJECT or a descendent of this class. The +syntax of DEFCLASS is extended through the addition of a class +option :base-table which defines the database table onto which +the View Class maps and which defaults to CLASS. The DEFCLASS +syntax is also extended through additional slot +options. The :db-kind slot option specifies the kind of DB +mapping which is performed for this slot and defaults to :base +which indicates that the slot maps to an ordinary column of the +database table. A :db-kind value of :key indicates that this slot +is a special kind of :base slot which maps onto a column which is +one of the unique keys for the database table, the value :join +indicates this slot represents a join onto another View Class +which contains View Class objects, and the value :virtual +indicates a standard CLOS slot which does not map onto columns of +the database table. If a slot is specified with :db-kind :join, +the slot option :db-info contains a list which specifies the +nature of the join. For slots of :db-kind :base or :key, +the :type slot option has a special interpretation such that Lisp +types, such as string, integer and float are automatically +converted into appropriate SQL types for the column onto which +the slot maps. This behaviour may be over-ridden using +the :db-type slot option which is a string specifying the +vendor-specific database type for this slot's column definition +in the database. The :column slot option specifies the name of +the SQL column which the slot maps onto, if :db-kind is +not :virtual, and defaults to the slot name. The :void-value slot +option specifies the value to store if the SQL value is NULL and +defaults to NIL. The :db-constraints slot option is a string +representing an SQL table constraint expression or a list of such +strings." + `(progn + (defclass ,class ,supers ,slots + ,@(if (find :metaclass `,cl-options :key #'car) + `,cl-options + (cons '(:metaclass clsql-sys::standard-db-class) `,cl-options))) + (finalize-inheritance (find-class ',class)) + (find-class ',class))) + +(defun keyslots-for-class (class) + (slot-value class 'key-slots)) diff --git a/sql/oodml.lisp b/sql/oodml.lisp new file mode 100644 index 0000000..072bc4a --- /dev/null +++ b/sql/oodml.lisp @@ -0,0 +1,1353 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; +;;;; The CLSQL Object Oriented Data Manipulation Language (OODML). +;;;; +;;;; 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 find-normalized-key (obj) + "Find the first / primary key of a normalized object" + (find-slot-if obj #'key-slot-p T T)) + +(defun normalized-key-value (obj) + "Normalized classes share a single key for all their key slots" + (when (normalizedp (class-of obj)) + (easy-slot-value obj (find-normalized-key obj)))) + +(defun key-qualifier-for-instance (obj &key (database *default-database*) this-class) + "Generate a boolean sql-expression that identifies an object by its keys" + (let* ((obj-class (or this-class (class-of obj))) + (keys (keyslots-for-class obj-class)) + (normal-db-value (normalized-key-value obj))) + (when keys + (labels ((db-value (k) + (or normal-db-value + (db-value-from-slot + k + (easy-slot-value obj k) + database))) + (key-equal-exp (k) + (sql-operation '== (generate-attribute-reference obj-class k database) + (db-value k)))) + (clsql-ands (mapcar #'key-equal-exp keys)))))) + +(defun generate-attribute-reference (vclass slotdef &optional (database *default-database*)) + "Turns key class and slot-def into a sql-expression representing the + table and column it comes from + + used by things like make-select-list, update-slot-from-record" + (when (key-or-base-slot-p slotdef) + (sql-expression :attribute (database-identifier slotdef database) + :table (database-identifier vclass database)))) + +(defun get-join-slots (class &optional retrieval-method) + "Returns list of join slots for a class. + + if a retrieval method is specified only return slots of that type + if the retrieval method is T, nil or :all return all join slots" + (assert (member retrieval-method '(nil t :all :immediate :deferred))) + (setf class (to-class class)) + (let ((all? (member retrieval-method '(nil t :all)))) + (loop for slot in (ordered-class-slots class) + when (and (join-slot-p slot) + (or all? (eql (join-slot-retrieval-method slot) retrieval-method))) + collect slot))) + +(defun immediate-join-slots (class) + (get-join-slots class :immediate)) + +(defmethod choose-database-for-instance ((obj standard-db-object) &optional database) + "Determine which database connection to use for a standard-db-object. + Errs if none is available." + (or (find-if #'(lambda (db) + (and db (is-database-open db))) + (list (view-database obj) + database + *default-database*)) + (signal-no-database-error nil))) + + + +(defmethod update-slot-with-null ((object standard-db-object) slotdef) + "sets a slot to the void value of the slot-def (usually nil)" + (setf (easy-slot-value object slotdef) + (slot-value slotdef 'void-value))) + +(defmethod update-slot-from-db-value ((instance standard-db-object) slotdef value) + "This gets a value from the database and turns it itno a lisp value + based on the slot's slot-db-reader or baring that read-sql-value" + (declare (optimize (speed 3) #+cmu (extensions:inhibit-warnings 3))) + (let* ((slot-reader (view-class-slot-db-reader slotdef)) + (slot-type (specified-type slotdef))) + (cond + ((null value) (update-slot-with-null instance slotdef)) + ((null slot-reader) + (setf (easy-slot-value instance slotdef) + (read-sql-value value (delistify slot-type) + (choose-database-for-instance instance) + (database-underlying-type + (choose-database-for-instance instance))))) + (t (etypecase slot-reader + ((or symbol function) + (setf (easy-slot-value instance slotdef) + (apply slot-reader (list value)))) + (string + (setf (easy-slot-value instance slotdef) + (format nil slot-reader value)))))))) + +(defmethod key-value-from-db (slotdef value database) + "TODO: is this deprecated? there are no uses anywhere in clsql" + (declare (optimize (speed 3) #+cmu (extensions:inhibit-warnings 3))) + (let ((slot-reader (view-class-slot-db-reader slotdef)) + (slot-type (specified-type slotdef))) + (cond ((and value (null slot-reader)) + (read-sql-value value (delistify slot-type) database + (database-underlying-type database))) + ((null value) + nil) + ((typep slot-reader 'string) + (format nil slot-reader value)) + ((typep slot-reader '(or symbol function)) + (apply slot-reader (list value))) + (t + (error "Slot reader is of an unusual type."))))) + +(defun db-value-from-slot (slotdef val database) + (let ((dbwriter (view-class-slot-db-writer slotdef)) + (dbtype (specified-type slotdef))) + (typecase dbwriter + (string (format nil dbwriter val)) + ((and (or symbol function) (not null)) (apply dbwriter (list val))) + (t + (database-output-sql-as-type + (typecase dbtype + (cons (car dbtype)) + (t dbtype)) + val database (database-underlying-type database)))))) + +(defun check-slot-type (slotdef val) + (let* ((slot-type (specified-type slotdef)) + (basetype (if (listp slot-type) (car slot-type) slot-type))) + (when (and slot-type val) + (unless (typep val basetype) + (error 'sql-user-error + :message + (format nil "Invalid value ~A in slot ~A, not of type ~A." + val (slot-definition-name slotdef) slot-type)))))) + +(defmethod get-slot-values-from-view (obj slotdeflist values) + "Used to copy values from the database into the object + used by things like find-all and select" + (loop for slot in slotdeflist + for value in values + do (update-slot-from-db-value obj slot value)) + obj) + +(defclass class-and-slots () + ((view-class :accessor view-class :initarg :view-class :initform nil) + (slot-defs :accessor slot-defs :initarg :slot-defs :initform nil)) + (:documentation "A helper class to keep track of which slot-defs from a + table need to be updated, a normalized class might have many of these + because each of its parent classes might represent some other table and we + need to match which slots came from which parent class/table")) + +(defun make-class-and-slots (c &optional s) + "Create a new class-and-slots object" + (make-instance 'class-and-slots :view-class c :slot-defs (listify s) )) + +(defmethod view-table ((o class-and-slots)) + "get the view-table of the view-class of o" + (view-table (view-class o))) + +(defmethod view-table-exp ((o class-and-slots)) + (sql-expression :table (view-table o))) + +(defmethod view-table-exp ((o standard-db-class)) + (sql-expression :table (view-table o))) + +(defmethod attribute-references ((o class-and-slots)) + "build sql-ident-attributes for a given class-and-slots" + (loop + with class = (view-class o) + for sd in (slot-defs o) + collect (generate-attribute-reference class sd))) + +(defmethod attribute-value-pairs ((def class-and-slots) (o standard-db-object) + database) + "for a given class-and-slots and object, create the sql-expression & value pairs + that need to be sent to the database" + (loop for s in (slot-defs def) + for n = (to-slot-name s) + when (slot-boundp o n) + collect (make-attribute-value-pair s (slot-value o n) database))) + +(defmethod view-classes-and-slots-by-name ((obj standard-db-object) slots-to-match) + "If it's normalized, find the class that actually contains + the slot that's tied to the db, + + otherwise just search the current class + " + (let* ((view-class (class-of obj)) + (normalizedp (normalizedp view-class)) + rtns) + (labels ((get-c&s-obj (class) + (or (find class rtns :key #'view-class) + (first (push (make-class-and-slots class) rtns)))) + (associate-slot-with-class (class slot) + "Find the best class to associate with the slot. If it is + normalized then it needs to be a direct slot otherwise it just + needs to be on the class." + (let ((sd (find-slot-by-name class slot normalizedp nil))) + (if sd + ;;we found it directly or it's (not normalized) + (pushnew sd (slot-defs (get-c&s-obj class))) + (when normalizedp + (loop for parent in (class-direct-superclasses class) + until (associate-slot-with-class parent slot)))) + sd))) + (loop + for in-slot in (listify slots-to-match) + do (associate-slot-with-class view-class in-slot))) + rtns)) + +(defun update-auto-increments-keys (class obj database) + " handle pulling any autoincrement values into the object + Also handles normalized key chaining" + (let ((pk-slots (keyslots-for-class class)) + (table (view-table class)) + new-pk-value) + (labels ((do-update (slot &aux (val (easy-slot-value obj slot))) + (if val + (setf new-pk-value val) + (update-slot-from-db-value + obj slot + (or new-pk-value + (setf new-pk-value + (database-last-auto-increment-id + database table slot)))))) + ;; NB: This interacts very strangely with autoincrement keys + ;; (see changelog 2014-01-30) + (chain-primary-keys (in-class) + "This seems kindof wrong, but this is mostly how it was working, so + its here to keep the normalized code path working" + (when (typep in-class 'standard-db-class) + (loop for slot in (ordered-class-slots in-class) + when (key-slot-p slot) + do (do-update slot))))) + (loop for slot in pk-slots do (do-update slot)) + (let ((direct-class (to-class obj))) + (when (and new-pk-value (normalizedp direct-class)) + (chain-primary-keys direct-class))) + new-pk-value))) + +(defmethod %update-instance-helper + (class-and-slots obj database + &aux (avps (attribute-value-pairs class-and-slots obj database))) + "A function to help us update a given table (based on class-and-slots) + with values from an object" + ;; we dont actually need to update anything on this particular + ;; class / parent class + (unless avps (return-from %update-instance-helper)) + + (let* ((view-class (view-class class-and-slots)) + (table (view-table view-class)) + (table-sql (sql-expression :table table))) + + ;; view database is the flag we use to tell it was pulled from a database + ;; and thus probably needs an update instead of an insert + (cond ((view-database obj) + (let ((where (key-qualifier-for-instance + obj :database database :this-class view-class))) + (unless where + (error "update-record-from-*: could not generate a where clause for ~a using ~A" + obj view-class)) + (update-records table-sql + :av-pairs avps + :where where + :database database))) + (T ;; was not pulled from the db so insert it + ;; avps MUST contain any primary key slots set + ;; by previous inserts of the same object into different + ;; tables (ie: normalized stuff) + (insert-records :into table-sql + :av-pairs avps + :database database) + ;; also handles normalized-class key chaining + (update-auto-increments-keys view-class obj database) + ;; we dont set view database here, because there could be + ;; N of these for each call to update-record-from-* because + ;; of normalized classes + )) + (update-slot-default-values obj class-and-slots))) + +(defmethod update-record-from-slots ((obj standard-db-object) slots + &key (database *default-database*)) + "For a given list of slots, update all records associated with those slots + and classes. + + Generally this will update the single record associated with this object, + but for normalized classes might update as many records as there are + inheritances " + (setf slots (listify slots)) + (let* ((classes-and-slots (view-classes-and-slots-by-name obj slots)) + (database (choose-database-for-instance obj database))) + (loop for class-and-slots in classes-and-slots + do (%update-instance-helper class-and-slots obj database)) + (setf (slot-value obj 'view-database) database)) + (values)) + +(defmethod update-record-from-slot + ((obj standard-db-object) slot &key (database *default-database*)) + "just call update-records-from-slots which now handles this. + + This function is only here to maintain backwards compatibility in + the public api" + (update-record-from-slots obj slot :database database)) + +(defmethod view-classes-and-storable-slots (class &key to-database-p) + "Get a list of all the tables we need to update and the slots on them + + for non normalized classes we return the class and all its storable slots + + for normalized classes we return a list of direct slots and the class they + came from for each normalized view class + + to-database-p is provided so that we can read / write different data + to the database in different circumstances + (specifically clsql-helper:dirty-db-slots-mixin which only updates slots + that have changed ) + " + (setf class (to-class class)) + (let* (rtns) + (labels ((storable-slots (class) + (loop for sd in (slots-for-possibly-normalized-class class) + when (and (key-or-base-slot-p sd) + ;; we dont want to insert/update auto-increments + ;; but we do read them + (not (and to-database-p (auto-increment-column-p sd)))) + collect sd)) + (get-classes-and-slots (class &aux (normalizedp (normalizedp class))) + (let ((slots (storable-slots class))) + (when slots + (push (make-class-and-slots class slots) rtns))) + (when normalizedp + (loop for new-class in (class-direct-superclasses class) + do (when (typep new-class 'standard-db-class) + (get-classes-and-slots new-class)))))) + (get-classes-and-slots class)) + rtns)) + +(defmethod primary-key-slot-values ((obj standard-db-object) + &key class slots ) + "Returns the values of all key-slots for a given class" + (defaulting class (class-of obj) + slots (keyslots-for-class class)) + (loop for slot in slots + collect (easy-slot-value obj slot))) + +(defmethod update-slot-default-values ((obj standard-db-object) + classes-and-slots) + "Makes sure that if a class has unfilled slots that claim to have a default, + that we retrieve those defaults from the database + + TODO: use update-slots-from-record (doesnt exist) instead to batch this!" + (loop for class-and-slots in (listify classes-and-slots) + do (loop for slot in (slot-defs class-and-slots) + do (when (and (slot-has-default-p slot) + (not (easy-slot-value obj slot))) + (update-slot-from-record obj (to-slot-name slot)))))) + +(defmethod update-records-from-instance ((obj standard-db-object) + &key (database *default-database*)) + "Updates the records in the database associated with this object if + view-database slot on the object is nil then the object is assumed to be + new and is inserted" + (let ((database (choose-database-for-instance obj database)) + (classes-and-slots (view-classes-and-storable-slots obj :to-database-p t))) + (loop for class-and-slots in classes-and-slots + do (%update-instance-helper class-and-slots obj database)) + (setf (slot-value obj 'view-database) database) + (primary-key-slot-values obj))) + +(defmethod delete-instance-records ((instance standard-db-object) &key database) + "Removes the records associated with a given instance + (as determined by key-qualifier-for-instance) + + TODO: Doesnt handle normalized classes at all afaict" + (let ((database (choose-database-for-instance instance database)) + (vt (sql-expression :table (view-table (class-of instance))))) + (if database + (let ((qualifier (key-qualifier-for-instance instance :database database))) + (delete-records :from vt :where qualifier :database database) + (setf (record-caches database) nil) + (setf (slot-value instance 'view-database) nil) + (values)) + (signal-no-database-error database)))) + +(defmethod update-instance-from-records ((instance standard-db-object) + &key (database *default-database*)) + "Updates a database object with the current values stored in the database + + TODO: Should this update immediate join slots similar to build-objects? + Can we just call build-objects?, update-objects-joins? + " + + (let* ((classes-and-slots (view-classes-and-storable-slots + instance :to-database-p nil)) + (vd (choose-database-for-instance instance database))) + (labels ((do-update (class-and-slots) + (let* ((select-list (make-select-list class-and-slots + :do-joins-p nil + :database database)) + (view-table (sql-table select-list)) + (view-qual (key-qualifier-for-instance + instance :database vd + :this-class (view-class select-list))) + (res (when view-qual + (first + (apply #'select + (append (full-select-list select-list) + (list :from view-table + :where view-qual + :result-types nil + :database vd))))))) + (when res + (setf (slot-value instance 'view-database) vd) + (get-slot-values-from-view instance (slot-list select-list) res)) + ))) + (loop for class-and-slots in classes-and-slots + do (do-update class-and-slots))))) + + +(defmethod get-slot-value-from-record ((instance standard-db-object) + slot &key (database *default-database*)) + (let* ((class-and-slot + (first + (view-classes-and-slots-by-name instance slot))) + (view-class (view-class class-and-slot)) + (slot-def (first (slot-defs class-and-slot))) + (vd (choose-database-for-instance instance database)) + (att-ref (first (attribute-references class-and-slot))) + (res (first + (select att-ref + :from (view-table-exp class-and-slot) + :where (key-qualifier-for-instance + instance + :database vd + :this-class view-class) + :result-types nil + :flatp T)))) + (values res slot-def))) + +(defmethod update-slot-from-record ((instance standard-db-object) + slot &key (database *default-database*)) + "Pulls the value of a given slot form the database and stores that in the + appropriate slot on instance" + (multiple-value-bind (res slot-def) + (get-slot-value-from-record instance slot :database database) + (let ((vd (choose-database-for-instance instance database))) + (setf (slot-value instance 'view-database) vd) + (update-slot-from-db-value instance slot-def res)))) + + +(defvar +no-slot-value+ '+no-slot-value+) + +(defsql sql-slot-value (:symbol "slot-value") (classname slot &optional (value +no-slot-value+) (database *default-database*)) + (let* ((class (find-class classname)) + (sld (slotdef-for-slot-with-class slot class))) + (if sld + (if (eq value +no-slot-value+) + (sql-expression :attribute (database-identifier sld database) + :table (view-table class)) + (db-value-from-slot + sld + value + database)) + (error "Unknown slot ~A for class ~A" slot classname)))) + +(defsql sql-view-class (:symbol "view-class") (classname &optional (database *default-database*)) + (declare (ignore database)) + (let* ((class (find-class classname))) + (unless (view-table class) + (error "No view-table for class ~A" classname)) + (sql-expression :table (view-table class)))) + +(deftype tinyint () + "An 8-bit integer, this width may vary by SQL implementation." + 'integer) + +(deftype smallint () + "An integer smaller than a 32-bit integer. this width may vary by SQL implementation." + 'integer) + +(deftype mediumint () + "An integer smaller than a 32-bit integer, but may be larger than a smallint. This width may vary by SQL implementation." + 'integer) + +(deftype bigint () + "An integer larger than a 32-bit integer, this width may vary by SQL implementation." + 'integer) + +(deftype varchar (&optional size) + "A variable length string for the SQL varchar type." + (declare (ignore size)) + 'string) + +(deftype universal-time () + "A positive integer as returned by GET-UNIVERSAL-TIME." + '(integer 1 *)) + +(deftype generalized-boolean () + "A type which outputs a SQL boolean value, though any lisp type can be stored in the slot." + t) + +#+ignore +(deftype char (&optional len) + "A lisp type for the SQL CHAR type." + `(string ,len)) + +(defmethod database-get-type-specifier ((type string) args database (db-type t)) + "Pass through the literal type as defined in the type string" + (declare (ignore args database db-type)) + type) + + +(defmethod database-get-type-specifier ((type symbol) args database db-type) + (case type + (char (if args + (format nil "CHAR(~D)" (first args)) + "CHAR(1)")) + ((varchar string symbol keyword) + (if args + (format nil "VARCHAR(~A)" (car args)) + (format nil "VARCHAR(~D)" *default-string-length*))) + ((longchar text) "text") + (integer (if args + (format nil "INT(~A)" (car args)) + "INT")) + ((tinyint smallint mediumint) "INT") + ((long-float float) + (if args + (format nil "FLOAT(~A)" (car args)) + "FLOAT")) + ((bigint universal-time) "BIGINT") + (number + (cond + ((and (consp args) (= (length args) 2)) + (format nil "NUMBER(~D,~D)" (first args) (second args))) + ((and (consp args) (= (length args) 1)) + (format nil "NUMBER(~D)" (first args))) + (t + "NUMBER"))) + (wall-time "TIMESTAMP") + (date "DATE") + (duration "VARCHAR") + (money "INT8") + ((boolean generalized-boolean) "BOOL") + (t (warn "Could not determine a valid ~A type specifier for ~A ~A ~A, defaulting to VARCHAR " + db-type type args database) + (format nil "VARCHAR(~D)" *default-string-length*)))) + +(defun print-readable-symbol (in &aux (*package* (find-package :keyword)) + (*print-readably* t)) + (prin1-to-string in)) + +(defmethod database-output-sql-as-type + (type val database db-type + &aux + (*print-circle* t) (*print-array* t) + (*print-length* nil) (*print-base* #10r10)) + (declare (ignore database)) + (cond + ((null type) val) + ((member type '(boolean generalized-boolean)) + ;; booleans handle null differently + (case db-type + ;; done here so it can be done once + ((:mssql :mysql) (if val 1 0)) + (otherwise (if val "t" "f")))) + ((null val) + (when (next-method-p) + (call-next-method))) + (t + (case type + ((or symbol keyword) + (print-readable-symbol val)) + (string val) + (char (etypecase val + (character (write-to-string val)) + (string val))) + (float (format nil "~F" val)) + ((list vector array) + (prin1-to-string val)) + (otherwise + (if (next-method-p) + (call-next-method) + val)))))) + + +(defmethod read-sql-value :around + (val type database db-type + ;; never eval while reading values, always read base 10 + &aux *read-eval* (*read-base* #10r10)) + (declare (ignore db-type)) + (cond + ;; null value or type + ((or (null val) + (equalp "nil" val) + (eql 'null val) + (eql 'null type)) + nil) + + ;; no specified type or already the right type + ((or (null type) + (ignore-errors (typep val type))) + val) + + ;; actually convert + (t + (let ((res (handler-bind + ;; all errors should be converted to sql-value-conversion-error + ((error (lambda (c) + (unless (typep c 'sql-value-conversion-error) + ;; this was blowing up the tests till I + ;; unbound *debugger-hook* not sure the answer, + ;; as this is also imensely useful in actually + ;; finding bugs below this point + (when *debugger-hook* (invoke-debugger c)) + (error-converting-value val type database))))) + (call-next-method)))) + ;; if we didnt get the right type after converting, we should probably + ;; error right away + (maybe-error-converting-value res val type database))))) + +(defmethod read-sql-value (val type database db-type) + "read a sql value, from :around read-eval is disabled read numbers in base 10" + ;; errors, nulls and preconverted types are already handled in around + (typecase type + (symbol + (case type + ((string varchar) val) + (char (string (schar val 0))) + ((or keyword symbol) + (read-from-string val)) + ((smallint mediumint bigint integer universal-time) + (parse-integer val)) + ((double-float float) + ;; ensure that whatever we got is coerced to a float of the correct + ;; type (eg: 1=>1.0d0) + (float + (etypecase val + (string (let ((*read-default-float-format* + (ecase type + (float 'single-float) + (double-float 'double-float)))) + (read-from-string val))) + ;; maybe wrong type of float + (float val)) + (if (eql type 'double-float) 1.0d0 1.0s0))) + (number (read-decimal-value val)) + ((boolean generalized-boolean) + (if (member val '(nil t)) + val + (etypecase val + (string + (when (member val '("1" "t" "true" "y") :test #'string-equal) + t)) + (number (not (zerop val)))))) + ((wall-time duration) (parse-timestring val)) + (date (parse-datestring val)) + (list (read-from-string val)) + (t (error-converting-value val type database)))) + (t (typecase val + (string (read-from-string val)) + (t (error-converting-value val type database)))))) + +;; ------------------------------------------------------------ +;; Logic for 'faulting in' :join slots + +;; this works, but is inefficient requiring (+ 1 n-rows) +;; SQL queries +#+ignore +(defun fault-join-target-slot (class object slot-def) + (let* ((res (fault-join-slot-raw class object slot-def)) + (dbi (view-class-slot-db-info slot-def)) + (target-name (gethash :target-slot dbi)) + (target-class (find-class target-name))) + (when res + (mapcar (lambda (obj) + (list + (car + (fault-join-slot-raw + target-class + obj + (find target-name (class-slots (class-of obj)) + :key #'slot-definition-name))) + obj)) + res) + #+ignore ;; this doesn't work when attempting to call slot-value + (mapcar (lambda (obj) + (cons obj (slot-value obj ts))) res)))) + +(defun fault-join-target-slot (class object slot-def) + (let* ((dbi (view-class-slot-db-info slot-def)) + (ts (gethash :target-slot dbi)) + (jc (gethash :join-class dbi)) + (jc-view-table (view-table (find-class jc))) + (tdbi (view-class-slot-db-info + (find ts (class-slots (find-class jc)) + :key #'slot-definition-name))) + (retrieval (gethash :retrieval tdbi)) + (tsc (gethash :join-class tdbi)) + (ts-view-table (view-table (find-class tsc))) + (jq (join-qualifier class object slot-def)) + (key (slot-value object (gethash :home-key dbi)))) + + (when jq + (ecase retrieval + (:immediate + (let ((res + (find-all (list tsc) + :inner-join (sql-expression :table jc-view-table) + :on (sql-operation + '== + (sql-expression + :attribute (gethash :foreign-key tdbi) + :table ts-view-table) + (sql-expression + :attribute (gethash :home-key tdbi) + :table jc-view-table)) + :where jq + :result-types :auto + :database (choose-database-for-instance object)))) + (mapcar #'(lambda (i) + (let* ((instance (car i)) + (jcc (make-instance jc :view-database (choose-database-for-instance instance)))) + (setf (slot-value jcc (gethash :foreign-key dbi)) + key) + (setf (slot-value jcc (gethash :home-key tdbi)) + (slot-value instance (gethash :foreign-key tdbi))) + (list instance jcc))) + res))) + (:deferred + ;; just fill in minimal slots + (mapcar + #'(lambda (k) + (let ((instance (make-instance tsc :view-database (choose-database-for-instance object))) + (jcc (make-instance jc :view-database (choose-database-for-instance object))) + (fk (car k))) + (setf (slot-value instance (gethash :home-key tdbi)) fk) + (setf (slot-value jcc (gethash :foreign-key dbi)) + key) + (setf (slot-value jcc (gethash :home-key tdbi)) + fk) + (list instance jcc))) + (select (sql-expression :attribute (gethash :foreign-key tdbi) :table jc-view-table) + :from (sql-expression :table jc-view-table) + :where jq + :database (choose-database-for-instance object)))))))) + + +;;; Remote Joins + +(defvar *default-update-objects-max-len* nil + "The default value to use for the MAX-LEN keyword argument to + UPDATE-OBJECT-JOINS.") + +(defun %update-objects-joins-slot-defs (class slot-names) + "Get the slot definitions for the joins slots specified as slot-names + if slot-names is :immediate, :deferred or (or :all t) return all of + that type of slot definitions" + (setf class (to-class class)) + (when (eq t slot-names) (setf slot-names :all)) + (etypecase slot-names + (null nil) + (keyword + ;; slot-names is the retrieval type of the join-slot or :all + (get-join-slots class slot-names)) + ((or symbol list) + (loop for slot in (listify slot-names) + for def = (find-slot-by-name class slot) + when (and def (join-slot-p def)) + collecting def + unless (and def (join-slot-p def)) + do (warn "Unable to find join slot named ~S in class ~S." slot class))))) + +(defun get-joined-objects (objects slotdef &key force-p + (batch-size *default-update-objects-max-len*)) + "Given a list of objects and a join slot-def get the objects that need to be + joined to the input objects + + we will query in batches as large as batch-size" + (when (join-slot-p slotdef) + (let* ((slot-name (to-slot-name slotdef)) + (join-class (join-slot-class-name slotdef)) + (home-key (join-slot-info-value slotdef :home-key)) + (foreign-key (join-slot-info-value slotdef :foreign-key)) + (foreign-key-values + (remove-duplicates + (loop for object in (listify objects) + for hk = (slot-value object home-key) + when (or force-p + (not (slot-boundp object slot-name))) + collect hk) + :test #'equal))) + ;; we want to retrieve at most batch-size objects per query + (flet ((fetch (keys) + (find-all + (list join-class) + :where (make-instance + 'sql-relational-exp + :operator 'in + :sub-expressions (list (sql-expression :attribute foreign-key) + keys)) + :result-types :auto + :flatp t))) + (if (null batch-size) + (fetch foreign-key-values) + (loop + for keys = (pop-n foreign-key-values batch-size) + while keys + nconcing (fetch keys))))))) + +(defun %object-joins-from-list (object slot joins force-p ) + "Given a list of objects that we are trying to join to, pull the correct + ones for this object" + (when (or force-p (not (slot-boundp object (to-slot-name slot)))) + (let ((home-key (join-slot-info-value slot :home-key)) + (foreign-key (join-slot-info-value slot :foreign-key))) + (loop for join in joins + when (equal (slot-value join foreign-key) + (slot-value object home-key)) + collect join)))) + +(defun update-objects-joins (objects &key (slots :immediate) (force-p t) + class-name (max-len *default-update-objects-max-len*)) + "Updates from the records of the appropriate database tables the join slots + specified by SLOTS in the supplied list of View Class instances OBJECTS. + + A simpler method of causing a join-slot to be requeried is to set it to + unbound, then request it again. This function has efficiency gains where + join-objects are shared among the `objects` (querying all join-objects, + then attaching them appropriately to each of the `objects`) + + SLOTS can be one of: + + * :immediate (DEFAULT) - refresh join slots created with :retrieval :immediate + * :deferred - refresh join slots created with :retrieval :deferred + * :all,t - refresh all join slots regardless of :retrieval + * list of symbols - which explicit slots to refresh + * a single symobl - what slot to refresh + + CLASS-NAME is used to specify the View Class of all instance in OBJECTS and + default to nil which means that the class of the first instance in OBJECTS + is used. + + FORCE-P is t by default which means that all join slots are updated whereas + a value of nil means that only unbound join slots are updated. + + MAX-LEN defaults to *DEFAULT-UPDATE-OBJECTS-MAX-LEN* When non-nil this is + essentially a batch size for the max number of objects to query from the + database at a time. If we need more than max-len we loop till we have all + the objects" + (assert (or (null max-len) (plusp max-len))) + (when objects + (defaulting class-name (class-name (class-of (first objects)))) + (let* ((class (find-class class-name)) + (slotdefs (%update-objects-joins-slot-defs class slots))) + (loop for slotdef in slotdefs + ;; all the joins we will need for *all* the objects + ;; which then get filtered below for each object + for joins = (unless (join-slot-info-value slotdef :target-slot) + (get-joined-objects objects slotdef + :force-p force-p :batch-size max-len)) + do (loop for object in objects + for these-joins = ;; the joins just for this object (filtered from above) + ;; or retrieved via fault-join-target-slot + (or (%object-joins-from-list object slotdef joins force-p) + (when (join-slot-info-value slotdef :target-slot) + (fault-join-target-slot class object slotdef))) + ;; when this object has joined-objects copy them in to the correct slot + do (when these-joins + (setf (easy-slot-value object slotdef) + (if (join-slot-info-value slotdef :set) + these-joins + (first these-joins)))))))) + (values)) + +(defun fault-join-slot-raw (class object slot-def) + (let* ((dbi (view-class-slot-db-info slot-def)) + (jc (gethash :join-class dbi))) + (let ((jq (join-qualifier class object slot-def))) + (when jq + (select jc :where jq :flatp t :result-types nil + :database (choose-database-for-instance object)))))) + +(defun fault-join-slot (class object slot-def) + (let* ((dbi (view-class-slot-db-info slot-def)) + (ts (gethash :target-slot dbi)) + (dbi-set (gethash :set dbi))) + (if (and ts dbi-set) + (fault-join-target-slot class object slot-def) + (let ((res (fault-join-slot-raw class object slot-def))) + (when res + (cond + ((and ts (not dbi-set)) + (mapcar (lambda (obj) (slot-value obj ts)) res)) + ((and (not ts) (not dbi-set)) + (car res)) + ((and (not ts) dbi-set) + res))))))) + +(defun update-fault-join-normalized-slot (class object slot-def) + (if (and (normalizedp class) (key-slot-p slot-def)) + (setf (easy-slot-value object slot-def) + (normalized-key-value object)) + (update-slot-from-record object slot-def))) + +(defun all-home-keys-have-values-p (object slot-def) + "Do all of the home-keys have values ?" + (let ((home-keys (join-slot-info-value slot-def :home-key))) + (loop for key in (listify home-keys) + always (easy-slot-value object key)))) + +(defun join-qualifier (class object slot-def) + "Builds the join where clause based on the keys of the join slot and values + of the object" + (declare (ignore class)) + (let* ((jc (join-slot-class slot-def)) + ;;(ts (gethash :target-slot dbi)) + ;;(tsdef (if ts (slotdef-for-slot-with-class ts jc))) + (foreign-keys (listify (join-slot-info-value slot-def :foreign-key))) + (home-keys (listify (join-slot-info-value slot-def :home-key)))) + (when (all-home-keys-have-values-p object slot-def) + (clsql-ands + (loop for hk in home-keys + for fk in foreign-keys + for fksd = (slotdef-for-slot-with-class fk jc) + for fk-sql = (typecase fk + (symbol + (sql-expression + :attribute (database-identifier fksd nil) + :table (database-identifier jc nil))) + (t fk)) + for hk-val = (typecase hk + ((or symbol + view-class-effective-slot-definition + view-class-direct-slot-definition) + (easy-slot-value object hk)) + (t hk)) + collect (sql-operation '== fk-sql hk-val)))))) + +(defmethod select-table-sql-expr ((table T)) + "Turns an object representing a table into the :from part of the sql expression that will be executed " + (sql-expression :table (view-table table))) + +(defun select-reference-equal (r1 r2) + "determines if two sql select references are equal + using database identifier equal" + (flet ((id-of (r) + (etypecase r + (cons (cdr r)) + (sql-ident-attribute r)))) + (database-identifier-equal (id-of r1) (id-of r2)))) + +(defun join-slot-qualifier (class join-slot) + "Creates a sql-expression expressing the join between the home-key on the table + and its respective key on the joined-to-table" + (sql-operation + '== + (sql-expression + :attribute (join-slot-info-value join-slot :foreign-key) + :table (view-table (join-slot-class join-slot))) + (sql-expression + :attribute (join-slot-info-value join-slot :home-key) + :table (view-table class)))) + +(defun all-immediate-join-classes-for (classes) + "returns a list of all join-classes needed for a list of classes" + (loop for class in (listify classes) + appending (loop for slot in (immediate-join-slots class) + collect (join-slot-class slot)))) + +(defun %tables-for-query (classes from where inner-joins) + "Given lists of classes froms wheres and inner-join compile a list + of tables that should appear in the FROM section of the query. + + This includes any immediate join classes from each of the classes" + (let ((inner-join-tables (collect-table-refs (listify inner-joins)))) + (loop for tbl in (append + (mapcar #'select-table-sql-expr classes) + (mapcar #'select-table-sql-expr + (all-immediate-join-classes-for classes)) + (collect-table-refs (listify where)) + (collect-table-refs (listify from))) + when (and tbl + (not (find tbl rtn :test #'database-identifier-equal)) + ;; TODO: inner-join is currently hacky as can be + (not (find tbl inner-join-tables :test #'database-identifier-equal))) + collect tbl into rtn + finally (return rtn)))) + + +(defclass select-list () + ((view-class :accessor view-class :initarg :view-class :initform nil) + (select-list :accessor select-list :initarg :select-list :initform nil) + (slot-list :accessor slot-list :initarg :slot-list :initform nil) + (joins :accessor joins :initarg :joins :initform nil) + (join-slots :accessor join-slots :initarg :join-slots :initform nil)) + (:documentation + "Collects the classes, slots and their respective sql representations + so that update-instance-from-recors, find-all, build-objects can share this + info and calculate it once. Joins are select-lists for each immediate join-slot + but only if make-select-list is called with do-joins-p")) + +(defmethod view-table ((o select-list)) + (view-table (view-class o))) + +(defmethod sql-table ((o select-list)) + (sql-expression :table (view-table o))) + +(defmethod filter-select-list ((c clsql-sys::standard-db-object) + (sl clsql-sys::select-list) + database) + sl) + +(defun make-select-list (class-and-slots &key (do-joins-p nil) + (database *default-database*)) + "Make a select-list for the current class (or class-and-slots) object." + (let* ((class-and-slots + (etypecase class-and-slots + (class-and-slots class-and-slots) + ((or symbol standard-db-class) + ;; find the first class with slots for us to select (this should be) + ;; the first of its classes / parent-classes with slots + (first (reverse (view-classes-and-storable-slots + (to-class class-and-slots) + :to-database-p nil)))))) + (class (view-class class-and-slots)) + (join-slots (when do-joins-p (immediate-join-slots class)))) + (multiple-value-bind (slots sqls) + (loop for slot in (slot-defs class-and-slots) + for sql = (generate-attribute-reference class slot) + collect slot into slots + collect sql into sqls + finally (return (values slots sqls))) + (unless slots + (error "No slots of type :base in view-class ~A" (class-name class))) + (let ((sl (make-instance + 'select-list + :view-class class + :select-list sqls + :slot-list slots + :join-slots join-slots + ;; only do a single layer of join objects + :joins (when do-joins-p + (loop for js in join-slots + collect (make-select-list + (join-slot-class js) + :do-joins-p nil + :database database)))))) + (filter-select-list (make-instance class) sl database) + sl)))) + +(defun full-select-list ( select-lists ) + "Returns a list of sql-ref of things to select for the given classes + + THIS NEEDS TO MATCH THE ORDER OF build-objects + " + (loop for s in (listify select-lists) + appending (select-list s) + appending (loop for join in (joins s) + appending (select-list join)))) + +(defun build-objects (select-lists row database &optional existing-instances) + "Used by find-all to build objects. + + THIS NEEDS TO MATCH THE ORDER OF FULL-SELECT-LIST + + TODO: this caching scheme seems bad for a number of reasons + * order is not guaranteed so references being held by one object + might change to represent a different database row (seems HIGHLY + suspect) + * also join objects are overwritten rather than refreshed + + TODO: the way we handle immediate joins seems only valid if it is a single + object. I suspect that making a :set :immediate join column would result + in an invalid number of objects returned from the database, because there + would be multiple rows per object, but we would return an object per row + " + (setf existing-instances (listify existing-instances)) + (loop + for select-list in select-lists + for class = (view-class select-list) + for existing = (pop existing-instances) + for object = (or existing + (make-instance class :view-database database)) + do (loop for slot in (slot-list select-list) + do (update-slot-from-db-value object slot (pop row))) + do (loop for join-slot in (join-slots select-list) + for join in (joins select-list) + for join-class = (view-class join) + for join-object = + (setf (easy-slot-value object join-slot) + (make-instance join-class)) + do (loop for slot in (slot-list join) + do (update-slot-from-db-value join-object slot (pop row)))) + do (when existing (instance-refreshed object)) + collect object)) + +(defun find-all (view-classes + &rest args + &key all set-operation distinct from where group-by having + order-by offset limit refresh flatp result-types + inner-join on + (database *default-database*) + instances parameters) + "Called by SELECT to generate object query results when the + View Classes VIEW-CLASSES are passed as arguments to SELECT. + + TODO: the caching scheme of passing in instances and overwriting their + values seems bad for a number of reasons + * order is not guaranteed so references being held by one object + might change to represent a different database row (seems HIGHLY + suspect) + + TODO: the way we handle immediate joins seems only valid if it is a single + object. I suspect that making a :set :immediate join column would result + in an invalid number of objects returned from the database, because there + would be multiple objects returned from the database + " + (declare (ignore all set-operation group-by having offset limit on parameters + distinct order-by) + (dynamic-extent args)) + (let* ((args (filter-plist + args :from :where :flatp :additional-fields :result-types :instances)) + (*db-deserializing* t) + (sclasses (mapcar #'to-class view-classes)) + (tables (%tables-for-query sclasses from where inner-join)) + (join-where + (loop for class in sclasses + appending (loop for slot in (immediate-join-slots class) + collect (join-slot-qualifier class slot)))) + (select-lists (loop for class in sclasses + collect (make-select-list class :do-joins-p t :database database))) + (full-select-list (full-select-list select-lists)) + (where (clsql-ands (append (listify where) (listify join-where)))) + #| + (_ (format t "~&sclasses: ~W~%ijc: ~W~%tables: ~W~%" + sclasses immediate-join-classes tables)) + |# + (rows (apply #'select + (append full-select-list + (list :from tables + :result-types result-types + :where where) + args))) + (return-objects + (loop for row in rows + for old-objs = (pop instances) + for objs = (build-objects select-lists row database + (when refresh old-objs)) + collecting (if flatp + (delist-if-single objs) + objs)))) + return-objects)) + +(defmethod instance-refreshed ((instance standard-db-object))) + +(defvar *default-caching* t + "Controls whether SELECT caches objects by default. The CommonSQL +specification states caching is on by default.") + +(defun select (&rest select-all-args) + "Executes a query on DATABASE, which has a default value of +*DEFAULT-DATABASE*, specified by the SQL expressions supplied +using the remaining arguments in SELECT-ALL-ARGS. The SELECT +argument can be used to generate queries in both functional and +object oriented contexts. + +In the functional case, the required arguments specify the +columns selected by the query and may be symbolic SQL expressions +or strings representing attribute identifiers. Type modified +identifiers indicate that the values selected from the specified +column are converted to the specified lisp type. The keyword +arguments ALL, DISTINCT, FROM, GROUP-by, HAVING, ORDER-BY, +SET-OPERATION and WHERE are used to specify, using the symbolic +SQL syntax, the corresponding components of the SQL query +generated by the call to SELECT. RESULT-TYPES is a list of +symbols which specifies the lisp type for each field returned by +the query. If RESULT-TYPES is nil all results are returned as +strings whereas the default value of :auto means that the lisp +types are automatically computed for each field. FIELD-NAMES is t +by default which means that the second value returned is a list +of strings representing the columns selected by the query. If +FIELD-NAMES is nil, the list of column names is not returned as a +second value. + +In the object oriented case, the required arguments to SELECT are +symbols denoting View Classes which specify the database tables +to query. In this case, SELECT returns a list of View Class +instances whose slots are set from the attribute values of the +records in the specified table. Slot-value is a legal operator +which can be employed as part of the symbolic SQL syntax used in +the WHERE keyword argument to SELECT. REFRESH is nil by default +which means that the View Class instances returned are retrieved +from a cache if an equivalent call to SELECT has previously been +issued. If REFRESH is true, the View Class instances returned are +updated as necessary from the database and the generic function +INSTANCE-REFRESHED is called to perform any necessary operations +on the updated instances. + +In both object oriented and functional contexts, FLATP has a +default value of nil which means that the results are returned as +a list of lists. If FLATP is t and only one result is returned +for each record selected in the query, the results are returned +as elements of a list." + (multiple-value-bind (target-args qualifier-args) + (query-get-selections select-all-args) + (unless (or *default-database* (getf qualifier-args :database)) + (signal-no-database-error nil)) + + (let ((caching (getf qualifier-args :caching *default-caching*)) + (result-types (getf qualifier-args :result-types :auto)) + (refresh (getf qualifier-args :refresh nil)) + (database (getf qualifier-args :database *default-database*))) + + (cond + ((and target-args + (every #'(lambda (arg) + (and (symbolp arg) + (find-class arg nil))) + target-args)) + + (setf qualifier-args (filter-plist qualifier-args :caching :refresh :result-types)) + + ;; Add explicity table name to order-by if not specified and only + ;; one selected table. This is required so FIND-ALL won't duplicate + ;; the field + (let ((order-by (getf qualifier-args :order-by))) + (when (and order-by (= 1 (length target-args))) + (let ((table-name (view-table (find-class (car target-args)))) + (order-by-list (copy-seq (listify order-by)))) + (labels ((sv (val name) (ignore-errors (slot-value val name))) + (set-table-if-needed (val) + (typecase val + (sql-ident-attribute + (handler-case + (if (sv val 'qualifier) + val + (make-instance 'sql-ident-attribute + :name (sv val 'name) + :qualifier table-name)) + (simple-error () + ;; TODO: Check for a specific error we expect + ))) + (cons (cons (set-table-if-needed (car val)) + (cdr val))) + (t val)))) + (setf order-by-list + (loop for i from 0 below (length order-by-list) + for id in order-by-list + collect (set-table-if-needed id)))) + (setf (getf qualifier-args :order-by) order-by-list)))) + + (cond + ((null caching) + (apply #'find-all target-args :result-types result-types :refresh refresh qualifier-args)) + (t + (let ((cached (records-cache-results target-args qualifier-args database))) + (if (and cached (not refresh)) + cached + (let ((results (apply #'find-all target-args + :result-types :auto :refresh refresh + :instances cached + qualifier-args))) + (setf (records-cache-results target-args qualifier-args database) results) + + results)))))) + (t + (let* ((expr (apply #'make-query select-all-args)) + (parameters (second (member :parameters select-all-args))) + (specified-types + (mapcar #'(lambda (attrib) + (if (typep attrib 'sql-ident-attribute) + (let ((type (slot-value attrib 'type))) + (if type + type + t)) + t)) + (slot-value expr 'selections))) + (flatp (getf qualifier-args :flatp)) + (field-names (getf qualifier-args :field-names t))) + + (when parameters + (setf expr (command-object (sql-output expr database) parameters))) + (query expr :flatp flatp + :result-types + ;; specifying a type for an attribute overrides result-types + (if (some #'(lambda (x) (not (eq t x))) specified-types) + specified-types + result-types) + :field-names field-names + :database database))))))) + +(defun compute-records-cache-key (targets qualifiers) + (list targets + (do ((args *select-arguments* (cdr args)) + (results nil)) + ((null args) results) + (let* ((arg (car args)) + (value (getf qualifiers arg))) + (when value + (push (list arg + (typecase value + (cons (cons (sql (car value)) (cdr value))) + (%sql-expression (sql value)) + (t value))) + results)))))) + +(defun records-cache-results (targets qualifiers database) + (when (record-caches database) + (gethash (compute-records-cache-key targets qualifiers) (record-caches database)))) + +(defun (setf records-cache-results) (results targets qualifiers database) + (unless (record-caches database) + (setf (record-caches database) + (make-weak-hash-table :test 'equal))) + (setf (gethash (compute-records-cache-key (copy-list targets) qualifiers) + (record-caches database)) results) + results) + + + +;;; Serialization functions + +(defun write-instance-to-stream (obj stream) + "Writes an instance to a stream where it can be later be read. +NOTE: an error will occur if a slot holds a value which can not be written readably." + (let* ((class (class-of obj)) + (alist '())) + (dolist (slot (ordered-class-slots (class-of obj))) + (let ((name (slot-definition-name slot))) + (when (and (not (eq 'view-database name)) + (slot-boundp obj name)) + (push (cons name (slot-value obj name)) alist)))) + (setq alist (reverse alist)) + (write (cons (class-name class) alist) :stream stream :readably t)) + obj) + +(defun read-instance-from-stream (stream) + (let ((raw (read stream nil nil))) + (when raw + (let ((obj (make-instance (car raw)))) + (dolist (pair (cdr raw)) + (setf (slot-value obj (car pair)) (cdr pair))) + obj)))) diff --git a/sql/operations.lisp b/sql/operations.lisp new file mode 100644 index 0000000..faa22b5 --- /dev/null +++ b/sql/operations.lisp @@ -0,0 +1,262 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; +;;;; Definition of SQL operations used with the symbolic SQL syntax. +;;;; +;;;; 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) + +;; Keep a hashtable for mapping symbols to sql generator functions, +;; for use by the bracketed reader syntax. + +(defvar *sql-op-table* (make-hash-table :test #'equal)) + + +;; Define an SQL operation type. + +(defmacro defsql (function definition-keys &body body) + `(progn + (defun ,function ,@body) + (let ((symbol (cadr (member :symbol ',definition-keys)))) + (setf (gethash (if symbol (symbol-name-default-case symbol) ',function) + *sql-op-table*) + ',function)))) + + +;; SQL operations + +(defsql sql-query (:symbol "select") (&rest args) + (apply #'make-query args)) + +(defsql sql-any (:symbol "any") (&rest rest) + (make-instance 'sql-function-exp + :name 'any :args rest)) + +(defsql sql-some (:symbol "some") (&rest rest) + (make-instance 'sql-function-exp + :name 'some :args rest)) + +(defsql sql-all (:symbol "all") (&rest rest) + (make-instance 'sql-function-exp + :name 'all :args rest)) + +(defsql sql-e-string (:symbol "E") (&rest rest) + (make-instance 'sql-escape-string-exp :string (first rest))) + +(defsql sql-not (:symbol "not") (&rest rest) + (make-instance 'sql-value-exp + :modifier 'not :components rest)) + +(defsql sql-union (:symbol "union") (&rest rest) + (make-instance 'sql-set-exp + :operator 'union :sub-expressions rest)) + +(defsql sql-intersect (:symbol "intersect") (&rest rest) + (make-instance 'sql-set-exp + :operator 'intersect :sub-expressions rest)) + +(defsql sql-except (:symbol "except") (&rest rest) + (make-instance 'sql-set-exp + :operator 'except :sub-expressions rest)) + +(defsql sql-minus (:symbol "minus") (&rest rest) + (make-instance 'sql-set-exp + :operator 'minus :sub-expressions rest)) + +(defsql sql-limit (:symbol "limit") (&rest rest) + (make-instance 'sql-query-modifier-exp + :modifier 'limit :components rest)) + +(defsql sql-group-by (:symbol "group-by") (&rest rest) + (make-instance 'sql-query-modifier-exp + :modifier '|GROUP BY| :components rest)) + +(defsql sql-order-by (:symbol "order-by") (&rest rest) + (make-instance 'sql-query-modifier-exp + :modifier '|ORDER BY| :components rest)) + +(defsql sql-having (:symbol "having") (&rest rest) + (make-instance 'sql-query-modifier-exp + :modifier 'having :components rest)) + +(defsql sql-null (:symbol "null") (&optional not-null-thing) + (if not-null-thing + (make-instance 'sql-relational-exp :operator 'is + :sub-expressions (list not-null-thing nil)) + (make-instance 'sql-value-exp :components 'null))) + +(defsql sql-not-null (:symbol "not-null") (&optional not-null-thing) + (if not-null-thing + (make-instance + 'sql-relational-exp + :operator 'IS + :sub-expressions (list not-null-thing + (sql-expression :string "NOT NULL"))) + (sql-expression :string "NOT NULL"))) + +(defsql sql-exists (:symbol "exists") (&rest rest) + (make-instance 'sql-function-exp + :name 'exists :args rest)) + +(defsql sql-* (:symbol "*") (&rest rest) + (if (zerop (length rest)) + (make-instance 'sql-ident :name '*) + (make-instance 'sql-relational-exp :operator '* :sub-expressions rest))) + +(defsql sql-+ (:symbol "+") (&rest rest) + (if (cdr rest) + (make-instance 'sql-relational-exp + :operator '+ :sub-expressions rest) + (make-instance 'sql-value-exp :modifier '+ :components rest))) + +(defsql sql-/ (:symbol "/") (&rest rest) + (make-instance 'sql-relational-exp + :operator '/ :sub-expressions rest)) + +(defsql sql-- (:symbol "-") (&rest rest) + (if (cdr rest) + (make-instance 'sql-relational-exp + :operator '- :sub-expressions rest) + (make-instance 'sql-value-exp :modifier '- :components rest))) + +(defsql sql-like (:symbol "like") (&rest rest) + (make-instance 'sql-relational-exp + :operator 'like :sub-expressions rest)) + +(defsql sql-uplike (:symbol "uplike") (&rest rest) + (make-instance 'sql-upcase-like + :sub-expressions rest)) + +(defsql sql-and (:symbol "and") (&rest rest) + (make-instance 'sql-relational-exp + :operator 'and :sub-expressions rest)) + +(defsql sql-or (:symbol "or") (&rest rest) + (make-instance 'sql-relational-exp + :operator 'or :sub-expressions rest)) + +(defsql sql-in (:symbol "in") (&rest rest) + (make-instance 'sql-relational-exp + :operator 'in :sub-expressions rest)) + +(defsql sql-concat-op (:symbol "concat-op") (&rest rest) + (make-instance 'sql-relational-exp + :operator '\|\| :sub-expressions rest)) + +(defsql sql-concat (:symbol "concat") (&rest rest) + (make-instance 'sql-function-exp + :name 'concat :args rest)) + +(defsql sql-substr (:symbol "substr") (&rest rest) + (if (= (length rest) 3) + (make-instance 'sql-function-exp + :name 'substr :args rest) + (error 'sql-user-error :message "SUBSTR must have 3 arguments."))) + +(defsql sql-substring (:symbol "substring") (&rest rest) + (if (= (length rest) 3) + (make-instance 'sql-function-exp + :name 'substring :args rest) + (error 'sql-user-error :message "SUBSTRING must have 3 arguments."))) + +(defsql sql-is (:symbol "is") (&rest rest) + (make-instance 'sql-relational-exp + :operator 'is :sub-expressions rest)) + +(defsql sql-= (:symbol "=") (&rest rest) + (make-instance 'sql-relational-exp + :operator '= :sub-expressions rest)) + +(defsql sql-== (:symbol "==") (&rest rest) + (make-instance 'sql-assignment-exp + :operator '= :sub-expressions rest)) + +(defsql sql-< (:symbol "<") (&rest rest) + (make-instance 'sql-relational-exp + :operator '< :sub-expressions rest)) + + +(defsql sql-> (:symbol ">") (&rest rest) + (make-instance 'sql-relational-exp + :operator '> :sub-expressions rest)) + +(defsql sql-<> (:symbol "<>") (&rest rest) + (make-instance 'sql-relational-exp + :operator '<> :sub-expressions rest)) + +(defsql sql->= (:symbol ">=") (&rest rest) + (make-instance 'sql-relational-exp + :operator '>= :sub-expressions rest)) + +(defsql sql-<= (:symbol "<=") (&rest rest) + (make-instance 'sql-relational-exp + :operator '<= :sub-expressions rest)) + +(defsql sql-count (:symbol "count") (&rest rest) + (make-instance 'sql-function-exp + :name 'count :args rest)) + +(defsql sql-max (:symbol "max") (&rest rest) + (make-instance 'sql-function-exp + :name 'max :args rest)) + +(defsql sql-min (:symbol "min") (&rest rest) + (make-instance 'sql-function-exp + :name 'min :args rest)) + +(defsql sql-avg (:symbol "avg") (&rest rest) + (make-instance 'sql-function-exp + :name 'avg :args rest)) + +(defsql sql-sum (:symbol "sum") (&rest rest) + (make-instance 'sql-function-exp + :name 'sum :args rest)) + +(defsql sql-the (:symbol "the") (&rest rest) + (make-instance 'sql-typecast-exp + :modifier (first rest) :components (second rest))) + +(defsql sql-function (:symbol "function") (&rest args) + (make-instance 'sql-function-exp + :name (make-symbol (car args)) :args (cdr args))) + +(defsql sql-between (:symbol "between") (&rest rest) + (if (= (length rest) 3) + (make-instance 'sql-between-exp :name 'between :args rest) + (error 'sql-user-error :message "BETWEEN must have 3 arguments."))) + +(defsql sql-distinct (:symbol "distinct") (&rest rest) + (make-instance 'sql-query-modifier-exp :modifier 'distinct + :components rest)) + +(defsql sql-coalesce (:symbol "coalesce") (&rest rest) + (make-instance 'sql-function-exp + :name 'coalesce :args rest)) + +(defsql sql-nvl (:symbol "nvl") (&rest rest) + (if (= (length rest) 2) + (make-instance 'sql-function-exp + :name 'coalesce :args rest) + (error 'sql-user-error :message "NVL accepts exactly 2 arguments."))) + +(defsql sql-userenv (:symbol "userenv") (&rest rest) + (make-instance 'sql-function-exp + :name 'userenv :args rest)) + +(defsql sql-lower (:symbol "lower") (&rest rest) + (if (= (length rest) 1) + (make-instance 'sql-function-exp + :name 'lower :args rest) + (error 'sql-user-error :message "LOWER must have 1 argument."))) + +(defsql sql-upper (:symbol "upper") (&rest rest) + (if (= (length rest) 1) + (make-instance 'sql-function-exp + :name 'upper :args rest) + (error 'sql-user-error :message "UPPER must have 1 argument."))) diff --git a/sql/package.lisp b/sql/package.lisp new file mode 100644 index 0000000..8915b06 --- /dev/null +++ b/sql/package.lisp @@ -0,0 +1,621 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: package.lisp +;;;; Purpose: Package definition for SQL interface +;;;; +;;;; 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 #:cl-user) + +;;;; This file makes the required package definitions for CLSQL's +;;;; core packages. + +(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)) + (pushnew :clsql-cmucl-mop cl:*features*) + (pushnew :clsql-cmucl-pcl cl:*features*))) + + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defpackage #:clsql-sys + (:use #:common-lisp + #+clsql-sbcl-mop #:sb-mop + #+clsql-cmucl-mop #:mop + #+allegro #:mop + #+clisp #:clos + #+ecl #:mop + #+lispworks #:clos + #+scl #:clos + #+openmcl #:openmcl-mop) + + #+allegro + (:shadowing-import-from + #:excl) + #+clisp + (:shadowing-import-from + #:clos) + #+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-connect + #:database-disconnect + #:database-reconnect + #: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-list-tables + #:database-list-tables-and-sequences + #: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-last + #:database-sequence-exists-p + #:database-last-auto-increment-id + #:database-list-attributes + #:database-attribute-type + #:database-type-library-loaded + #:database-create + #:database-destroy + #:database-probe + #:database-list + #:database-acquire-from-conn-pool + #:database-release-to-conn-pool + + #:db-backend-has-create/destroy-db? + #:db-type-has-views? + #:db-type-has-bigint? + #:db-type-has-union? + #:db-type-has-prepared-stmt? + #: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? + #:db-type-use-fully-qualified-column-on-drop-index? + #:db-type-has-intersect? + #:db-type-has-except? + #:db-type-has-auto-increment? + #:database-underlying-type + #:database-get-type-specifier + #:read-sql-value + #:database-output-sql-as-type + #:*loaded-database-types* + #:reload-database-types + #:is-database-open + #:*db-pool-max-free-connections* + + ;; 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 + + ;; Prepared statments + #:database-prepare + #:database-run-prepared + #:database-bind-parameter + #:database-free-prepared + + ;; accessors for database class + #:name + #:connection-spec + #:transaction + #:transaction-level + #:conn-pool + #:command-recording-stream + #:result-recording-stream + #:record-caches + #:view-classes + #:database-state + #:attribute-cache + #:database-autocommit + #:encoding + + ;; utils.lisp + #:without-interrupts + #:make-process-lock + #:with-process-lock + #:command-output + #:symbol-name-default-case + #:convert-to-db-default-case + #:ensure-keyword + #:getenv + #:number-to-sql-string + #:float-to-sql-string + #:sql-escape-quotes + #:sql-escape + #:in + + ;; Command-object.lisp + #:expression + #:parameters + #:prepare-sql-parameter + #:prepared-name + #:has-been-prepared + #:command-object + #:reset-command-object + + ;; Generic backends + #:generic-postgresql-database + #:generic-odbc-database + + ;; Subclasses of sql-expresssion (expressions.lisp) + #:sql-function-exp + #:sql-value-exp + #:sql-set-exp + #:sql-query-modifier-exp + #:sql-relational-exp + #:sql-upcase-like + #:sql-assignment-exp + #:sql-typecast-exp + #:sql-between-exp + #:sql-ident + #:sql-ident-attribute + #:sql-ident-table + + . + + ;; Shared exports for re-export by CLSQL package. + #1=( + + ;; foreign library loading + #:*foreign-library-search-paths* + #:push-library-path + + ;; Condition system (conditions.lisp) + #:sql-user-error + #:sql-database-error + #:sql-database-data-error + #:sql-connection-error + #:sql-temporary-error + #:sql-timeout-error + #:sql-fatal-error + #:sql-error-error-id + #:sql-error-secondary-error-id + #:sql-error-database-message + ;; CLSQL Extensions + #:sql-condition + #:sql-error + #:sql-warning + #:sql-database-warning + #:sql-error-database + #:sql-error-database-type + #:sql-error-connection-spec + #:sql-error-expression + #:sql-warning-database + #:sql-user-error-message + #:*backend-warning-behavior* + + ;; Connection/initialisation (base-classes.lisp, database.lisp, + ;; initialize.lisp) + #:*default-database-type* + #:*default-database* + #:*initialized-database-types* + #:initialize-database-type + #:connect + #:disconnect + #:*connect-if-exists* + #:connected-databases + #:database + #:database-name + #:reconnect + #:find-database + #:status + ;; CLSQL Extensions + #:database-name-from-spec + #:database-type + #:with-database + #:with-default-database + #:disconnect-pooled + #:list-databases + #:create-database + #:destroy-database + #:probe-database + + ;; I/O Recording (recording.lisp) + #:add-sql-stream + #:delete-sql-stream + #:list-sql-streams + #:sql-recording-p + #:sql-stream + #:start-sql-recording + #:stop-sql-recording + + ;; FDDL (fddl.lisp) + #:create-table + #:drop-table + #:list-tables + #:table-exists-p + #:list-attributes + #:attribute-type + #:list-attribute-types + #:create-view + #:drop-view + #:create-index + #:drop-index + ;; CLSQL Extensions + #:truncate-database + #:list-views + #:view-exists-p + #:list-indexes + #:index-exists-p + #:create-sequence + #:drop-sequence + #:list-sequences + #:sequence-exists-p + #:sequence-next + #:sequence-last + #:set-sequence-position + #:*old-sequence-names* + + ;; FDML (fdml.lisp) + #:select + #:cache-table-queries + #:*cache-table-queries-default* + #:delete-records + #:insert-records + #:update-records + #:execute-command + #:query + #:print-query + #:do-query + #:map-query + #:loop + ;; CLSQL Extensions + #:prepare-sql + #:bind-parameter + #:run-prepared-sql + #:free-prepared-sql + + ;; Transaction handling (transaction.lisp) + #:with-transaction + #:commit + #:rollback + ;; CLSQL Extensions + #:add-transaction-commit-hook + #:add-transaction-rollback-hook + #:start-transaction + #:in-transaction-p + #:set-autocommit + + ;; OODDL (ooddl.lisp) + #:standard-db-object + #:def-view-class + #:create-view-from-class + #:drop-view-from-class + #:list-classes + #:universal-time + ;; CLSQL Extensions + #:view-table + #:bigint + #:varchar + #:longchar + #:text + #:generalized-boolean + #:mediumint + #:smallint + #:tinyint + #:*default-string-length* + + ;; OODML (oodml.lisp) + #:select-list + #:filter-select-list + #:slot-list + #:joins + #:join-slots + #:instance-refreshed + #:update-objects-joins + #:*default-update-objects-max-len* + #:*default-caching* + #:update-slot-from-record + #:update-instance-from-records + #:update-records-from-instance + #:update-record-from-slot + #:update-record-from-slots + #:delete-instance-records + ;; CLSQL Extensions + #:*db-auto-sync* + #:write-instance-to-stream + #:read-instance-from-stream + + ;; Symbolic SQL Syntax (syntax.lisp) + #:sql + #:sql-expression + #:sql-operation + #:sql-operator + #:disable-sql-reader-syntax + #:enable-sql-reader-syntax + #:locally-disable-sql-reader-syntax + #:locally-enable-sql-reader-syntax + #:restore-sql-reader-syntax-state + #:file-enable-sql-reader-syntax + + ;; SQL operations (operations.lisp) + #:sql-query + #:sql-object-query + #:sql-any + #:sql-some + #:sql-all + #:sql-not + #:sql-union + #:sql-intersect + #:sql-minus + #:sql-except + #:sql-order-by + #:sql-null + #:sql-* + #:sql-+ + #:sql-/ + #:sql-- + #:sql-like + #:sql-and + #:sql-or + #:sql-in + #:sql-substr + #:sql-concat-op + #:sql-= + #:sql-< + #:sql-> + #:sql->= + #:sql-<= + #:sql-<> + #:sql-count + #:sql-max + #:sql-min + #:sql-avg + #:sql-sum + #:sql-function + #:sql-between + #:sql-distinct + #:sql-nvl + #:sql-slot-value + #:sql-userenv + ;; CLSQL Extensions + #:sql-concat + #:sql-substring + #:sql-limit + #:sql-group-by + #:sql-having + #:sql-not-null + #:sql-exists + #:sql-uplike + #:sql-is + #:sql-== + #:sql-the + #:sql-coalesce + #:sql-view-class + + ;; Time handling (time.lisp) + #:bad-component + #:current-day + #:current-month + #:current-year + #:day-duration + #:db-timestring + #:db-datestring + #:decode-duration + #:decode-time + #:decode-date + #: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 + #:format-date + #:get-time + #:get-date + #: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 + #:make-date + #:merged-time + #:midnight + #:month-name + #:parse-date-time + #:parse-timestring + #:parse-datestring + #: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>= + #:date + #:date+ + #:date- + #:date-difference + #:date-compare + #:date-dow + #:date-element + #:date-max + #:date-min + #:date-mjd + #:date-p + #:date-ymd + #:date< + #:date<= + #:date= + #:date> + #:date>= + #:timezone + #:universal-time + #:wall-time + #:wall-timestring + #:week-containing + #:gregorian-to-mjd + #:mjd-to-gregorian + #:iso-timestring + )) + (:documentation "This is the INTERNAL SQL-Interface package of CLSQL.")) + + +(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-sys . #1#) + (:export . #1#) + (:documentation "This is the user package with CLSQL symbols.")) + + ;; This is from USQL's pcl-patch + #+(or clsql-sbcl-pcl clsql-cmucl-pcl) + (progn + ;; Note that this will no longer required for cmucl as of version 19a. + (in-package #+cmu :pcl #+sbcl :sb-pcl) + (defmacro pv-binding1 ((pv calls pv-table-symbol pv-parameters slot-vars) + &body body) + `(pv-env (,pv ,calls ,pv-table-symbol ,pv-parameters) + (let (,@(mapcar #'(lambda (slot-var p) `(,slot-var (get-slots-or-nil ,p))) + slot-vars pv-parameters)) + ,@(mapcar #'(lambda (slot-var) `(declare (ignorable ,slot-var))) slot-vars) + ,@body)))) + +;; 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*)) + (setq cl:*features* (delete :clsql-sbcl-pcl cl:*features*))) + + #+cmu + (if (find-package 'mop) + (setq cl:*features* (delete :clsql-cmucl-mop cl:*features*)) + (setq cl:*features* (delete :clsql-cmucl-pcl cl:*features*))) + +) ;eval-when + diff --git a/sql/pool.lisp b/sql/pool.lisp new file mode 100644 index 0000000..a153c91 --- /dev/null +++ b/sql/pool.lisp @@ -0,0 +1,185 @@ +;;;; -*- 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 +;;;; +;;;; This file, part of CLSQL, is Copyright (c) 2002-2010 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) + +(defparameter *db-pool-max-free-connections* 4 + "Threshold of free-connections in the pool before we disconnect a database + rather than returning it to the pool. NIL for no limit. This is really a + heuristic that should, on avg keep the free connections about this size.") + +(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 nil) + (all-connections :accessor all-connections :initform nil) + (lock :accessor conn-pool-lock + :initform (make-process-lock "Connection pool")))) + + + + +(defun acquire-from-pool (connection-spec database-type &optional pool (encoding *default-encoding*)) + "Try to find a working database connection in the pool or create a new +one if needed. This performs 1 query against the DB to ensure it's still +valid. When possible (postgres, mssql) that query will be a reset +command to put the connection back into its default state." + (unless (typep pool 'conn-pool) + (setf pool (find-or-create-connection-pool connection-spec database-type))) + (or + (loop for pconn = (with-process-lock ((conn-pool-lock pool) "Acquire") + (pop (free-connections pool))) + always pconn + thereis + ;; test if connection still valid. + ;; (e.g. db reboot -> invalid connection ) + (handler-case + (progn (database-acquire-from-conn-pool pconn) + pconn) + (sql-database-error (e) + ;; we could check for a specific error, + ;; but, it's safer just to disconnect the pooled conn for any error ? + (warn "Database connection ~S had an error while acquiring from the pool: + ~S +Disconnecting.~%" + pconn e) + ;;run database disconnect to give chance for cleanup + ;;there, then remove it from the lists of connected + ;;databases. + (%pool-force-disconnect pconn) + (with-process-lock ((conn-pool-lock pool) "remove dead conn") + (setf (all-connections pool) + (delete pconn (all-connections pool)))) + nil))) + (let ((conn (connect (connection-spec pool) + :database-type (pool-database-type pool) + :if-exists :new + :make-default nil + :encoding encoding))) + (setf (conn-pool conn) pool) + (with-process-lock ((conn-pool-lock pool) "new conection") + (push conn (all-connections pool))) + conn))) + +(defun release-to-pool (database &optional (pool (conn-pool database))) + "Release a database connection to the pool. The backend will have a +chance to do cleanup." + (unless (conn-pool database) (setf (conn-pool database) pool)) + (cond + ;;We read the list of free-connections outside the lock. This + ;;should be fine as long as that list is never dealt with + ;;destructively (push and pop destructively modify the place, + ;;not the list). Multiple threads getting to this test at the + ;;same time might result in the free-connections getting + ;;longer... meh. + ((or (and *db-pool-max-free-connections* + (>= (length (free-connections pool)) + *db-pool-max-free-connections*))) + (%pool-force-disconnect database) + + (with-process-lock ((conn-pool-lock pool) "Remove extra Conn") + (setf (all-connections pool) + (delete database (all-connections pool))))) + (t + ;;let it do cleanup + (database-release-to-conn-pool database) + (with-process-lock ((conn-pool-lock pool) "Release to pool") + (push database (free-connections pool)))))) + +(defmethod database-acquire-from-conn-pool (database) + (case (database-underlying-type database) + (:postgresql + (database-execute-command "RESET ALL" database)) + (:mysql + (database-query "SHOW ERRORS LIMIT 1" database nil nil)) + (:mssql + ;; rpc escape sequence since this can't be called as a normal sp. + ;;http://msdn.microsoft.com/en-us/library/aa198358%28SQL.80%29.aspx + (database-execute-command "{rpc sp_reset_connection}" database)) + (T + (database-query "SELECT 1;" database '(integer) nil)))) + +(defmethod database-release-to-conn-pool (database) + (case (database-underlying-type database) + (:postgresql + (ignore-errors + ;;http://www.postgresql.org/docs/current/static/sql-discard.html + ;;this was introduced relatively recently, wrap in ignore-errors + ;;so that it doesn't choke older versions. + (database-execute-command "DISCARD ALL" database))))) + +(defun clear-conn-pool (pool) + "Be careful this function will disconnect connections without regard +to whether another thread is actively using them." + (with-process-lock ((conn-pool-lock pool) "Clear pool") + (mapc #'%pool-force-disconnect (all-connections pool)) + (setf (all-connections pool) nil + (free-connections pool) nil)) + 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" + (let ((key (list connection-spec database-type))) + (with-process-lock (*db-pool-lock* "Find-or-create connection") + (or (gethash key *db-pool*) + (setf (gethash key *db-pool*) + (make-instance 'conn-pool + :connection-spec connection-spec + :pool-database-type database-type)))))) + +(defun disconnect-pooled (&optional clear) + "Disconnects all connections in the pool. When clear, also deletes +the pool objects." + (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-force-disconnect (database) + "Force disconnection of a connection from the pool." + ;;so it isn't just returned to pool + (setf (conn-pool database) nil) + ;; disconnect may error if remote side closed connection + (ignore-errors (disconnect :database database))) + +;(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))) diff --git a/sql/recording.lisp b/sql/recording.lisp new file mode 100644 index 0000000..02bb972 --- /dev/null +++ b/sql/recording.lisp @@ -0,0 +1,165 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; +;;;; 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*)) + "Starts recording of SQL commands sent to and/or results +returned from DATABASE which defaults to *DEFAULT-DATABASE*. The +SQL is output on one or more broadcast streams, initially just +*STANDARD-OUTPUT*, and the functions ADD-SQL-STREAM and +DELETE-SQL-STREAM may be used to add or delete command or result +recording streams. The default value of TYPE is :commands which +means that SQL commands sent to DATABASE are recorded. If TYPE +is :results then SQL results returned from DATABASE are +recorded. Both commands and results may be recorded by passing +TYPE value of :both." + (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 commands sent to and/or results +returned from DATABASE which defaults to *DEFAULT-DATABASE*. The +default value of TYPE is :commands which means that SQL commands +sent to DATABASE will no longer be recorded. If TYPE is :results +then SQL results returned from DATABASE will no longer be +recorded. Recording may be stopped for both commands and results +by passing TYPE value of :both." + (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*)) + "Predicate to test whether the SQL recording specified by TYPE +is currently enabled for DATABASE which defaults to *DEFAULT-DATABASE*. +TYPE may be one of :commands, :results, :both or :either, defaulting to +:commands, otherwise nil is returned." + (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*)) + "Adds the supplied stream STREAM (or T for *standard-output*) +as a component of the recording broadcast stream for the SQL +recording type specified by TYPE on DATABASE which defaults to +*DEFAULT-DATABASE*. TYPE must be one of :commands, :results, +or :both, defaulting to :commands, depending on whether the +stream is to be added for recording SQL commands, results or +both." + (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 supplied stream STREAM from the recording broadcast +stream for the SQL recording type specified by TYPE on DATABASE +which defaults to *DEFAULT-DATABASE*. TYPE must be one +of :commands, :results, or :both, defaulting to :commands, +depending on whether the stream is to be added for recording SQL +commands, results or both." + (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 list of component streams for the broadcast stream +recording SQL commands sent to and/or results returned from +DATABASE which defaults to *DEFAULT-DATABASE*. TYPE must be one +of :commands, :results, or :both, defaulting to :commands, and +determines whether the listed streams contain those recording SQL +commands, results or both." + (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 stream used for recording SQL commands +sent to or results returned from DATABASE which defaults to +*DEFAULT-DATABASE*. TYPE must be one of :commands or :results, +defaulting to :commands, and determines whether the stream +returned is that used for recording SQL commands or results." + (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) + (when database + (with-slots (command-recording-stream) + database + (when command-recording-stream + (format command-recording-stream "~&;; ~A ~A => ~A~%" + (iso-timestring (get-time)) + (database-name database) + expr))))) + +(defun record-sql-result (res database) + (when database + (with-slots (result-recording-stream) + database + (when result-recording-stream + (format result-recording-stream "~&;; ~A ~A <= ~A~%" + (iso-timestring (get-time)) + (database-name database) + res))))) + + + diff --git a/sql/sequences.lisp b/sql/sequences.lisp new file mode 100644 index 0000000..1b32f29 --- /dev/null +++ b/sql/sequences.lisp @@ -0,0 +1,103 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; +;;;; Generic sequence implementation. Backends should use native sequences if +;;;; are available. +;;;; +;;;; 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 generic-database (database) + () + (:documentation "Encapsulate same behavior across backends.")) + + +;;; Sequence functions + +(defvar *old-sequence-names* nil + "Should CLSQL use its old sequence naming scheme _CLSQL_SEQ_{table} instead + of the current scheme {table}_CLSQL_SEQ") + +(defun %sequence-name-to-table (sequence-name database) + (escaped + (combine-database-identifiers + (if *old-sequence-names* + (list '_CLSQL_SEQ sequence-name) + (list sequence-name 'CLSQL_SEQ)) + database))) + +(defmethod database-create-sequence (sequence-name database) + (let ((table-name (%sequence-name-to-table sequence-name database))) + (database-execute-command + (concatenate 'string "CREATE TABLE " table-name + " (last_value int NOT NULL PRIMARY KEY, increment_by int, min_value int, is_called char(1))") + database) + (database-execute-command + (concatenate 'string "INSERT INTO " table-name + " VALUES (1,1,1,'f')") + database))) + +(defmethod database-drop-sequence (sequence-name database) + (database-execute-command + (concatenate 'string "DROP TABLE " (%sequence-name-to-table sequence-name database)) + database)) + +(defun %seq-name-key () + (if *old-sequence-names* + "_CLSQL_SEQ_" + "_CLSQL_SEQ")) + +(defun %table-name-to-sequence-name (table-name) + ;; if this was escaped it still should be, + ;; if it wasnt it still shouldnt-be + (check-type table-name string) + (replace-all table-name (%seq-name-key) "")) + +(defmethod database-list-sequences (database &key (owner nil)) + (declare (ignore owner)) + (mapcan #'(lambda (s) + (and (search (%seq-name-key) s :test #'string-equal) + (list (%table-name-to-sequence-name s)))) + (database-list-tables-and-sequences database))) + +(defmethod database-set-sequence-position (sequence-name position database) + (database-execute-command + (format nil "UPDATE ~A SET last_value=~A,is_called='t'" + (%sequence-name-to-table sequence-name database) + position) + database) + position) + +(defmethod database-sequence-next (sequence-name database) + (without-interrupts + (let* ((table-name (%sequence-name-to-table sequence-name database)) + (tuple + (car (database-query + (concatenate 'string "SELECT last_value,is_called FROM " + table-name) + database :auto nil)))) + (cond + ((char-equal (schar (second tuple) 0) #\f) + (database-execute-command + (format nil "UPDATE ~A SET is_called='t'" table-name) + database) + (car tuple)) + (t + (let ((new-pos (1+ (car tuple)))) + (database-execute-command + (format nil "UPDATE ~A SET last_value=~D" table-name new-pos) + database) + new-pos)))))) + +(defmethod database-sequence-last (sequence-name database) + (without-interrupts + (caar (database-query + (concatenate 'string "SELECT last_value FROM " + (%sequence-name-to-table sequence-name database)) + database :auto nil)))) diff --git a/sql/syntax.lisp b/sql/syntax.lisp new file mode 100644 index 0000000..68fa8aa --- /dev/null +++ b/sql/syntax.lisp @@ -0,0 +1,198 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; +;;;; CLSQL square bracket symbolic query syntax. Functions for +;;;; enabling and disabling the syntax and for building SQL +;;;; expressions using the syntax. +;;;; +;;;; 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) + +(defvar *original-readtable* nil) + +(defvar *sql-macro-open-char* #\[) + +(defvar *sql-macro-close-char* #\]) + +(defvar *restore-sql-reader-syntax* nil) + + +;; Exported functions for disabling SQL syntax. + +(defmacro disable-sql-reader-syntax () + "Turns off the SQL reader syntax setting the syntax state such +that if the syntax is subsequently enabled, +RESTORE-SQL-READER-SYNTAX-STATE will disable it again." + '(eval-when (:compile-toplevel :load-toplevel :execute) + (setf *restore-sql-reader-syntax* nil) + (%disable-sql-reader-syntax))) + +(defmacro locally-disable-sql-reader-syntax () + "Turns off the SQL reader syntax without changing the syntax +state such that RESTORE-SQL-READER-SYNTAX-STATE will re-establish +the current syntax state." + '(eval-when (:compile-toplevel :load-toplevel :execute) + (%disable-sql-reader-syntax))) + +(defun %disable-sql-reader-syntax () + (when *original-readtable* + (setf *readtable* *original-readtable* + *original-readtable* nil)) + (values)) + + +;; Exported functions for enabling SQL syntax. + +(defmacro enable-sql-reader-syntax () + "Turns on the SQL reader syntax setting the syntax state such +that if the syntax is subsequently disabled, +RESTORE-SQL-READER-SYNTAX-STATE will enable it again." + '(eval-when (:compile-toplevel :load-toplevel :execute) + (setf *restore-sql-reader-syntax* t) + (%enable-sql-reader-syntax))) + +(defmacro locally-enable-sql-reader-syntax () + "Turns on the SQL reader syntax without changing the syntax +state such that RESTORE-SQL-READER-SYNTAX-STATE will re-establish +the current syntax state." + '(eval-when (:compile-toplevel :load-toplevel :execute) + (%enable-sql-reader-syntax))) + +(defmacro file-enable-sql-reader-syntax () + "Turns on the SQL reader syntax for the rest of the file. +The CL spec says that when finished loading a file the original +*readtable* is restored. clhs COMPILE-FILE" + '(eval-when (:compile-toplevel :load-toplevel :execute) + (setf *readtable* (copy-readtable)) + (set-macro-character *sql-macro-open-char* #'sql-reader-open) + (set-macro-character *sql-macro-close-char* (get-macro-character #\))))) + +(defun %enable-sql-reader-syntax () + (unless *original-readtable* + (setf *original-readtable* *readtable* + *readtable* (copy-readtable)) + (set-macro-character *sql-macro-open-char* #'sql-reader-open) + (set-macro-character *sql-macro-close-char* (get-macro-character #\)))) + (values)) + +(defmacro restore-sql-reader-syntax-state () + "Enables the SQL reader syntax if ENABLE-SQL-READER-SYNTAX has +been called more recently than DISABLE-SQL-READER-SYNTAX and +otherwise disables the SQL reader syntax. By default, the SQL +reader syntax is disabled." + '(eval-when (:compile-toplevel :load-toplevel :execute) + (if *restore-sql-reader-syntax* + (%enable-sql-reader-syntax) + (%disable-sql-reader-syntax)))) + +(defun sql-reader-open (stream char) + (declare (ignore char)) + (let ((sqllist (read-delimited-list #\] stream t))) + (unless *read-suppress* + (handler-case + (cond ((string= (write-to-string (car sqllist)) "||") + (cons (sql-operator 'concat-op) (cdr sqllist))) + ((and (= (length sqllist) 1) (eql (car sqllist) '*)) + (apply #'generate-sql-reference sqllist)) + ((sql-operator (car sqllist)) + (cons (sql-operator (car sqllist)) (cdr sqllist))) + (t (apply #'generate-sql-reference sqllist))) + (sql-user-error (c) + (error 'sql-user-error + :message (format nil "Error ~A occured while attempting to parse '~A' at file position ~A" + (sql-user-error-message c) sqllist (file-position stream)))))))) + +(defun generate-sql-reference (&rest arglist) + (cond ((= (length arglist) 1) ; string, table or attribute + (let ((arg (first arglist))) + (typecase arg + (string (sql-expression :string arg)) + (symbol ;; handle . separated names + (let* ((sn (symbol-name arg)) + (idx (position #\. sn))) + (cond + (idx (sql-expression :table (intern (subseq sn 0 idx)) + :attribute (intern (subseq sn (+ idx 1))) )) + (T (sql-expression :attribute arg)))) + )))) + ((<= 2 (length arglist)) + (let ((sqltype (when (keywordp (caddr arglist)) (caddr arglist) nil))) + (cond + ((stringp (cadr arglist)) + (sql-expression :table (car arglist) + :alias (cadr arglist) + :type sqltype)) + ((keywordp (cadr arglist)) + (sql-expression :attribute (car arglist) + :type (cadr arglist))) + (t + (sql-expression :attribute (cadr arglist) + :table (car arglist) + :type sqltype))))) + (t + (error 'sql-user-error :message "bad expression syntax")))) + + +;; Exported functions for dealing with SQL syntax + +(defun sql (&rest args) + "Returns an SQL string generated from the expressions ARGS. The +expressions are translated into SQL strings and then concatenated +with a single space delimiting each expression. An error of type +SQL-USER-ERROR is signalled if any element in ARGS is not of the +supported types (a symbol, string, number or symbolic SQL +expression) or a list or vector containing only these supported +types." + (format nil "~{~A~^ ~}" (mapcar #'sql-output args))) + +(defun sql-expression (&key string table alias attribute type) + "Returns an SQL expression constructed from the supplied +arguments which may be combined as follows: ATTRIBUTE and TYPE; +ATTRIBUTE; ALIAS or TABLE and ATTRIBUTE and TYPE; ALIAS or TABLE +and ATTRIBUTE; TABLE, ATTRIBUTE and TYPE; TABLE and ATTRIBUTE; +TABLE and ALIAS; TABLE; and STRING. An error of type +SQL-USER-ERROR is signalled if an unsupported combination of +keyword arguments is specified." + (cond + (string + (make-instance 'sql :string string)) + (attribute + (make-instance 'sql-ident-attribute :name attribute + :qualifier (or table alias) + :type type)) + ((and table (not attribute)) + (make-instance 'sql-ident-table :name table + :table-alias alias)))) + +(defun sql-operator (operator) + "Returns the Lisp symbol corresponding to the SQL operator + represented by the symbol OPERATOR. If OPERATOR does not + represent a supported SQL operator or is not a symbol, nil is + returned." + (typecase operator + (string nil) + (symbol (values (gethash (symbol-name-default-case (symbol-name operator)) + *sql-op-table*))))) + +(defun sql-operation (operator &rest args) + "Returns an SQL expression constructed from the supplied symbol +OPERATOR representing an SQL operator or function and its +arguments ARGS. An error of type SQL-USER-ERROR is signalled if +OPERATOR is not a symbol representing a supported SQL +operator. If OPERATOR is passed the symbol FUNCTION then the +first value in ARGS must be a string representing a valid SQL +function and the remaining values in ARGS its arguments as +strings." + (if (sql-operator operator) + (apply (symbol-function (sql-operator operator)) args) + (error 'sql-user-error + :message + (format nil "~A is not a recognized SQL operator." operator)))) + + diff --git a/sql/time.lisp b/sql/time.lisp new file mode 100644 index 0000000..0bb18c3 --- /dev/null +++ b/sql/time.lisp @@ -0,0 +1,1359 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; +;;;; 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) + (usec 0 :type fixnum)) + +(defun %print-wall-time (time stream depth) + (declare (ignore depth)) + (if *print-escape* + (format stream "#<WALL-TIME: ~a>" (format-time nil time)) + (format-time stream time :format :pretty))) + +(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) + (usec 0 :type fixnum)) + +(defun %print-duration (duration stream depth) + (declare (ignore depth)) + (if *print-escape* + (format stream "#<DURATION: ~a>" + (format-duration nil duration :precision :second)) + (format-duration stream duration :precision :second))) + +(defstruct (date (:constructor %make-date) + (:print-function %print-date)) + (mjd 0 :type fixnum)) + +(defun %print-date (date stream depth) + (declare (ignore depth)) + (if *print-escape* + (format stream "#<DATE: ~a>" (format-date nil date)) + (format-date stream date :format :pretty))) + +);eval-when + +(defun duration-timestring (duration) + (let ((second (duration-second duration)) + (minute (duration-minute duration)) + (hour (duration-hour duration)) + (day (duration-day duration)) + (month (duration-month duration)) + (year (duration-year duration))) + (format nil "P~dY~dM~dD~dH~dM~dS" year month day hour minute second))) + + +;; ------------------------------------------------------------ +;; Constructors + +(defun make-time (&key (year 0) (month 1) (day 1) (hour 0) (minute 0) + (second 0) (usec 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 :usec usec)))) + +(defun make-date (&key (year 0) (month 1) (day 1) (hour 0) (minute 0) + (second 0) (usec 0) (offset 0)) + (time->date (make-time :year year :month month :day day :hour hour + :minute minute :second second :usec usec :offset offset))) + +(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 date->time (date) + "Returns a walltime for the given date" + (%make-wall-time :mjd (date-mjd date))) + +(defun time->date (time) + "Returns a date for the given wall time (obvious loss in resolution)" + (%make-date :mjd (time-mjd time))) + +(defun get-time () + "Return a pair: (GREGORIAN DAY . TIME-OF-DAY)" + (utime->time (get-universal-time))) + +(defun get-date () + "Returns a date for today" + (time->date (get-time))) + +(defun make-duration (&key (year 0) (month 0) (day 0) (hour 0) (minute 0) + (second 0) (usec 0)) + (multiple-value-bind (second-add usec-1000000) + (floor usec 1000000) + (multiple-value-bind (minute-add second-60) + (floor (+ second second-add) 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 + :usec usec-1000000)))))) + + +;; ------------------------------------------------------------ +;; 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: usec, 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 (time-usec time) second minute hour day month year (mod (+ (time-mjd time) 3) 7))))) + +(defun date-ymd (date) + (time-ymd (date->time date))) + +(defun date-dow (date) + (time-dow (date->time date))) + +(defun decode-date (date) + "returns the decoded date as multiple values: day month year integer day-of-week" + (multiple-value-bind (year month day) + (time-ymd (date->time date)) + (values day month year (date-dow date)))) + +;; duration specific +(defun duration-reduce (duration precision &optional round) + (ecase precision + (:usec + (+ (duration-usec duration) + (* (duration-reduce duration :second) 1000000))) + (:second + (+ (if round + (floor (duration-usec duration) 500000) + 0) + (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 :usec) + (duration-reduce duration-b :usec))) + +(defun duration< (duration-a duration-b) + (< (duration-reduce duration-a :usec) + (duration-reduce duration-b :usec))) + +(defun duration<= (duration-a duration-b) + (<= (duration-reduce duration-a :usec) + (duration-reduce duration-b :usec))) + +(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) + (if (/= (time-second x) (time-second y)) + (< (time-second x) (time-second y)) + (< (time-usec x) (time-usec y)))))) + +(defun %time>= (x y) + (if (/= (time-mjd x) (time-mjd y)) + (>= (time-mjd x) (time-mjd y)) + (if (/= (time-second x) (time-second y)) + (>= (time-second x) (time-second y)) + (>= (time-usec x) (time-usec y))))) + +(defun %time<= (x y) + (if (/= (time-mjd x) (time-mjd y)) + (<= (time-mjd x) (time-mjd y)) + (if (/= (time-second x) (time-second y)) + (<= (time-second x) (time-second y)) + (<= (time-usec x) (time-usec y))))) + +(defun %time> (x y) + (if (/= (time-mjd x) (time-mjd y)) + (> (time-mjd x) (time-mjd y)) + (if (/= (time-second x) (time-second y)) + (> (time-second x) (time-second y)) + (> (time-usec x) (time-usec y))))) + +(defun %time= (x y) + (and (= (time-mjd x) (time-mjd y)) + (= (time-second x) (time-second y)) + (= (time-usec x) (time-usec 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)) + (usec-a (time-usec time-a)) + (usec-b (time-usec time-b))) + (if (= mjd-a mjd-b) + (if (= sec-a sec-b) + (if (= usec-a usec-b) + :equal + (if (< usec-a usec-b) + :less-than + :greater-than)) + (if (< sec-a sec-b) + :less-than + :greater-than)) + (if (< mjd-a mjd-b) + :less-than + :greater-than)))) + +; now the same for dates +(eval-when (:compile-toplevel :load-toplevel) +(defun replace-string (string1 search-string replace-string &key (test #'string=)) + "Search within string1 for search-string, replace with replace-string, non-destructively." + (let ((replace-string-length (length replace-string)) + (search-string-length (length search-string))) + (labels ((sub-replace-string (current-string position) + (let ((found-position (search search-string current-string :test test :start2 position))) + (if (null found-position) + current-string + (sub-replace-string (concatenate 'string + (subseq current-string 0 found-position) + replace-string + (subseq current-string (+ found-position search-string-length))) + (+ position replace-string-length)))))) + (sub-replace-string string1 0)))) +);eval-when + +(defmacro wrap-time-for-date (time-func &key (result-func)) + (let ((date-func (intern (replace-string (symbol-name time-func) + (symbol-name-default-case "TIME") + (symbol-name-default-case "DATE"))))) + `(defun ,date-func (number &rest more-numbers) + (let ((result (apply #',time-func (mapcar #'date->time (cons number more-numbers))))) + ,(if result-func + `(funcall #',result-func result) + 'result))))) + +(wrap-time-for-date time=) +(wrap-time-for-date time/=) +(wrap-time-for-date time<) +(wrap-time-for-date time>) +(wrap-time-for-date time<=) +(wrap-time-for-date time>=) +(wrap-time-for-date time-max :result-func time->date) +(wrap-time-for-date time-min :result-func time->date) + +(defun date-compare (date-a date-b) + (time-compare (date->time date-a) (date->time date-b))) + +;; ------------------------------------------------------------ +;; Formatting and output +(defun db-timestring (time &key stream) + "return the string to store the given time in the database" + (if stream + (progn (write-char #\' stream) (iso-timestring time :stream stream) (write-char #\' stream)) + (concatenate 'string "'" (iso-timestring time) "'"))) + +(defun iso-timestring (time &key stream) + (multiple-value-bind (usec sec min hour day month year dow) + (decode-time time) + (declare (ignore dow)) + (flet ((fmt (stream) + (when (< year 1000) (princ #\0 stream)) + (when (< year 100) (princ #\0 stream)) + (when (< year 10) (princ #\0 stream)) + (princ year stream) + (princ #\- stream) + (when (< month 10) (princ #\0 stream)) + (princ month stream) + (princ #\- stream) + (when (< day 10) (princ #\0 stream)) + (princ day stream) + (princ #\T stream) ;strict ISO says T here isn't optional. + (when (< hour 10) (princ #\0 stream)) + (princ hour stream) + (princ #\: stream) + (when (< min 10) (princ #\0 stream)) + (princ min stream) + (princ #\: stream) + (when (< sec 10) (princ #\0 stream)) + (princ sec stream) + (when (and usec (plusp usec)) + ;; we dont do this because different dbs support differnt precision levels + (princ #\. stream) + (loop for i from 5 downto 0 + for x10 = (expt 10 i) + do (multiple-value-bind (quo rem) + (floor (/ usec x10)) + (setf usec (- usec (* quo x10))) + (princ quo stream) + (when (= rem 0) (return))))) + nil)) + (if stream + (fmt stream) + (with-output-to-string (stream) + (fmt stream)))))) + +(defun db-datestring (date) + (db-timestring (date->time date))) +(defun iso-datestring (date) + (iso-timestring (date->time date))) + + +;; ------------------------------------------------------------ +;; 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)) + (usec (duration-usec 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)) + (incf usec (duration-usec duration))) + (make-duration :year year :month month :day day :hour hour :minute minute + :second second :usec usec))) + +(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)) + (usec (duration-usec 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)) + (decf usec (duration-usec duration))) + (make-duration :year year :month month :day day :hour hour :minute minute + :second second :usec usec))) + +;; 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) + :usec (duration-usec duration) + :destructive t)) + new-time)) + +(defun date+ (date &rest durations) + "Add each DURATION to DATE, returning a new date value. +Note that (barring daylight saving time) 12h + 12h will result in a new day, but doing +it as separate calculations will not, as the time is chopped to a date before being returned." + (time->date (apply #'time+ (cons (date->time date) durations)))) + +(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)) + :usec (- (duration-usec duration)) + :destructive t)) + new-time)) + +(defun date- (date &rest durations) + "Subtract each DURATION to DATE, returning a new date value. +Note that (barring daylight saving time) 12h + 12h will result in a new day, but doing +it as separate calculations will not, as the time is chopped to a date before being returned." + (time->date (apply #'time- (cons (date->time date) durations)))) + +(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 date-difference (date1 date2) + "Returns a DURATION representing the difference between TIME1 and +TIME2." + (time-difference (date->time date1) (date->time date2))) + +(defun format-date (stream date &key format + (date-separator "-") + (internal-separator " ")) + "produces on stream the datestring corresponding to the date +with the given options" + (format-time stream (date->time date) + :format format + :date-separator date-separator + :internal-separator internal-separator)) + +(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 (usec 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 :iso8601) (iso-timestring time :stream stream)) + (t (format stream "~2,'0D~A~2,'0D~A~2,'0D~A~2,'0D~A~2,'0D~A~2,'0D.~6,'0D" + year date-separator month date-separator day + internal-separator hour time-separator minute time-separator + second usec) + ))))) + +(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 () + (first (mjd-to-gregorian (time-mjd (get-time))))) + +(defun current-day () + (second (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 (usec second minute hour day month year dow) + (decode-time time) + (declare (ignore usec 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 (usec second minute hour day month year dow) + (decode-time time) + (declare (ignore usec)) + (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 date-element (date element) + (time-element (date->time date) element)) + +(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)) + (month (duration-month duration)) + (year (duration-year 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 year month day hour minute) + (format stream "0 minutes") + (let ((sent? nil)) + (when (< 0 year) + (format stream "~d year~p" year year) + (setf sent? t)) + (when (< 0 month) + (when sent? + (write-char #\Space stream)) + (format stream "~d month~p" month month) + (setf sent? t)) + (when (< 0 day) + (when sent? + (write-char #\Space stream)) + (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) (usec 0) (destructive nil)) + (unless (= 0 year month) + (multiple-value-bind (year-orig month-orig day-orig) + (time-ymd date) + (multiple-value-bind (new-year new-month) + (floor (+ month month-orig (* 12 (+ year year-orig))) 12) + (let ((new-date (make-time :year new-year + :month new-month + :day day-orig + :second (time-second date) + :usec usec))) + (if destructive + (setf (time-mjd date) (time-mjd new-date)) + (setq date new-date)))))) + (let ((mjd (time-mjd date)) + (sec (time-second date))) + (multiple-value-bind (sec-new usec-new) + (floor (+ usec (time-usec date) + (* 1000000 + (+ sec second + (* 60 minute) + (* 60 60 hour)))) + 1000000) + (multiple-value-bind (mjd-new sec-new) + (floor sec-new (* 60 60 24)) + (if destructive + (progn + (setf (time-mjd date) (+ mjd mjd-new day) + (time-second date) sec-new + (time-usec date) usec-new) + date) + (%make-wall-time :mjd (+ mjd mjd-new day) + :second sec-new + :usec usec-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 (sql-user-error) + ((bad-component;; year, month whatever + :initarg :bad-component + :reader bad-component)) + (:report (lambda (c stream) + (format stream "Bad component: ~A " (bad-component c))))) + +(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)) + (etypecase timestring + (wall-time timestring) + (date (date->time timestring)) + (string + (let ((string (subseq timestring start end))) + (if (char= (aref string 0) #\P) + (parse-iso-8601-duration string) + (parse-iso-8601-time string)))))) + +(defun parse-datestring (datestring &key (start 0) end junk-allowed) + "parse a ISO 8601 timestring and return the corresponding date. +Will throw a hissy fit if the date string is a duration. Will ignore any precision beyond day (hour/min/sec/usec)." + (etypecase datestring + (date datestring) + (wall-time (time->date datestring)) + (string + (let ((parsed-value + (parse-timestring + datestring :start start :end end :junk-allowed junk-allowed))) + (etypecase parsed-value + (date parsed-value) + (wall-time (time->date parsed-value))))))) + + +(defvar *iso-8601-duration-delimiters* + '((#\Y . :years) + (#\D . :days) + (#\H . :hours) + (#\M . :months/minutes) + (#\S . :seconds))) + +(defun iso-8601-delimiter (elt) + (cdr (assoc elt *iso-8601-duration-delimiters*))) + +(defun iso-8601-duration-subseq (string end) + (let* ((pos (position-if #'iso-8601-delimiter string :end end :from-end t)) + (pos2 (when pos + (position-if-not #'digit-char-p string :end pos :from-end t))) + (number (when pos2 + (parse-integer + (subseq string (1+ pos2) pos) :junk-allowed t)))) + (when number + (values number + (1+ pos) + (1+ pos2) + (iso-8601-delimiter (aref string pos)))))) + +(defun parse-iso-8601-duration (string) + "return a wall-time from a duration string" + (block parse + (let ((years 0) + (months 0) + (days 0) + (secs 0) + (hours 0) + (minutes 0) + (index (length string)) + (months/minutes nil)) + (loop + (multiple-value-bind (duration end next-index duration-type) + (iso-8601-duration-subseq string index) + (declare (ignore end)) + (case duration-type + (:years + (incf years duration)) + (:months/minutes + (if months/minutes + (incf months duration) + (progn + (setq months/minutes t) + (incf minutes duration)))) + (:days + (setq months/minutes t) + (incf days duration)) + (:hours + (setq months/minutes t) + (incf hours duration)) + (:seconds + (incf secs duration)) + (t + (return-from parse + (make-duration + :year years :month months :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 usec offset) + (syntax-parse-iso-8601 string) + (make-time :year year + :month month + :day day + :hour hour + :minute minute + :second second + :usec usec + :offset offset))) + + +(defun syntax-parse-iso-8601 (string) + ;; use strlen to determine if fractional seconds are present in timestamp + (let ((strlen (length string)) + year month day hour minute second usec gmt-sec-offset) + (handler-case + (progn + (setf year (parse-integer string :start 0 :end 4) + month (parse-integer string :start 5 :end 7) + day (parse-integer string :start 8 :end 10) + hour (if (<= 13 strlen) + (parse-integer string :start 11 :end 13) + 0) + minute (if (<= 16 strlen) + (parse-integer string :start 14 :end 16) + 0) + second (if (<= 19 strlen) + (parse-integer string :start 17 :end 19) + 0)) + (cond + ((and (> strlen 19) + (or (char= #\, (char string 19)) + (char= #\. (char string 19)))) + (multiple-value-bind (parsed-usec usec-end) + (parse-integer string :start 20 :junk-allowed t) + (let ((parsed-usec (and parsed-usec + (floor (* parsed-usec (expt 10 (+ 6 (- usec-end) 20))))))) + (setf usec (or parsed-usec 0) + gmt-sec-offset (if (<= (+ 3 usec-end) strlen) + (let ((skip-to (or (position #\+ string :start 19) + (position #\- string :start 19)))) + (if skip-to + (* 60 60 + (parse-integer string :start skip-to + :end (+ skip-to 3))) + 0)) + 0))))) + (t + (setf usec 0 + gmt-sec-offset (if (<= 22 strlen) + (let ((skip-to (or (position #\+ string :start 19) + (position #\- string :start 19)))) + (if skip-to + (* 60 60 + (parse-integer string :start skip-to + :end (+ skip-to 3))) + 0)) + 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 usec 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) + (usec . ,usec) + (timezone . ,gmt-sec-offset))))))))) diff --git a/sql/transaction.lisp b/sql/transaction.lisp new file mode 100644 index 0000000..24465d1 --- /dev/null +++ b/sql/transaction.lisp @@ -0,0 +1,152 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; +;;;; 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) + (previous-autocommit :initarg :previous-autocommit + :reader previous-autocommit) + (status :initform nil :accessor transaction-status + :documentation "nil or :committed"))) + +(defun add-transaction-commit-hook (commit-hook &key + (database *default-database*)) + "Adds COMMIT-HOOK, which should a designator for a function +with no required arguments, to the list of hooks run when COMMIT +is called on DATABASE which defaults to *DEFAULT-DATABASE*." + (when (transaction database) + (push commit-hook (commit-hooks (transaction database))))) + +(defun add-transaction-rollback-hook (rollback-hook + &key (database *default-database*)) + "Adds ROLLBACK-HOOK, which should a designator for a function +with no required arguments, to the list of hooks run when ROLLBACK +is called on DATABASE which defaults to *DEFAULT-DATABASE*." + (when (transaction database) + (push rollback-hook (rollback-hooks (transaction database))))) + +(defmethod database-start-transaction ((database database)) + (unless (transaction database) + (setf (transaction database) + (make-instance 'transaction :previous-autocommit + (database-autocommit database)))) + ;; TODO: database-autocommit might get lost in some scenarios + ;; when pooling connections + (setf (database-autocommit database) nil) + (when (= (incf (transaction-level database)) 1) + (let ((transaction (transaction database))) + (setf (commit-hooks transaction) nil + (rollback-hooks transaction) nil + (transaction-status transaction) nil) + (case (database-underlying-type database) + (:oracle nil) + (:mssql (execute-command "BEGIN TRANSACTION" :database database)) + (t (execute-command "BEGIN" :database database)))))) + +;;ODBC should potentially be using the following scheme for transactions: +;; turn off autocommit for begin. then use sqlendtran (or maybe sqltransact) +;; whatever is appropriate for this version of odbc. +(defmethod database-commit-transaction ((database database)) + (with-slots (transaction transaction-level autocommit) database + (if (plusp transaction-level) + (if (zerop (decf transaction-level)) + (progn + (case (database-underlying-type database) + (:mssql (execute-command "COMMIT TRANSACTION" :database database)) + (t (execute-command "COMMIT" :database database))) + (setf autocommit (previous-autocommit transaction)) + (map nil #'funcall (commit-hooks transaction))) + (setf (transaction-status (transaction database)) nil)) + (warn 'sql-warning + :message + (format nil "Cannot commit transaction against ~A because there is no transaction in progress." + database))))) + +(defmethod database-abort-transaction ((database database)) + (with-slots (transaction transaction-level autocommit) database + (if (plusp transaction-level) + (when (zerop (decf transaction-level)) + (unwind-protect + (case (database-underlying-type database) + (:mssql (execute-command "ROLLBACK TRANSACTION" :database database)) + (t (execute-command "ROLLBACK" :database database))) + (setf autocommit (previous-autocommit transaction)) + (map nil #'funcall (rollback-hooks transaction)))) + (warn 'sql-warning + :message + (format nil "Cannot abort transaction against ~A because there is no transaction in progress." + database))))) + +(defun mark-transaction-committed (database) + (when (and (transaction database) + (not (transaction-status (transaction database)))) + (setf (transaction-status (transaction database)) :committed))) + +(defmacro with-transaction ((&key (database '*default-database*)) &body body) + "Starts a transaction in the database specified by DATABASE, +which is *DEFAULT-DATABASE* by default, and executes BODY within +that transaction. If BODY aborts or throws, DATABASE is rolled +back and otherwise the transaction is committed." + (let ((db (gensym "db-"))) + `(let ((,db ,database)) + (unwind-protect + (prog2 + (database-start-transaction ,db) + (progn + ,@body) + (mark-transaction-committed ,db)) + (if (eq (transaction-status (transaction ,db)) :committed) + (database-commit-transaction ,db) + (database-abort-transaction ,db)))))) + +(defun commit (&key (database *default-database*)) + "If DATABASE, which defaults to *DEFAULT-DATABASE*, is +currently within the scope of a transaction, commits changes made +since the transaction began." + (database-commit-transaction database) + nil) + +(defun rollback (&key (database *default-database*)) + "If DATABASE, which defaults to *DEFAULT-DATABASE*, is +currently within the scope of a transaction, rolls back changes +made since the transaction began." + (database-abort-transaction database) + nil) + +(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)) + nil) + +(defun in-transaction-p (&key (database *default-database*)) + "A predicate to test whether DATABASE, which defaults to +*DEFAULT-DATABASE*, is currently within the scope of a +transaction." + (and database (transaction database) (= (transaction-level database) 1))) + +(defun set-autocommit (value &key (database *default-database*)) + "Turns autocommit off for DATABASE if VALUE is NIL, and +otherwise turns it on. Returns the old value of autocommit flag. +For RDBMS (such as Oracle) which don't automatically commit +changes, turning autocommit on has the effect of explicitly +committing changes made whenever SQL statements are executed. +Autocommit is turned on by default." + (let ((old-value (database-autocommit database))) + (setf (database-autocommit database) value) + (database-autocommit database) + old-value)) + diff --git a/sql/utils.lisp b/sql/utils.lisp new file mode 100644 index 0000000..0196d04 --- /dev/null +++ b/sql/utils.lisp @@ -0,0 +1,511 @@ +;;;; -*- 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 +;;;; +;;;; This file, part of CLSQL, is Copyright (c) 2002-2010 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) + +(defmacro defaulting (&rest place-value-plist) + "for places and values (as an &rest plist) + if place-n is null set it to value-n" + `(progn + ,@(loop for (place value . rest) on place-value-plist by #'cddr + collect `(unless ,place (setf ,place ,value))))) + +(defmacro pop-n (place &optional (n 1)) + "pops n items off of a list in place and returns their values in a new list + + if n > the length of the list in place, then we return the full list, + setting the place to nil" + `(loop repeat ,n + while ,place + collect (pop ,place))) + +(defun %get-int (v) + (etypecase v + (string (parse-integer v :junk-allowed t)) + (integer v) + (number (truncate v)))) + +(defun dequote (it) + (if (and (listp it) (eql (first it) 'quote)) + (second it) + it)) + +(defvar +whitespace-chars+ + '(#\space #\tab #\newline #\return + ;; Tested: sbcl unicode, allegrocl, openmcl,clisp use #\no-break_space + ;; lispworks uses #\no-break-space + ;; sbcl non-unicode doesn't support no break space + ;; AllegroCL 8-bit strings don't fail on reading #\no-break_space, + ;; but can't represent such a character + ;; CMUCL errors when trying to read #\no-break_space + #+(and lispworks unicode) #\no-break-space + #+(or (and sbcl sb-unicode) (and allegro ics) (and clisp i18n) + (and openmcl openmcl-unicode-strings)) + #\no-break_space + ) + "List of whitespace characters for this lisp implementation.") + +(defun number-to-sql-string (num) + (etypecase num + (integer + (princ-to-string 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))) + (declare (type string str)) + (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)))) + (substitute #\_ #\- unescaped))) + +#+lispworks +(defvar +lw-has-without-preemption+ + #-(or lispworks5 lispworks4) nil + #+(or lispworks5 lispworks4) t) +#+lispworks +(defvar +lw-global-lock+ + (unless +lw-has-without-preemption+ + (mp:make-lock :name "CLSQL" :important-p nil :safep t :recursivep nil + :sharing t))) + +(defmacro without-interrupts (&body body) + #+allegro `(mp:without-scheduling ,@body) + #+clisp `(progn ,@body) + #+cmu `(system:without-interrupts ,@body) + #+lispworks + (if +lw-has-without-preemption+ + `(mp:without-preemption ,@body) + `(mp:with-exclusive-lock (+lw-global-lock+) + ,@body)) + #+openmcl `(ccl:without-interrupts ,@body) + #+sbcl `(sb-sys::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" + (when procstr + (locally + (declare (type string procstr)) + (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) + (declare (type string 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)))))) + + +(defun getenv (var) + "Return the value of the environment variable." + #+allegro (sys::getenv (string var)) + #+clisp (ext:getenv (string var)) + #+(or cmu scl) + (cdr (assoc (string var) ext:*environment-list* :test #'equalp + :key #'string)) + #+lispworks (lw:environment-variable (string var)) + #+ccl (ccl::getenv var) + #+sbcl (sb-ext:posix-getenv var)) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (when (char= #\a (schar (symbol-name '#:a) 0)) + (pushnew :clsql-lowercase-reader *features*))) + +(defun symbol-name-default-case (str) + #-clsql-lowercase-reader + (string-upcase str) + #+clsql-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))))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (setq cl:*features* (delete :clsql-lowercase-reader cl:*features*))) + +(defun replace-all (string part replacement &key (test #'char=) stream) + "Returns a new string in which all the occurences of the part +is replaced with replacement. [FROM http://cl-cookbook.sourceforge.net/strings.html#manip]" + (let ((out (or stream (make-string-output-stream)))) + (loop with part-length = (length part) + for old-pos = 0 then (+ pos part-length) + for pos = (search part string + :start2 old-pos + :test test) + do (write-string string out + :start old-pos + :end (or pos (length string))) + when pos do (write-string replacement out) + while pos) + (unless stream + (get-output-stream-string out)))) + +(defun read-decimal-value (string) + (let* ((comma 0) + (dot 0) + (last)) + (loop for c across string + do (case c + (#\. (incf dot) (setf last 'dot)) + (#\, (incf comma) (setf last 'comma)))) + (let* ((bag (if (and (eql last 'dot) (eql dot 1)) + ".0123456789+-" + ",0123456789+-")) + (clean (with-output-to-string (out) + (loop for c across string + do (when (find c bag :test #'char=) + (write-char c out)))))) + (if (and (eql last 'dot) (eql dot 1)) + (decimals:parse-decimal-number clean) + (decimals:parse-decimal-number + clean :decimal-separator #\,))))) + + +(defun filter-plist (plist &rest keys-to-remove) + "Returns a copy of the given plist with indicated key-value pairs +removed. keys are searched with #'MEMBER" + (declare (dynamic-extent keys-to-remove)) + (when plist + (loop for (k v . rest) = plist then rest + unless (member k keys-to-remove) + collect k and collect v + while rest))) + +(defmacro make-weak-hash-table (&rest args) + "Creates a weak hash table for use in a cache." + `(progn + + ;;NB: These are generally used for caches that may not have an alternate + ;;clearing mechanism. If you are on an implementation that doesn't support + ;;weak hash tables then you're memory may accumulate. + + #-(or sbcl allegro clisp lispworks ccl) + (warn "UNSAFE! use of weak hash on implementation without support. (see clsql/sql/utils.lisp to add)") + + (make-hash-table + #+allegro :values #+allegro :weak + #+clisp :weak #+clisp :value + #+lispworks :weak-kind #+lispworks :value + #+sbcl :weakness #+sbcl :value + #+ccl :weak #+ccl :value + ,@args) + )) + +(defun to-slot-name (slot) + "try to turn what we got representing the slot into a slot name" + (etypecase slot + (symbol slot) + (slot-definition (slot-definition-name slot)))) + +(defun to-class (it) + (etypecase it + (class it) + (symbol (find-class it)) + (standard-object (class-of it)))) + +(defun to-class-name (o) + (etypecase o + (symbol o) + (standard-class (class-name o)) + (standard-object (class-name (class-of o))))) + +(defun easy-slot-value (obj slot) + "like slot-value except it accepts slot-names or defs + and returns nil when the slot is unbound" + (let ((n (to-slot-name slot))) + (when (and obj (slot-boundp obj n)) + (slot-value obj n)))) + +(defun (setf easy-slot-value) (new obj slot) + "like slot-value except it accepts slot-names or defs" + (setf (slot-value obj (to-slot-name slot)) new)) + +(defun delist-if-single (x) + "if this is a single item in a list return it" + (if (and (listp x) (= 1 (length x))) + (first x) + x)) diff --git a/tests/Makefile b/tests/Makefile new file mode 100644 index 0000000..695e656 --- /dev/null +++ b/tests/Makefile @@ -0,0 +1,24 @@ +#!/usr/bin/make +########################################################################## +# FILE IDENTIFICATION +# +# Name: Makefile +# Purpose: Makefile for CLSQL tests +# Programer: Kevin M. Rosenberg +# Date Started: Mar 2002 +# +# 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. +########################################################################## + + +SUBDIRS= + +include ../Makefile.common + +.PHONY: distclean +distclean: clean + diff --git a/tests/README b/tests/README new file mode 100644 index 0000000..aa6a9a6 --- /dev/null +++ b/tests/README @@ -0,0 +1,124 @@ +* RUNNING THE REGRESSION SUITE + +This test suite looks for a configuration file named +".clsql-test.config" located in the users home directory. This file +contains a single assoc-list that specifies the connection specs for +each database type to be tested. There is an example file in +contained in CLSQL's examples directory. + +These tests require the downloading of the rt package from +http://files.kpe.io/. + +Load clsql.asd or put it somewhere where ASDF can find it +and call: + +(asdf:oos 'asdf:test-op 'clsql) + +The test suite will then automatically run on all of the backends that +you have defined in .clsql-test.config + +* REGRESSION TEST SUITE GOALS + +The intent of this test suite is to provide sufficient coverage for +the system to support the following: + +** Refactoring and Redesign of particular subsystems + +Refactoring and redesign efforts are normally restricted to a single +subsystem, or perhaps to interdependent subsystems. In such cases, a +set of regression tests which excercise the existing interface of the +rest of CLSQL to the changing subsystems should be in place and passing +before the coding starts. + +** Ensuring portability and Supporting new ports. + +The more coverage the test suite provides the easier portability is to +maintain, particularly if we have instances of the test suite running +against the head on the supporting lisp environment/OS/hardware/DBMS +combinations. Since no individual within the project has the ability +to run all of those combinations themselves, we are dependent upon some +informal coordination between the mintainers of the various ports. + +** Adding new RDBMS backends + +The entire CLSQL DBMS interface needs to be excercised by the test +suite, such that a new RDBMS backend that passes all the tests can be +reasonably assured of working with the CLSQL layers above that. These +tests should also serve as impromptu documentation for the details of +that interface and what it expects frothe RDBMS driver layers. + +** Bug identification and QA + +As new bugs are identified, they should have a regression test written +which excercises them. This is to ensue that we donot start +backtracking. These tests by theselves are also very valuable for +developers, so even if you cannot fix a bug yourself, providing a +testto excercise it greatly reduces the amount of timea developer must +spend finding the bug prior to fixing it. + + +* TEST DESIGN ISSUES + +** Multiple RDBMS Issues + +CLSQL supports several RDBMS backends, and it should be possible to run +every test against all of them. However, there are some features +which we want tests for but which are not implemented on several of +the backends. + +** Test Hygiene + +Tests should be able to be run multiple times against the same +database. It is also important that they clean up after themselves +when they create tables, sequences or other pesistent entities in the +RDBMS backends, because often there are limits to the number of those +thatcan exist at one time, and it also makes debuging thru the SQL +monitors difficult when there aretons of unused tables lying around. + +If test need to load large datasets, they should have a mechanism to +ensure the dataset is loaded just once, and not with every test run. + +Lastly, because there are various idiosyncracies with RDBMSs, please +ensure that you run the entire test suite once when you write your +tests, to ensure that your test does not leave some state behind which +causes other tests to fail. + +** Test Run Configuration + +The file test-init.lisp defines several variables which can be used to +control the connection dictionary of the database against which tests +will be run. + + +* DATABASE CONNECTIONS/LIFECYCLE + +** CreateDB + *** Without existing DB + *** With existing DB and use old + *** With existing DB and use new + *** Error if existing DB + +** Data Definition + *** Create Tables/Views/Sequences/Indexes -- Should cover creation of + tables with all supported types of fields. + *** Delete Tables/Views/Sequences/Indexes + *** Inspection of Tables and attributes, including types + +** Data Manipulation + *** Update + *** Insert + *** Delete + *** Query + +** Functional Interface + *** Creation/Modification of SQL expressions + *** Querying + +** Embedded SQL syntax + *** Excercise all sql operators + +** Object Interface + *** View class definition + *** Object creation/manipulation/deletion + *** Inter-object Relations + diff --git a/tests/benchmarks.lisp b/tests/benchmarks.lisp new file mode 100644 index 0000000..4e52890 --- /dev/null +++ b/tests/benchmarks.lisp @@ -0,0 +1,87 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: benchmarks.lisp +;;;; Purpose: Time performance tests for CLSQL +;;;; Authors: Kevin M. Rosenberg +;;;; Created: March 5, 2004 +;;;; +;;;; 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-tests) + +(defun run-benchmarks-append-report-file (report-file) + (run-function-append-report-file 'run-benchmarks report-file)) + +(clsql:def-view-class bench () + ((a :initarg :a + :type integer) + (b :initarg :b + :type (string 100)) + (c :initarg :c + :type float))) + +(defun run-benchmarks (&key (report-stream *standard-output*) (sexp-report-stream nil) (count 10000)) + (let ((specs (read-specs)) + (*report-stream* report-stream) + (*sexp-report-stream* sexp-report-stream)) + (unless specs + (warn "Not running benchmarks because test configuration file is missing") + (return-from run-benchmarks :skipped)) + (load-necessary-systems specs) + (dolist (db-type +all-db-types+) + (dolist (spec (db-type-spec db-type specs)) + (do-benchmarks-for-backend db-type spec count)))) + (values)) + +(defun do-benchmarks-for-backend (db-type spec count) + (test-setup-database db-type spec) + (write-report-banner "Benchmarks" db-type *report-stream* + (database-name-from-spec spec db-type)) + + (create-view-from-class 'bench) + (benchmark-init) + (benchmark-selects count) + (drop-view-from-class 'bench)) + +(defun benchmark-init () + (dotimes (i 10) + (execute-command "INSERT INTO BENCH (A,B,C) VALUES (123,'A Medium size string',3.14159)"))) + +(defun benchmark-selects (n) + (let ((*trace-output* *report-stream*)) + (format *report-stream* "~&~%*** QUERY ***~%") + (time + (dotimes (i n) + (query "SELECT * FROM BENCH"))) + (format *report-stream* "~&~%*** QUERY WITH RESULT-TYPES NIL ***~%") + (time + (dotimes (i n) + (query "SELECT * FROM BENCH" :result-types nil))) + (format *report-stream* "~&~%*** QUERY WITH FIELD-NAMES NIL ***~%") + (time + (dotimes (i n) + (query "SELECT * FROM BENCH" :field-names nil))) + + (with-dataset *ds-employees* + (format *report-stream* "~&~%*** JOINED OBJECT QUERY RETRIEVAL IMMEDIATE ***~%") + (time + (dotimes (i (truncate n 10)) + (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-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)) + (mapcar #'(lambda (ea) (slot-value ea 'address)) (select 'employee-address :flatp t)))) + (setf (gethash :retrieval dbi) :immediate))))) diff --git a/tests/datasets.lisp b/tests/datasets.lisp new file mode 100644 index 0000000..42698ec --- /dev/null +++ b/tests/datasets.lisp @@ -0,0 +1,141 @@ +;;;; Proposed new file in clsql-tests to enable abstracting datasets for reuse. +;;;; +;;;; The core is def-datset and with-dataset that respectively define a set, +;;;; and enable one for a dynamic scope. Datasets will normally be setup and +;;;; torn down in the scope of one test, which may impose a computation +;;;; overhead, but enables simpler tests by not worrying about side-effects +;;;; between tests. +;;;; +;;;; In general datasets should be database agnostic, but because the code +;;;; is only run in the scope of a test, if a test is excluded for a backend +;;;; or some other reason then it is never run hence doesn't cause problems. + +(in-package #:clsql-tests) + +(defparameter *dataset-debug-on-error* nil + "If we get an error while loading or cleaning up the dataset, +should we debug (T) or just print and quit.") + +(defun generic-error (e) + (when (and *dataset-debug-on-error* + *debugger-hook*) + (invoke-debugger e)) + (fresh-line *error-output*) + (princ e *error-output*) + (throw 'quit-dataset e)) + +(defmacro def-dataset (name &body body) + "Define a dataset" + ;;probably just shove this into a param, perhaps a marginal + ;; bit of processing first. + `(defparameter ,name ',body)) + +(defmacro with-dataset (name &body body) + "Use a dataset in a dynamic scope, e.g. a single test. +1. Before the body: + * :setup is run + * :data is loaded +2. Body +3. :cleanup always happens" + `(catch 'quit-dataset + (unwind-protect + (progn + (restart-case (%dataset-init ,name) + (retry-dataset-init () + :report ,(format nil "Retry dataset('~a) init: (with any dataset changes)" + (symbol-name name)) + (%dataset-init ,name)) + (skip-this-test () + :report "FAIL and run the next test" + (throw 'quit-dataset :data-set-failure))) + ,@body) + (%dataset-cleanup ,name)))) + + +(defun %dataset-dispatch (arg) + "For use with def-dataset and with-dataset, tries to DWIM." + (etypecase arg + (string (clsql-sys:execute-command arg)) ;treat it as a sql command. + ((or function symbol) (funcall arg)) ;run functions + (list + (case (first arg) + ((function lambda) (%dataset-dispatch (eval arg))) ;#' forms, lambdas + (progn (mapc #'%dataset-dispatch (rest arg))) ; (progn "asdf" "ff") + (ignore-errors (ignore-errors (mapc #'%dataset-dispatch (rest arg)))) + (t (mapc #'%dataset-dispatch arg))) ;otherwise implicit progn + ))) + +(defun %dataset-init (name) + "Run initialization code and fill database for given dataset." + ;;find items that looks like '(:setup ...), + ;; dispatch the rest. + (let ((*backend-warning-behavior* + (typecase *default-database* + (clsql-sys:generic-postgresql-database + :ignore) + (t *backend-warning-behavior*))) + (setup (rest (find :setup name :key #'first))) + (sqldata (rest (find :sqldata name :key #'first))) + (objdata (rest (find :objdata name :key #'first)))) + (when setup + (handler-bind ((warning + (lambda (c) + (when (eql :ignore *backend-warning-behavior*) + (muffle-warning c))))) + (%dataset-dispatch setup))) + (when sqldata + ;;run raw sql insert statements + (destructuring-bind (table-name columns &rest values-list) sqldata + (dolist (v values-list) + (clsql-sys:execute-command + (format nil + "INSERT INTO ~a (~a) VALUES (~a)" + table-name columns v))))) + (when objdata + ;;presumed to be view-class objects, force them to insert. + (dolist (o objdata) + (setf (slot-value o 'clsql-sys::view-database) nil) + (clsql-sys:update-records-from-instance o))))) + +(defun %dataset-cleanup (name) + "Run cleanup code associated with the given dataset." + (restart-case + (handler-bind ((error #'generic-error)) + (let ((cleanup (rest (find :cleanup name :key #'first)))) + (when cleanup + (%dataset-dispatch cleanup)))) + (retry-dataset-cleanup () + :report "Retry dataset cleanup (with any dataset changes)" + (%dataset-cleanup name)) + (skip-cleanup () nil))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Example Test Code + +;;incomplete example taken from test-init +;; (def-dataset *employees* +;; (:setup "CREATE TABLE employee +;; ( +;; emplid integer NOT NULL, +;; groupid integer NOT NULL, +;; first_name character varying(30), +;; last_name character varying(30), +;; email character varying(100), +;; ecompanyid integer, +;; managerid integer, +;; height double, +;; married boolean, +;; birthday timestamp without time zone, +;; bd_utime bigint, +;; CONSTRAINT employeepk PRIMARY KEY (emplid, groupid), +;; CONSTRAINT employee_emplid_key UNIQUE (emplid) +;; ) +;; ") +;; ;;alternatively setup can still be done as +;; ;;(:setup #'(lambda () (create-view-from-class ...))) +;; (:sqldata "employees" "emplid,groupid,married,height,first_name,last_name" +;; "1,1,false,1.5,'Napolean', 'Bonaparte'" +;; (format nil "1,1,true,~a,'Vladimir','Lenin'" (1+ (random 1.00)))) +;; (:cleanup "DROP TABLE EMPLOYEES")) + diff --git a/tests/ds-artists.lisp b/tests/ds-artists.lisp new file mode 100644 index 0000000..f4d3271 --- /dev/null +++ b/tests/ds-artists.lisp @@ -0,0 +1,31 @@ +(in-package #:clsql-tests) + +(clsql-sys:file-enable-sql-reader-syntax) + +(defparameter artist1 nil) + +(def-view-class artist () + ((artist_id :accessor artist_id :initarg :id + :type integer :db-kind :key :db-constraints (:not-null :auto-increment) + :autoincrement-sequence 'artist_artist_id_seq) + (name :accessor name :initarg :name :type (varchar 20)) + (genre :accessor genre :initarg :genre :type (varchar 10) :db-constraints (:default "'Unknown'")))) + +(defun initialize-ds-artists () + (mapc #'clsql:create-view-from-class + '(artist)) + + (setq *test-start-utime* (get-universal-time)) + (let* ((*db-auto-sync* nil)) + (setf artist1 (make-instance 'artist + :name "Mogwai")))) + +(def-dataset *ds-artists* + (:setup initialize-ds-artists) + (:cleanup (lambda () + (mapc #'clsql-sys:drop-view-from-class + '(artist)) + (ignore-errors + (mapc #'clsql-sys:drop-sequence + (list "artist_artist_id_seq")))))) + diff --git a/tests/ds-employees.lisp b/tests/ds-employees.lisp new file mode 100644 index 0000000..2611053 --- /dev/null +++ b/tests/ds-employees.lisp @@ -0,0 +1,405 @@ +(in-package #:clsql-tests) + +(clsql-sys:file-enable-sql-reader-syntax) +(defparameter company1 nil) +(defparameter employee1 nil) +(defparameter employee2 nil) +(defparameter employee3 nil) +(defparameter employee4 nil) +(defparameter employee5 nil) +(defparameter employee6 nil) +(defparameter employee7 nil) +(defparameter employee8 nil) +(defparameter employee9 nil) +(defparameter employee10 nil) +(defparameter address1 nil) +(defparameter address2 nil) +(defparameter address3 nil) +(defparameter employee-address1 nil) +(defparameter employee-address2 nil) +(defparameter employee-address3 nil) +(defparameter employee-address4 nil) +(defparameter employee-address5 nil) +(defparameter employee-address6 nil) + +(defclass thing () + ((extraterrestrial :initform nil :initarg :extraterrestrial))) + +(def-view-class person (thing) + ((height :db-kind :base :accessor height :type float + :initarg :height) + (married :db-kind :base :accessor married :type boolean + :initarg :married) + (birthday :type clsql:wall-time :initarg :birthday) + (bd-utime :type clsql:universal-time :initarg :bd-utime) + (hobby :db-kind :virtual :initarg :hobby :initform nil))) + +(def-view-class employee (person) + ((emplid + :db-kind :key + :db-constraints (:not-null :unique) + :type integer + :initarg :emplid) + (groupid + :db-kind :key + :db-constraints :not-null + :type integer + :initarg :groupid) + (title + :accessor title + :type symbol + :initarg :title) + (first-name + :accessor first-name + :type (varchar 30) + :initarg :first-name) + (last-name + :accessor last-name + :type (varchar 30) + :initarg :last-name) + (email + :accessor employee-email + :type (varchar 100) + :initarg :email) + (ecompanyid + :type integer + :initarg :companyid) + (company + :accessor employee-company + :db-kind :join + :db-info (:join-class company + :home-key ecompanyid + :foreign-key companyid + :set nil)) + (managerid + :type integer + :initarg :managerid) + (manager + :accessor employee-manager + :db-kind :join + :db-info (:join-class employee + :home-key managerid + :foreign-key emplid + :set nil)) + (addresses + :accessor employee-addresses + :db-kind :join + :db-info (:join-class employee-address + :home-key emplid + :foreign-key aemplid + :target-slot address + :set t))) + (:base-table employee)) + +(def-view-class company () + ((companyid + :db-kind :key + :db-constraints :not-null + :type integer + :initarg :companyid) + (groupid + :db-kind :key + :db-constraints :not-null + :type integer + :initarg :groupid) + (name + :type (varchar 100) + :initarg :name) + (presidentid + :type integer + :initarg :presidentid) + (president + :reader president + :db-kind :join + :db-info (:join-class employee + :home-key presidentid + :foreign-key emplid + :set nil)) + (employees + :reader company-employees + :db-kind :join + :db-info (:join-class employee + :home-key (companyid groupid) + :foreign-key (ecompanyid groupid) + :set t)))) + +(def-view-class address () + ((addressid + :db-kind :key + :db-constraints :not-null + :type integer + :initarg :addressid) + (street-number + :type integer + :initarg :street-number) + (street-name + :type (varchar 30) + :void-value "" + :initarg :street-name) + (city + :column "city_field" + :void-value "no city" + :type (varchar 30) + :initarg :city) + (postal-code + :column zip + :type integer + :void-value 0 + :initarg :postal-code)) + (:base-table addr)) + +;; many employees can reside at many addressess +(def-view-class employee-address () + ((aemplid :type integer :initarg :emplid) + (aaddressid :type integer :initarg :addressid) + (verified :type boolean :initarg :verified) + (address :db-kind :join + :db-info (:join-class address + :home-key aaddressid + :foreign-key addressid + :retrieval :immediate)) + (employee :db-kind :join + :db-info (:join-class employee + :home-key aemplid + :foreign-key emplid + :retrieval :immediate))) + (:base-table "ea_join")) + +(def-view-class deferred-employee-address () + ((aemplid :type integer :initarg :emplid) + (aaddressid :type integer :initarg :addressid) + (verified :type boolean :initarg :verified) + (address :db-kind :join + :db-info (:join-class address + :home-key aaddressid + :foreign-key addressid + :retrieval :deferred + :set nil))) + (:base-table "ea_join")) + + + +(defun initialize-ds-employees () + ;; (start-sql-recording :type :both) + (mapc #'clsql:create-view-from-class + '(employee company address employee-address)) + + (setq *test-start-utime* (get-universal-time)) + (let* ((*db-auto-sync* t) + (now-time (clsql:utime->time *test-start-utime*))) + (setf company1 (make-instance 'company + :presidentid 1 + :companyid 1 + :groupid 1 + :name "Widgets Inc.") + employee1 (make-instance 'employee + :emplid 1 + :groupid 1 + :married t + :title 'supplicant + :height (1+ (random 1.00)) + :bd-utime *test-start-utime* + :birthday now-time + :first-name "Vladimir" + :last-name "Lenin" + :email "lenin@soviet.org" + :companyid 1) + employee2 (make-instance 'employee + :emplid 2 + :groupid 1 + :title :adherent + :height (1+ (random 1.00)) + :married t + :bd-utime *test-start-utime* + :birthday now-time + :first-name "Josef" + :last-name "Stalin" + :email "stalin@soviet.org" + :managerid 1 + :companyid 1) + employee3 (make-instance 'employee + :emplid 3 + :groupid 1 + :title 'cl-user::novice + :height (1+ (random 1.00)) + :married t + :bd-utime *test-start-utime* + :birthday now-time + :first-name "Leon" + :last-name "Trotsky" + :email "trotsky@soviet.org" + :managerid 1 + :companyid 1) + employee4 (make-instance 'employee + :emplid 4 + :groupid 1 + :height (1+ (random 1.00)) + :married nil + :bd-utime *test-start-utime* + :birthday now-time + :first-name "Nikita" + :last-name "Kruschev" + :email "kruschev@soviet.org" + :managerid 1 + :companyid 1) + employee5 (make-instance 'employee + :emplid 5 + :groupid 1 + :married nil + :height (1+ (random 1.00)) + :bd-utime *test-start-utime* + :birthday now-time + :first-name "Leonid" + :last-name "Brezhnev" + :email "brezhnev@soviet.org" + :managerid 1 + :companyid 1) + employee6 (make-instance 'employee + :emplid 6 + :groupid 1 + :married nil + :height (1+ (random 1.00)) + :bd-utime *test-start-utime* + :birthday now-time + :first-name "Yuri" + :last-name "Andropov" + :email "andropov@soviet.org" + :managerid 1 + :companyid 1) + employee7 (make-instance 'employee + :emplid 7 + :groupid 1 + :height (1+ (random 1.00)) + :married nil + :bd-utime *test-start-utime* + :birthday now-time + :first-name "Konstantin" + :last-name "Chernenko" + :email "chernenko@soviet.org" + :managerid 1 + :companyid 1) + employee8 (make-instance 'employee + :emplid 8 + :groupid 1 + :height (1+ (random 1.00)) + :married nil + :bd-utime *test-start-utime* + :birthday now-time + :first-name "Mikhail" + :last-name "Gorbachev" + :email "gorbachev@soviet.org" + :managerid 1 + :companyid 1) + employee9 (make-instance 'employee + :emplid 9 + :groupid 1 + :married nil + :height (1+ (random 1.00)) + :bd-utime *test-start-utime* + :birthday now-time + :first-name "Boris" + :last-name "Yeltsin" + :email "yeltsin@soviet.org" + :managerid 1 + :companyid 1) + employee10 (make-instance 'employee + :emplid 10 + :groupid 1 + :married nil + :height (1+ (random 1.00)) + :bd-utime *test-start-utime* + :birthday now-time + :first-name "Vladimir" + :last-name "Putin" + :email "putin@soviet.org" + :managerid 1 + :companyid 1) + address1 (make-instance 'address + :addressid 1 + :street-number 10 + :street-name "Park Place" + :city "Leningrad" + :postal-code 123) + address2 (make-instance 'address + :addressid 2) + address3 (make-instance 'address + :addressid 3) + employee-address1 (make-instance 'employee-address + :emplid 1 + :addressid 1 + :verified t) + employee-address2 (make-instance 'employee-address + :emplid 2 + :addressid 2 + :verified t) + employee-address3 (make-instance 'employee-address + :emplid 3 + :addressid 1 + :verified nil) + employee-address4 (make-instance 'employee-address + :emplid 1 + :addressid 2 + :verified nil) + employee-address5 (make-instance 'employee-address + :emplid 3 + :addressid 2) + employee-address6 (make-instance 'employee-address + :emplid 4 + :addressid 3))) + + ;; sleep to ensure birthdays are no longer at current time + ;(sleep 1) ;want to find the test that depends on it, put the sleep there. + + #|| + ;; Lenin manages everyone ; + (clsql:add-to-relation employee2 'manager employee1) + (clsql:add-to-relation employee3 'manager employee1) + (clsql:add-to-relation employee4 'manager employee1) + (clsql:add-to-relation employee5 'manager employee1) + (clsql:add-to-relation employee6 'manager employee1) + (clsql:add-to-relation employee7 'manager employee1) + (clsql:add-to-relation employee8 'manager employee1) + (clsql:add-to-relation employee9 'manager employee1) + (clsql:add-to-relation employee10 'manager employee1) + ;; Everyone works for Widgets Inc. ; + (clsql:add-to-relation company1 'employees employee1) + (clsql:add-to-relation company1 'employees employee2) + (clsql:add-to-relation company1 'employees employee3) + (clsql:add-to-relation company1 'employees employee4) + (clsql:add-to-relation company1 'employees employee5) + (clsql:add-to-relation company1 'employees employee6) + (clsql:add-to-relation company1 'employees employee7) + (clsql:add-to-relation company1 'employees employee8) + (clsql:add-to-relation company1 'employees employee9) + (clsql:add-to-relation company1 'employees employee10) + ;; Lenin is president of Widgets Inc. ; + (clsql:add-to-relation company1 'president employee1) + ||# + + ;; store these instances + #|| + (clsql:update-records-from-instance employee1) + (clsql:update-records-from-instance employee2) + (clsql:update-records-from-instance employee3) + (clsql:update-records-from-instance employee4) + (clsql:update-records-from-instance employee5) + (clsql:update-records-from-instance employee6) + (clsql:update-records-from-instance employee7) + (clsql:update-records-from-instance employee8) + (clsql:update-records-from-instance employee9) + (clsql:update-records-from-instance employee10) + (clsql:update-records-from-instance company1) + (clsql:update-records-from-instance address1) + (clsql:update-records-from-instance address2) + ||# + ) + + + (def-dataset *ds-employees* + (:setup initialize-ds-employees) + (:cleanup (lambda () + (mapc #'clsql-sys:drop-view-from-class + '(employee company address employee-address)) + (ignore-errors + (clsql-sys:execute-command "DROP TABLE ea_join"))))) + diff --git a/tests/ds-nodes.lisp b/tests/ds-nodes.lisp new file mode 100644 index 0000000..098c742 --- /dev/null +++ b/tests/ds-nodes.lisp @@ -0,0 +1,118 @@ +(in-package #:clsql-tests) + +(clsql-sys:file-enable-sql-reader-syntax) + +(defparameter basenode nil) +(defparameter derivednode1 nil) +(defparameter derivednode2 nil) +(defparameter node nil) +(defparameter setting1 nil) +(defparameter setting2 nil) +(defparameter user1 nil) +(defparameter user2 nil) +(defparameter theme1 nil) +(defparameter theme2 nil) +(defparameter loc1 nil) +(defparameter loc2 nil) +(defparameter subloc1 nil) +(defparameter subloc2 nil) + + +;; classes for testing the normalizedp stuff +(def-view-class node () + ((node-id :accessor node-id :initarg :node-id + :type integer :db-kind :key + :db-constraints (:not-null :auto-increment)) + (title :accessor title :initarg :title :type (varchar 240)) + (createtime :accessor createtime :initarg :createtime :type wall-time + :db-constraints (:not-null) :initform (get-time)) + (modifiedtime :accessor modifiedtime :initarg :modifiedtime :type wall-time + :initform (make-time :year 1900 :month 1 :day 1)))) + +(def-view-class setting (node) + ((setting-id :accessor setting-id :initarg :setting-id + :type integer :db-kind :key :db-constraints (:not-null )) + (vars :accessor vars :initarg :vars :type (varchar 240))) + (:normalizedp t)) + +(def-view-class user (node) + ((user-id :accessor user-id :initarg :user-id + :type integer :db-kind :key :db-constraints (:not-null )) + (nick :accessor nick :initarg :nick :type (varchar 64))) + (:base-table "nodeuser") + (:normalizedp t)) + +(def-view-class theme (setting) + ((theme-id :accessor theme-id :initarg :theme-id + :type integer :db-kind :key :db-constraints (:not-null )) + (doc :accessor doc :initarg :doc :type (varchar 240))) + (:normalizedp t)) + +;; A class that uses only a superclass db table +(def-view-class location (node) + () + (:base-table node) + (:normalizedp t)) + +(def-view-class subloc (location) + ((subloc-id :accessor subloc-id :initarg :subloc-id + :type integer :db-kind :key :db-constraints (:not-null )) + (loc :accessor loc :initarg :loc :type (varchar 64))) + (:normalizedp t)) + + + +(defun initialize-ds-nodes () + ;; (start-sql-recording :type :both) + (mapc #'clsql:create-view-from-class + '(node setting user theme location subloc)) + + (setq *test-start-utime* (get-universal-time)) + (let* ((*db-auto-sync* t)) + (setf node (make-instance 'node + :title "Bare node") + setting1 (make-instance 'setting + :title "Setting1" + :vars "var 1") + setting2 (make-instance 'setting + :title "Setting2" + :vars "var 2") + user1 (make-instance 'user + :title "user-1" + :nick "first user") + user2 (make-instance 'user + :title "user-2" + :nick "second user") + theme1 (make-instance 'theme + :title "theme-1" + :vars "empty" + :doc "first theme") + theme2 (make-instance 'theme + :title "theme-2" + :doc "second theme") + loc1 (make-instance 'location + :title "location-1") + loc2 (make-instance 'location + :title "location-2") + subloc1 (make-instance 'subloc + :title "subloc-1" + :loc "a subloc") + subloc2 (make-instance 'subloc + :title "subloc-2" + :loc "second subloc")))) + + + + + (def-dataset *ds-nodes* + (:setup initialize-ds-nodes) + (:cleanup (lambda () + (mapc #'clsql-sys:drop-view-from-class + '(node setting user theme location subloc)) + (ignore-errors + (clsql-sys:execute-command "DROP TABLE nodeuser") + (mapc #'clsql-sys:drop-sequence + '(node_node_id_seq setting_setting_id_seq subloc_subloc_id_seq + theme_theme_id_seq nodeuser_user_id_seq) + ))))) + diff --git a/tests/package.lisp b/tests/package.lisp new file mode 100644 index 0000000..f420b10 --- /dev/null +++ b/tests/package.lisp @@ -0,0 +1,33 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: package.lisp +;;;; Purpose: Package definition for CLSQL test suite +;;;; Authors: Marcus Pearce and Kevin M. Rosenberg +;;;; Created: March 2004 +;;;; +;;;; 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 #:cl-user) + +(defpackage #:clsql-tests + (:use #:clsql #:common-lisp #:rtest) + (:shadowing-import-from #:clsql-sys #:%get-int ) + (:export + #:run-tests + #:run-tests-append-report-file + #:run-benchmarks + #:run-benchmarks-append-report-file + #:summarize-test-report + #:test-connect + #:test-setup-database + ) + (:documentation "Regression tests for CLSQL.")) + diff --git a/tests/test-basic.lisp b/tests/test-basic.lisp new file mode 100644 index 0000000..4d277e3 --- /dev/null +++ b/tests/test-basic.lisp @@ -0,0 +1,314 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: test-basic.lisp +;;;; Purpose: Tests for clsql string-based queries and result types +;;;; Author: Kevin M. Rosenberg +;;;; Created: Mar 2002 +;;;; +;;;; This file, part of CLSQL, is Copyright (c) 2002-2010 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-tests) + + +(setq *rt-basic* + '( + (deftest :basic/type/1 + (with-dataset *ds-basic* + (let ((results '())) + (dolist (row (query "select * from TYPE_TABLE" :result-types :auto) + results) + (destructuring-bind (int float str) row + (push (list (integerp int) + (typep float 'double-float) + (stringp str)) + results))))) + ((t t t) (t t t) (t t t) (t t t) (t t t) (t t t) (t t t) (t t t) (t t t) (t t t) (t t t))) + + (deftest :basic/type/2 + (with-dataset *ds-basic* + (let ((results '())) + (dolist (row (query "select * from TYPE_TABLE" :result-types :auto) + results) + (destructuring-bind (int float str) row + (setq results + (cons (list (double-float-equal + (transform-float-1 int) + float) + (double-float-equal + (parse-double str) + float)) + results)))) + results)) + ((t t) (t t) (t t) (t t) (t t) (t t) (t t) (t t) (t t) (t t) (t t))) + + (deftest :basic/select/1 + (with-dataset *ds-basic* + (let ((rows (query "select * from TYPE_TABLE" :result-types :auto))) + (values + (length rows) + (length (car rows))))) + 11 3) + + (deftest :BASIC/SELECT/2 + (with-dataset *ds-basic* + (let ((results '())) + (dolist (row (query "select * from TYPE_TABLE" :result-types nil) + results) + (destructuring-bind (int float str) row + (push (list (stringp int) + (stringp float) + (stringp str)) + results))))) + ((t t t) (t t t) (t t t) (t t t) (t t t) (t t t) (t t t) (t t t) (t t t) (t t t) (t t t))) + + (deftest :basic/select/3 + (with-dataset *ds-basic* + (let ((results '())) + (dolist (row (query "select * from TYPE_TABLE" :result-types nil) + results) + (destructuring-bind (int float str) row + (push (list (double-float-equal + (transform-float-1 (parse-integer int)) + (parse-double float)) + (double-float-equal + (parse-double str) + (parse-double float))) + results))))) + ((t t) (t t) (t t) (t t) (t t) (t t) (t t) (t t) (t t) (t t) (t t))) + + (deftest :basic/map/1 + (with-dataset *ds-basic* + (let ((results '()) + (rows (map-query 'vector #'identity "select * from TYPE_TABLE" + :result-types nil))) + (declare (type (simple-array list (*)) rows)) + (dotimes (i (length rows) results) + (push + (list + (listp (aref rows i)) + (length (aref rows i)) + (eql (- i 5) + (parse-integer (first (aref rows i)) + :junk-allowed nil)) + (double-float-equal + (transform-float-1 (parse-integer (first (aref rows i)))) + (parse-double (second (aref rows i))))) + results)))) + ((t 3 t t) (t 3 t t) (t 3 t t) (t 3 t t) (t 3 t t) (t 3 t t) (t 3 t t) (t 3 t t) (t 3 t t) (t 3 t t) (t 3 t t))) + + + (deftest :basic/map/2 + (with-dataset *ds-basic* + (let ((results '()) + (rows (map-query 'list #'identity "select * from TYPE_TABLE" + :result-types nil))) + (dotimes (i (length rows) results) + (push + (list + (listp (nth i rows)) + (length (nth i rows)) + (eql (- i 5) + (parse-integer (first (nth i rows)) + :junk-allowed nil)) + (double-float-equal + (transform-float-1 (parse-integer (first (nth i rows)))) + (parse-double (second (nth i rows))))) + results)))) + ((t 3 t t) (t 3 t t) (t 3 t t) (t 3 t t) (t 3 t t) (t 3 t t) (t 3 t t) (t 3 t t) (t 3 t t) (t 3 t t) (t 3 t t))) + + (deftest :basic/map/3 + (with-dataset *ds-basic* + (let ((results '()) + (rows (map-query 'list #'identity "select * from TYPE_TABLE" + :result-types :auto))) + (dotimes (i (length rows) results) + (push + (list + (listp (nth i rows)) + (length (nth i rows)) + (eql (- i 5) + (first (nth i rows))) + (double-float-equal + (transform-float-1 (first (nth i rows))) + (second (nth i rows)))) + results)))) + ((t 3 t t) (t 3 t t) (t 3 t t) (t 3 t t) (t 3 t t) (t 3 t t) (t 3 t t) (t 3 t t) (t 3 t t) (t 3 t t) (t 3 t t))) + + ;; confirm that a query on a single element returns a list of one element + (deftest :basic/map/4 + (with-dataset *ds-basic* + (let ((rows (map-query 'list #'identity "select t_int from TYPE_TABLE" + :result-types nil))) + (values + (consp (first rows)) + (length (first rows))))) + t 1) + + (deftest :basic/do/1 + (with-dataset *ds-basic* + (let ((results '())) + (do-query ((int float str) "select * from TYPE_TABLE" :result-types nil) + (let ((int-number (parse-integer int))) + (setq results + (cons (list (double-float-equal (transform-float-1 + int-number) + (parse-double float)) + (double-float-equal (parse-double str) + (parse-double float))) + results)))) + results)) + ((t t) (t t) (t t) (t t) (t t) (t t) (t t) (t t) (t t) (t t) (t t))) + + (deftest :basic/do/2 + (with-dataset *ds-basic* + (let ((results '())) + (do-query ((int float str) "select * from TYPE_TABLE" :result-types :auto) + (setq results + (cons + (list (double-float-equal + (transform-float-1 int) + float) + (double-float-equal + (parse-double str) + float)) + results))) + results)) + ((t t) (t t) (t t) (t t) (t t) (t t) (t t) (t t) (t t) (t t) (t t))) + + + (deftest :basic/bigint/1 + (with-dataset *ds-bigint* + (let ((results '())) + (dolist (row (query "select * from TYPE_BIGINT" :result-types :auto) + results) + (destructuring-bind (int bigint) row + (push (list (integerp int) + (integerp bigint)) + results))))) + ((t t) (t t) (t t) (t t) (t t) (t t) (t t) (t t) (t t) (t t) (t t))) + + + (deftest :basic/bigtext/1 + (with-dataset *ds-bigtext* + (let* ((len 7499) + (str (make-string len :initial-element #\a)) + (cmd (format nil "INSERT INTO testbigtext (a) VALUES ('~a')" str))) + (execute-command cmd) + (let ((a (first (query "SELECT a from testbigtext" + :flatp t :field-names nil)))) + (assert (string= str a) (str a) + "mismatch on a. inserted: ~a returned: ~a" len (length a))) + )) + nil) + (deftest :basic/bigtext/2 + (flet ((random-char () + (let ((alphabet "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ") + (idx (random 52))) + (elt alphabet idx)))) + (dotimes (n 10) + (with-dataset *ds-bigtext* + (let* ((len (random 7500)) + (str (coerce (make-array len + :initial-contents (loop repeat len collect (random-char))) + 'string)) + (cmd (format nil "INSERT INTO testbigtext (a) VALUES ('~a')" str))) + (execute-command cmd) + (let ((a (first (query "SELECT a from testbigtext" + :flatp t :field-names nil)))) + (assert (string= str a) (str a) + "mismatch on randomized bigtext(~a) inserted: ~s returned: ~s" len str a)) + )))) + nil) + + (deftest :basic/reallybigintegers/1 + (with-dataset *ds-reallybigintegers* + (let* ((a (1- (expt 2 64))) + (b (- (expt 2 64) 2)) + (c (expt 2 63)) + (d (expt 2 62)) + (sql (format nil "INSERT INTO testreallybigintegers + VALUES (~A, ~A, ~A, ~A)" + a b c d))) + (query sql) + (let ((results + (query + (format nil "SELECT * FROM testreallybigintegers")))) + (equal `(,a ,b ,c ,d) (car results))))) + t) + )) + + +(def-dataset *ds-basic* + (:setup (lambda () + (ignore-errors + (clsql:execute-command "DROP TABLE TYPE_TABLE") + (clsql:execute-command "DROP TABLE TYPE_BIGINT")) + + (clsql:execute-command + "CREATE TABLE TYPE_TABLE (t_int integer, t_float double precision, t_str VARCHAR(30))") + + (dotimes (i 11) + (let* ((test-int (- i 5)) + (test-flt (transform-float-1 test-int))) + (clsql:execute-command + (format nil "INSERT INTO TYPE_TABLE VALUES (~a,~a,'~a')" + test-int + (clsql-sys:number-to-sql-string test-flt) + (clsql-sys:number-to-sql-string test-flt) + )))))) + (:cleanup "DROP TABLE TYPE_TABLE")) + +(def-dataset *ds-bigint* + (:setup (lambda () + (ignore-errors (clsql:execute-command "DROP TABLE TYPE_BIGINT")) + (clsql:execute-command "CREATE TABLE TYPE_BIGINT (T_INT integer, T_BIGINT BIGINT)") + (dotimes (i 11) + (clsql:execute-command + (format nil "INSERT INTO TYPE_BIGINT VALUES (~a,~a)" + (- i 5) + (transform-bigint-1 (- i 5))))))) + (:cleanup "DROP TABLE TYPE_BIGINT")) + +;;;; Testing functions + +(defun transform-float-1 (i) + (coerce (* i (abs (/ i 2)) (expt 10 (* 2 i))) 'double-float)) + +(defun transform-bigint-1 (i) + (* i (expt 10 (* 3 (abs i))))) + +(defun parse-double (num-str) + (let ((*read-default-float-format* 'double-float)) + (coerce (read-from-string num-str) 'double-float))) + +(defun double-float-equal (a b) + (if (zerop a) + (if (zerop b) + t + nil) + (let ((diff (abs (/ (- a b) a)))) + (if (> diff (* 10 double-float-epsilon)) + nil + t)))) + +(def-dataset *ds-bigtext* + (:setup "CREATE TABLE testbigtext(a varchar(7500))") + (:cleanup "DROP TABLE testbigtext")) + +(def-dataset *ds-reallybigintegers* + (:setup (lambda () + (ignore-errors + (clsql:execute-command "DROP TABLE testreallybigintegers")) + (clsql:execute-command + "CREATE TABLE testreallybigintegers( a BIGINT UNSIGNED, + b BIGINT UNSIGNED, + c BIGINT UNSIGNED, + d BIGINT UNSIGNED )"))) + (:cleanup "DROP TABLE testreallybigintegers")) diff --git a/tests/test-connection.lisp b/tests/test-connection.lisp new file mode 100644 index 0000000..3e742e7 --- /dev/null +++ b/tests/test-connection.lisp @@ -0,0 +1,80 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: test-connection.lisp +;;;; Purpose: Tests for CLSQL database connections +;;;; Authors: Marcus Pearce and Kevin M. Rosenberg +;;;; Created: March 2004 +;;;; +;;;; 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-tests) + +(setq *rt-connection* + '( + +(deftest :connection/1 + (let ((database (clsql:find-database + (clsql:database-name clsql:*default-database*) + :db-type (clsql-sys:database-type clsql:*default-database*)))) + (eql (clsql-sys:database-type database) *test-database-type*)) + t) + +(deftest :connection/2 + (clsql-sys::string-to-list-connection-spec + "localhost/dbname/user/passwd") + ("localhost" "dbname" "user" "passwd")) + +(deftest :connection/3 + (clsql-sys::string-to-list-connection-spec + "dbname/user@hostname") + ("hostname" "dbname" "user")) + +(deftest :connection/execute-command + ;;check that we can issue basic commands. + (values + (clsql-sys:execute-command "CREATE TABLE DUMMY (foo integer)") + (clsql-sys:execute-command "DROP TABLE DUMMY")) + nil nil) + +(deftest :connection/query + ;;check that we can do a basic query + (first (clsql:query "SELECT 1" :flatp t :field-names nil)) + 1) + +(deftest :connection/query-command + ;;queries that are commands (no result set) shouldn't cause breakage + (values + (clsql-sys:query "CREATE TABLE DUMMY (foo integer)") + (clsql-sys:query "DROP TABLE DUMMY")) + nil nil) + +(deftest :connection/pool/procedure-mysql + (unwind-protect + (progn + (clsql-sys:disconnect) + (test-connect :pool t) + (clsql-sys:execute-command + "CREATE PROCEDURE prTest () BEGIN SELECT 1 \"a\",2 \"b\",3 \"c\" ,4 \"d\" UNION SELECT 5,6,7,8; END;") + (clsql-sys:disconnect) + (test-connect :pool t) + (let ((p0 (clsql-sys:query "CALL prTest();" :flatp t))) + (clsql-sys:disconnect) + (test-connect :pool t) + (let ((p1 (clsql-sys:query "CALL prTest();" :flatp t))) + (clsql-sys:disconnect) + (test-connect :pool t) + (values p0 p1)))) + (ignore-errors + (clsql-sys:execute-command "DROP PROCEDURE prTest;")) + (test-connect)) + ((1 2 3 4) (5 6 7 8)) + ((1 2 3 4) (5 6 7 8))) + +)) diff --git a/tests/test-fddl.lisp b/tests/test-fddl.lisp new file mode 100644 index 0000000..41e79d5 --- /dev/null +++ b/tests/test-fddl.lisp @@ -0,0 +1,454 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: test-fddl.lisp +;;;; Purpose: Tests for the CLSQL Functional Data Definition Language +;;;; Authors: Marcus Pearce and Kevin M. Rosenberg +;;;; Created: March 2004 +;;;; +;;;; 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-tests) +(clsql-sys:file-enable-sql-reader-syntax) + +(def-dataset *ds-fddl* + (:setup (lambda () + (create-table [alpha] '(([a] integer) + ([c] (varchar 30)) + ([d] date) + ([f] float))) + (create-table [bravo] '(([foo] integer) + ([bar] integer))))) + (:sqldata "ALPHA" "A,C,D,F" + "1,'asdf','2010-01-01',3.14" + "2,'blarg','2012-12-21',0.1" + "3,'matey','1992-02-29',0.0") + (:cleanup "DROP TABLE ALPHA" "DROP TABLE BRAVO")) + +(def-dataset *ds-fddl-parsing-oddities* + (:setup "CREATE TABLE ATEST ( +A varchar (32), +B varchar(32))") + (:cleanup "DROP TABLE ATEST")) + +(setq *rt-fddl* + '( + +;; list current tables +(deftest :fddl/table/1 + (with-dataset *ds-fddl* + (let ((tables (sort (mapcar #'string-downcase (clsql:list-tables)) + #'string<))) + ;; sqlite has a table for autoincrement sequences that we dont care about if + ;; it exists + (remove "sqlite_sequence" tables :test #'string-equal))) + ("alpha" "bravo")) + +;; create a table, test for its existence, drop it and test again +(deftest :fddl/table/2 + (progn (clsql:create-table [foo] + '(([id] integer) + ([height] float) + ([name] (string 24)) + ([comments] longchar))) + (values + (clsql:table-exists-p [foo]) + (progn + (clsql:drop-table [foo] :if-does-not-exist :ignore) + (clsql:table-exists-p [foo])))) + t nil) + +;; create a table, list its attributes and drop it +(deftest :fddl/table/3 + (apply #'values + (progn (clsql:create-table [foo] + '(([id] integer) + ([height] float) + ([name] (char 255)) + ([comments] longchar))) + (prog1 + (sort (mapcar #'string-downcase + (clsql:list-attributes [foo])) + #'string<) + (clsql:drop-table [foo] :if-does-not-exist :ignore)))) + "comments" "height" "id" "name") + +(deftest :fddl/table/4 + (values + (clsql:table-exists-p "MyMixedCase") + (progn + (clsql:create-table "MyMixedCase" '(([a] integer))) + (clsql:table-exists-p "MyMixedCase")) + (progn + (clsql:drop-table "MyMixedCase") + (clsql:table-exists-p "MyMixedCase"))) + nil t nil) + +(deftest :fddl/table/5 + (prog1 + (progn + (clsql:create-table "MyMixedCase" '(([a] integer))) + (clsql:execute-command "insert into \"MyMixedCase\" values (5)") + (clsql:insert-records :into "MyMixedCase" :values '(6)) + (clsql:select [a] :from "MyMixedCase" :order-by '((a :asc)))) + (clsql:drop-table "MyMixedCase")) + ((5) (6))) + +(deftest :fddl/table/6 + (values + (clsql:table-exists-p [foo]) + (progn + (let ((*backend-warning-behavior* + (if (member *test-database-type* + '(:postgresql :postgresql-socket :postgresql-socket3)) + :ignore + :warn))) + (case *test-database-underlying-type* + (:mssql (clsql:create-table [foo] + '(([bar] integer :not-null :primary-key) + ([baz] string :not-null :unique)))) + (t (clsql:create-table [foo] + '(([bar] integer :not-null :unique :primary-key) + ([baz] string :not-null :unique)))))) + (clsql:table-exists-p [foo])) + (progn + (clsql:drop-table [foo]) + (clsql:table-exists-p [foo]))) + nil t nil) + +(deftest :fddl/table/7 + (values + (clsql:table-exists-p [foo]) + (progn + (let ((*backend-warning-behavior* + (if (member *test-database-type* + '(:postgresql :postgresql-socket :postgresql-socket3)) + :ignore + :warn))) + (clsql:create-table [foo] '(([bar] integer :not-null) + ([baz] string :not-null)) + :constraints '("UNIQUE (bar,baz)" + "PRIMARY KEY (bar)"))) + (clsql:table-exists-p [foo])) + (progn + (clsql:drop-table [foo]) + (clsql:table-exists-p [foo]))) + nil t nil) + +(deftest :fddl/attributes/1 + (apply #'values + (with-dataset *ds-fddl* + (sort + (mapcar #'string-downcase + (clsql:list-attributes [alpha] )) + #'string<))) + "a" "c" "d" "f") + +(deftest :fddl/attributes/2 + (with-dataset *ds-fddl* + (apply #'values + (sort + (mapcar #'(lambda (a) (string-downcase (car a))) + (clsql:list-attribute-types [alpha])) + #'string<))) + "a" "c" "d" "f") + +;; Attribute types are vendor specific so need to test a range +(deftest :fddl/attributes/3 + (with-dataset *ds-fddl* + (and (member (clsql:attribute-type [a] [alpha]) '(:int :integer :int4 :number)) t)) + t) + +(deftest :fddl/attributes/4 + (with-dataset *ds-fddl* + (multiple-value-bind (type length scale nullable) + (clsql:attribute-type [c] [alpha]) + (values (clsql-sys:in type :varchar :varchar2 :nvarchar) + length scale nullable))) + t 30 nil 1) + +(deftest :fddl/attributes/5 + (with-dataset *ds-fddl* + (and (member (clsql:attribute-type [d] [alpha]) + '(:datetime :timestamp :date :smalldatetime)) t)) + t) + +(deftest :fddl/attributes/6 + (with-dataset *ds-fddl* + (and (member (clsql:attribute-type [f] [alpha]) '(:float :float8 :number)) t)) + t) + +(deftest :fddl/attributes/7 + (with-dataset *ds-bigint* + (and (member (clsql:attribute-type [t_bigint] [TYPE_BIGINT]) '(:bigint :int8)) t)) + t) + +(deftest :fddl/attributes/8 + ;;this is mostly from sqlite3 sending back + (with-dataset *ds-fddl-parsing-oddities* + (values + (clsql-sys:in (clsql:attribute-type [a] [atest]) :varchar :varchar2) + (clsql-sys:in (clsql:attribute-type [b] [atest]) :varchar :varchar2))) + t t) + + +;; create a view, test for existence, drop it and test again +(deftest :fddl/view/1 + (with-dataset *ds-fddl* + (progn (clsql:create-view [v1] + :as [select [a] [c] [d] + :from [alpha] + :where [= [a] 1]]) + (values + (clsql:view-exists-p [v1]) + (progn + (clsql:drop-view [v1] :if-does-not-exist :ignore) + (clsql:view-exists-p [v1]))))) + t nil) + + ;; create a view, list its attributes and drop it +(deftest :fddl/view/2 + (with-dataset *ds-fddl* + (progn (clsql:create-view [v1] + :as [select [a] [c] [d] + :from [alpha] + :where [= [a] 1]]) + (unwind-protect + (sort (mapcar #'string-downcase + (clsql:list-attributes [v1])) + #'string<) + (clsql:drop-view [v1] :if-does-not-exist :ignore)))) + ("a" "c" "d")) + + ;; create a view, select stuff from it and drop it +(deftest :fddl/view/3 + (with-dataset *ds-fddl* + (progn + (clsql:create-view [v1] + :as [select [a] [c] [d] + :from [alpha] + :where [= [a] 1]]) + (unwind-protect + (let ((result + (list + ;; Shouldn't exist + (clsql:select [a] [c] + :from [v1] + :where [= [a] -1]) + ;; Should exist + (car (clsql:select [a] [c] + :from [v1] + :where [= [a] 1]))))) + + (apply #'values result)) + (clsql:drop-view [v1] :if-does-not-exist :ignore)))) + nil (1 "asdf")) + +(deftest :fddl/view/4 + (with-dataset *ds-fddl* + (progn + (clsql:create-view [v1] + :column-list '([x] [y] [z]) + :as [select [a] [c] [d] + :from [alpha] + :where [= [a] 1]]) + (unwind-protect + (let ((result + (list + (sort (mapcar #'string-downcase + (clsql:list-attributes [v1])) + #'string<) + ;; Shouldn't exist + (clsql:select [x] [y] + :from [v1] + :where [= [x] -1]) + ;; Should exist + (car (clsql:select [x] [y] + :from [v1] + :where [= [x] 1]))))) + + (apply #'values result)) + (clsql:drop-view [v1] :if-does-not-exist :ignore)))) + ("x" "y" "z") nil (1 "asdf")) + +;; create an index, test for existence, drop it and test again +(deftest :fddl/index/1 + (with-dataset *ds-fddl* + (progn (clsql:create-index [bar] :on [alpha] :attributes + '([a] [c]) :unique t) + (values + (clsql:index-exists-p [bar] ) + (progn + (clsql:drop-index [bar] :on [alpha] + :if-does-not-exist :ignore) + (clsql:index-exists-p [bar]))))) + t nil) + +;; create indexes with names as strings, symbols and in square brackets +(deftest :fddl/index/2 + (with-dataset *ds-fddl* + (let ((names '("foo" foo [foo])) + (result '())) + (dolist (name names) + (clsql:create-index name :on [alpha] :attributes '([a])) + (push (clsql:index-exists-p name ) result) + (clsql:drop-index name :on [alpha] :if-does-not-exist :ignore)) + (apply #'values result))) + t t t) + +;; test list-indexes with keyword :ON +(deftest :fddl/index/3 + (progn + (clsql:create-table [i3test] '(([a] (string 10)) + ([b] integer))) + (clsql:create-index [foo] :on [i3test] :attributes + '([b]) :unique nil) + (clsql:create-index [bar] :on [i3test] :attributes + '([a]) :unique t) + (values + (clsql:table-exists-p [i3test]) + (clsql:index-exists-p [foo]) + (clsql:index-exists-p [bar]) + (sort + (mapcar + #'string-downcase + (clsql:list-indexes :on [i3test])) + #'string-lessp) + (progn + (clsql:drop-index [bar] :on [i3test]) + (clsql:drop-index [foo] :on [i3test]) + (clsql:drop-table [i3test]) + t))) + t t t ("bar" "foo") t) + +;; create an sequence, test for existence, drop it and test again +(deftest :fddl/sequence/1 + (progn (clsql:create-sequence [foo]) + (values + (clsql:sequence-exists-p [foo]) + (progn + (clsql:drop-sequence [foo] :if-does-not-exist :ignore) + (clsql:sequence-exists-p [foo])))) + t nil) + +;; create and increment a sequence +(deftest :fddl/sequence/2 + (let ((val1 nil)) + (clsql:create-sequence [foo]) + (setf val1 (clsql:sequence-next [foo])) + (prog1 + (< val1 (clsql:sequence-next [foo])) + (clsql:drop-sequence [foo] :if-does-not-exist :ignore))) + t) + +;; explicitly set the value of a sequence +(deftest :fddl/sequence/3 + (progn + (clsql:create-sequence [foo]) + (clsql:set-sequence-position [foo] 5) + (prog1 + (clsql:sequence-next [foo]) + (clsql:drop-sequence [foo] :if-does-not-exist :ignore))) + 6) + + + +(deftest :fddl/owner/1 + (with-dataset *ds-fddl* + (and + ;; user tables are an improper subset of all tables + (= (length (intersection (clsql:list-tables :owner nil) + (clsql:list-tables :owner :all) + :test #'string=)) + (length (clsql:list-tables :owner nil))) + ;; user tables are a proper subset of all tables + (> (length (clsql:list-tables :owner :all)) + (length (clsql:list-tables :owner nil))))) + t) + +(deftest :fddl/owner/table + (with-dataset *ds-fddl* + (values + (clsql-sys:table-exists-p [alpha]) + (clsql-sys:table-exists-p [alpha] :owner *test-database-user*) + (clsql-sys:table-exists-p [alpha] :owner *test-false-database-user*))) + t t nil) + +(deftest :fddl/owner/attributes + (with-dataset *ds-fddl* + (values + (length (clsql-sys:list-attributes [alpha])) + (length (clsql-sys:list-attributes [alpha] :owner *test-database-user*)) + (length (clsql-sys:list-attributes [alpha] :owner *test-false-database-user*)))) + 4 4 0) + +(deftest :fddl/owner/attribute-types + (with-dataset *ds-fddl* + (values + (length (clsql:list-attribute-types [alpha])) + (length (clsql:list-attribute-types [alpha] :owner *test-database-user*)) + (length (clsql:list-attribute-types [alpha] :owner *test-false-database-user*)))) + 4 4 0) + +(deftest :fddl/owner/index + (with-dataset *ds-fddl* + (progn (clsql:create-index [bar] :on [alpha] + :attributes '([a] [c])) + (values + (clsql:index-exists-p [bar] ) + (clsql:index-exists-p [bar] :owner *test-database-user*) + (clsql:index-exists-p [bar] :owner *test-false-database-user*) + + (length (clsql-sys:list-indexes :on [alpha])) + (length (clsql-sys:list-indexes :on [alpha] :owner *test-database-user*)) + (length (clsql-sys:list-indexes :on [alpha] :owner *test-false-database-user*)) + (progn + (clsql:drop-index [bar] :on [alpha] + :if-does-not-exist :ignore) + (clsql:index-exists-p [bar] :owner *test-database-user*)) + (clsql:index-exists-p [bar] )))) + t t nil + 1 1 0 + nil nil) + +(deftest :fddl/owner/sequence + (progn (clsql:create-sequence [foo]) + (values + (clsql:sequence-exists-p [foo]) + (clsql:sequence-exists-p [foo] :owner *test-database-user*) + (clsql:sequence-exists-p [foo] :owner *test-false-database-user*) + + (progn + (clsql:drop-sequence [foo] :if-does-not-exist :ignore) + (clsql:sequence-exists-p [foo] )))) + t t nil nil) + + + +(deftest :fddl/cache-table-queries/1 + (with-dataset *ds-fddl* + (list + (gethash "ALPHA" (clsql-sys::attribute-cache clsql:*default-database*)) + (progn + (clsql:cache-table-queries "ALPHA" :action t) + (gethash "ALPHA" (clsql-sys::attribute-cache clsql:*default-database*))) + (progn + (clsql:list-attribute-types "ALPHA") + (not + (null + (cadr + (gethash "ALPHA" + (clsql-sys::attribute-cache clsql:*default-database*)))))) + (progn + (clsql:cache-table-queries "ALPHA" :action :flush) + (gethash "ALPHA" (clsql-sys::attribute-cache clsql:*default-database*))))) + (nil (t nil) t (t nil))) + + )) diff --git a/tests/test-fdml.lisp b/tests/test-fdml.lisp new file mode 100644 index 0000000..51cdd02 --- /dev/null +++ b/tests/test-fdml.lisp @@ -0,0 +1,780 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ====================================================================== +;;;; File: test-fdml.lisp +;;;; Author: Marcus Pearce <m.t.pearce@city.ac.uk>, Kevin Rosenberg +;;;; Created: 30/03/2004 +;;;; +;;;; Tests for the CLSQL Functional Data Manipulation Language +;;;; (FDML). +;;;; +;;;; 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-tests) + +(clsql-sys:file-enable-sql-reader-syntax) +;;started defining an independent dataset that doesn't depend on the view-classes +;; but there is a *lot* of stuff in the file assuming that dataset. +;; (def-dataset *ds-fdml* +;; (:setup (lambda () +;; (let ((*backend-warning-behavior* +;; (if (member *test-database-type* '(:postgresql :postgresql-socket)) +;; :ignore +;; :warn))) +;; (clsql-sys:execute-command "CREATE TABLE EMPLOYEE ( +;; emplid integer NOT NULL, +;; groupid integer NOT NULL, +;; first_name character varying(30), +;; last_name character varying(30), +;; email character varying(100), +;; ecompanyid integer, +;; managerid integer, +;; height double precision, +;; married boolean, +;; birthday timestamp, +;; bd_utime bigint, +;; CONSTRAINT employeepk PRIMARY KEY (emplid, groupid), +;; CONSTRAINT employee_emplid_key UNIQUE (emplid) +;; )")))) +;; (:sqldata "EMPLOYEE" +;; "emplid,groupid,first_name,last_name,email,height,birthday" +;; "10,1,'a','b','a@b.org',1.9,current_timestamp" +;; "11,1,'x','y','x@y.org',null,current_timestamp" +;; ) +;; (:cleanup "DROP TABLE EMPLOYEE") +;; ) + +(setq *rt-fdml* + '( + +;; Computed values are not always classified as numeric by psqlodbc +(deftest :fdml/query/1 + (with-dataset *ds-employees* + (let ((count (caar (clsql:query "SELECT COUNT(*) FROM EMPLOYEE WHERE (EMAIL LIKE '%org')" :field-names nil)))) + (%get-int count))) + 10) + +(deftest :fdml/query/2 + (with-dataset *ds-employees* + (multiple-value-bind (rows field-names) + (clsql:query + "SELECT FIRST_NAME,LAST_NAME FROM EMPLOYEE WHERE (EMPLID <= 5) ORDER BY LAST_NAME") + (values rows (mapcar 'string-upcase field-names)))) + (("Leonid" "Brezhnev") ("Nikita" "Kruschev") ("Vladimir" "Lenin") + ("Josef" "Stalin") ("Leon" "Trotsky")) + ("FIRST_NAME" "LAST_NAME")) + +(deftest :fdml/query/3 + (with-dataset *ds-employees* + (caar (clsql:query "SELECT EMPLID FROM EMPLOYEE WHERE LAST_NAME = 'Andropov'" :field-names nil))) + 6) + +(deftest :fdml/query/4 + (with-dataset *ds-employees* + (typep (caar (clsql:query "SELECT HEIGHT FROM EMPLOYEE WHERE LAST_NAME = 'Andropov'" :field-names nil)) + 'float)) + t) + +(deftest :fdml/query/5 + (with-dataset *ds-employees* + (let ((res (clsql:query (clsql:sql [select [first-name] [sum [emplid]] :from [employee]] + [group-by [first-name]] [order-by [sum [emplid]]]) + :field-names nil :result-types nil))) + (mapcar (lambda (p) (list (car p) (%get-int (second p)))) + res))) + (("Josef" 2) ("Leon" 3) ("Nikita" 4) ("Leonid" 5) ("Yuri" 6) + ("Konstantin" 7) ("Mikhail" 8) ("Boris" 9) ("Vladimir" 11))) + +(deftest :fdml/query/6 + (with-dataset *ds-employees* + (let ((res (clsql:query (clsql:sql [union [select [emplid] :from [employee]] + [select [groupid] :from [company]]]) + :field-names nil :result-types nil :flatp t + ))) + (values (or (eql *test-database-type* :postgresql-socket3) + (every #'stringp res)) + (sort (mapcar #'%get-int res) + #'<=)))) + t (1 2 3 4 5 6 7 8 9 10)) + +(deftest :fdml/query/7 + (with-dataset *ds-employees* + (let ((res (car (clsql:query (clsql:sql [intersect [select [emplid] :from [employee]] + [select [groupid] :from [company]]]) + :field-names nil :result-types nil :flatp t)))) + (values (or (stringp res) + (eql *test-database-type* :postgresql-socket3)) + (nth-value 0 (%get-int res))))) + t 1) + +(deftest :fdml/query/8 + (with-dataset *ds-employees* + (let ((res (clsql:query (clsql:sql [except [select [emplid] :from [employee]] + [select [groupid] :from [company]]]) + :field-names nil :result-types nil :flatp t))) + (values (or (every #'stringp res) + (eql *test-database-type* :postgresql-socket3)) + (sort (mapcar #'%get-int res) + #'<=)))) + t (2 3 4 5 6 7 8 9 10)) + +;; compare min, max and average hieghts in inches (they're quite short +;; these guys!) +(deftest :fdml/select/1 + (with-dataset *ds-employees* + (let ((max (clsql:select [function "floor" + [/ [* [max [height]] 100] 2.54]] + :from [employee] + :result-types nil + :flatp t)) + (min (clsql:select [function "floor" + [/ [* [min [height]] 100] 2.54]] + :from [employee] + :result-types nil + :flatp t)) + (avg (clsql:select [function "floor" + [avg [/ [* [height] 100] 2.54]]] + :from [employee] + :result-types nil + :flatp t))) + (apply #'< (mapcar #'%get-int (append min avg max))))) + t) + +(deftest :fdml/select/2 + (with-dataset *ds-employees* + (clsql:select [first-name] :from [employee] :flatp t :distinct t + :field-names nil + :result-types nil + :order-by [first-name])) + ("Boris" "Josef" "Konstantin" "Leon" "Leonid" "Mikhail" "Nikita" "Vladimir" + "Yuri")) + +(deftest :fdml/select/3 + (with-dataset *ds-employees* + (let ((res (clsql:select [first-name] [count [*]] :from [employee] + :result-types nil + :group-by [first-name] + :order-by [first-name] + :field-names nil))) + (mapcar (lambda (p) (list (car p) (%get-int (second p)))) + res))) + (("Boris" 1) ("Josef" 1) ("Konstantin" 1) ("Leon" 1) ("Leonid" 1) + ("Mikhail" 1) ("Nikita" 1) ("Vladimir" 2) ("Yuri" 1))) + +(deftest :fdml/select/4 + (with-dataset *ds-employees* + (clsql:select [last-name] :from [employee] + :where [like [email] "%org"] + :order-by [last-name] + :field-names nil + :result-types nil + :flatp t)) + ("Andropov" "Brezhnev" "Chernenko" "Gorbachev" "Kruschev" "Lenin" "Putin" + "Stalin" "Trotsky" "Yeltsin")) + +(deftest :fdml/select/5 + (with-dataset *ds-employees* + (clsql:select [email] :from [employee] :flatp t :result-types nil + :where [in [employee emplid] + [select [managerid] :from [employee]]] + :field-names nil)) + ("lenin@soviet.org")) + +(deftest :fdml/select/6 + (with-dataset *ds-employees* + (if (clsql-sys:db-type-has-fancy-math? *test-database-underlying-type*) + (mapcar #'%get-int + (clsql:select [function "trunc" [height]] :from [employee] + :result-types nil + :field-names nil + :flatp t)) + (mapcar #'%get-int + (clsql:select [height] :from [employee] :flatp t + :field-names nil :result-types nil)))) + (1 1 1 1 1 1 1 1 1 1)) + +(deftest :fdml/select/7 + (with-dataset *ds-employees* + (let ((result (car (clsql:select [max [emplid]] :from [employee] :flatp t + :field-names nil :result-types nil)))) + (values + (nth-value 0 (%get-int result))))) + 10) + +(deftest :fdml/select/8 + (with-dataset *ds-employees* + (let ((result (car (clsql:select [min [emplid]] :from [employee] :flatp t + :field-names nil :result-types nil)))) + (values + (nth-value 0 (%get-int result))))) + 1) + +(deftest :fdml/select/9 + (with-dataset *ds-employees* + (let ((val (car (clsql:select + [avg [emplid]] :from [employee] :flatp t + :field-names nil :result-types nil)))) + (typecase val + (string (subseq val 0 3)) + (number (format nil "~,1F" val))))) + "5.5") + +(deftest :fdml/select/10 + (with-dataset *ds-employees* + (clsql:select [last-name] :from [employee] + :where [not [in [emplid] + [select [managerid] :from [company]]]] + :result-types nil + :field-names nil + :flatp t + :order-by [last-name])) + ("Andropov" "Brezhnev" "Chernenko" "Gorbachev" "Kruschev" "Putin" "Stalin" + "Trotsky" "Yeltsin")) + +(deftest :fdml/select/11 + (with-dataset *ds-employees* + (clsql:select [last-name] :from [employee] :where [married] :flatp t + :field-names nil :order-by [emplid] :result-types nil)) + ("Lenin" "Stalin" "Trotsky")) + +(deftest :fdml/select/12 + (with-dataset *ds-employees* + (let ((v 1)) + (clsql:select [last-name] :from [employee] :where [= [emplid] v] + :field-names nil :result-types nil))) + (("Lenin"))) + +(deftest :fdml/select/13 + (with-dataset *ds-employees* + (multiple-value-bind (results field-names) + (clsql:select [emplid] [last-name] :from [employee] + :where [= [emplid] 1]) + (values results (mapcar #'string-downcase field-names)))) + ((1 "Lenin")) + ("emplid" "last_name")) + +(deftest :fdml/select/14 + (with-dataset *ds-employees* + (floatp (car (clsql:select [height] :from [employee] :where [= [emplid] 1] + :flatp t)))) + t) + +(deftest :fdml/select/15 + (with-dataset *ds-employees* + (multiple-value-bind (rows field-names) + (clsql:select [addressid] [street-number] [street-name] [city_field] [zip] + :from [addr] + :where [= 1 [addressid]]) + (values + rows + (mapcar #'string-downcase field-names)))) + ((1 10 "Park Place" "Leningrad" 123)) + ("addressid" "street_number" "street_name" "city_field" "zip")) + +(deftest :fdml/select/16 + (with-dataset *ds-employees* + (clsql:select [emplid] :from [employee] :where [= 1 [emplid]] + :field-names nil)) + ((1))) + +(deftest :fdml/select/17 + (with-dataset *ds-employees* + (clsql:select [emplid] [last-name] :from [employee] :where [= 1 [emplid]] + :field-names nil)) + ((1 "Lenin"))) + +(deftest :fdml/select/18 + (with-dataset *ds-employees* + (clsql:select [emplid :string] [last-name] :from [employee] :where [= 1 [emplid]] + :field-names nil)) + (("1" "Lenin"))) + +(deftest :fdml/select/19 + (with-dataset *ds-employees* + (mapcar + #'%get-int + (clsql:select [emplid] :from [employee] :order-by [emplid] + :where [between [* [emplid] 10] [* 5 10] [* 10 10]] + :field-names nil :result-types nil :flatp t))) + (5 6 7 8 9 10)) + +(deftest :fdml/select/20 + (with-dataset *ds-employees* + (mapcar #'%get-int + (clsql:select [emplid] :from [employee] :order-by [emplid] + :where [not [between [* [emplid] 10] [* 5 10] [* 10 10]]] + :field-names nil :result-types nil :flatp t))) + (1 2 3 4)) + +(deftest :fdml/select/21 + (with-dataset *ds-employees* + (clsql:select [substring [first-name] 1 4] :from [employee] + :flatp t :order-by [emplid] :field-names nil)) + ("Vlad" "Jose" "Leon" "Niki" "Leon" "Yuri" "Kons" "Mikh" "Bori" "Vlad")) + +(deftest :fdml/select/22 + (with-dataset *ds-employees* + (case *test-database-underlying-type* + (:mssql (clsql:select [+ [first-name] " " [last-name]] :from [employee] + :flatp t :order-by [emplid] :field-names nil)) + (t (clsql:select [|| [first-name] " " [last-name]] :from [employee] + :flatp t :order-by [emplid] :field-names nil)))) + ("Vladimir Lenin" "Josef Stalin" "Leon Trotsky" "Nikita Kruschev" + "Leonid Brezhnev" "Yuri Andropov" "Konstantin Chernenko" "Mikhail Gorbachev" + "Boris Yeltsin" "Vladimir Putin")) + +(deftest :fdml/select/23 + (with-dataset *ds-employees* + (mapcar #'%get-int + (clsql:select [emplid] :from [employee] :where [in [emplid] '(1 2 3 4)] + :flatp t :order-by [emplid] :field-names nil + :result-types nil))) + (1 2 3 4)) + +(deftest :fdml/select/24 + (with-dataset *ds-employees* + (clsql:select [distinct [first-name]] :from [employee] :flatp t + :order-by [first-name] :field-names nil :result-types nil)) + ("Boris" "Josef" "Konstantin" "Leon" "Leonid" "Mikhail" "Nikita" "Vladimir" + "Yuri")) + +(deftest :fdml/select/25 + (with-dataset *ds-employees* + (clsql:select [first-name] :from (clsql-sys:convert-to-db-default-case "employee" *default-database*) + :flatp t :distinct t + :field-names nil + :result-types nil + :order-by [first-name])) + ("Boris" "Josef" "Konstantin" "Leon" "Leonid" "Mikhail" "Nikita" "Vladimir" + "Yuri")) + +(deftest :fdml/select/26 + (with-dataset *ds-employees* + (clsql:select ["table" first-name] ["table" last-name] + :from '([employee "table"] [employee "join"]) + :where [and [= ["table" first-name] + ["join" first-name]] + [not [= ["table" emplid] + ["join" emplid]]]] + :order-by '(["table" last-name]) + :result-types nil :field-names nil)) + (("Vladimir" "Lenin") ("Vladimir" "Putin"))) + +(deftest :fdml/select/27 + (with-dataset *ds-employees* + (mapcar + #'%get-int + (clsql:select [coalesce [managerid] 10] :from [employee] :order-by [emplid] + :field-names nil :result-types nil :flatp t))) + (10 1 1 1 1 1 1 1 1 1)) + +(deftest :fdml/select/28 + (with-dataset *ds-employees* + (loop for column in `([*] [emplid]) + collect + (%get-int + (car + (clsql:select [count column] :from [employee] + :flatp t :result-types nil :field-names nil))))) + (10 10)) + +(deftest :fdml/select/29 + (with-dataset *ds-employees* + (clsql:select [first-name] [last-name] :from [employee] + :result-types nil :field-names nil + :order-by '(([first-name] :asc) ([last-name] :desc)))) + (("Boris" "Yeltsin") ("Josef" "Stalin") ("Konstantin" "Chernenko") + ("Leon" "Trotsky") ("Leonid" "Brezhnev") ("Mikhail" "Gorbachev") + ("Nikita" "Kruschev") ("Vladimir" "Putin") ("Vladimir" "Lenin") + ("Yuri" "Andropov"))) + +(deftest :fdml/select/30 + (with-dataset *ds-employees* + (clsql:select [first-name] [last-name] :from [employee] + :result-types nil :field-names nil + :order-by '(([first-name] :asc) ([last-name] :asc)))) + (("Boris" "Yeltsin") ("Josef" "Stalin") ("Konstantin" "Chernenko") + ("Leon" "Trotsky") ("Leonid" "Brezhnev") ("Mikhail" "Gorbachev") + ("Nikita" "Kruschev") ("Vladimir" "Lenin") ("Vladimir" "Putin") + ("Yuri" "Andropov"))) + +(deftest :fdml/select/31 + (with-dataset *ds-employees* + (clsql:select [last-name] :from [employee] + :set-operation [union [select [first-name] :from [employee] + :order-by [last-name]]] + :flatp t + :result-types nil + :field-names nil)) + ("Andropov" "Boris" "Brezhnev" "Chernenko" "Gorbachev" "Josef" "Konstantin" + "Kruschev" "Lenin" "Leon" "Leonid" "Mikhail" "Nikita" "Putin" "Stalin" + "Trotsky" "Vladimir" "Yeltsin" "Yuri")) + +(deftest :fdml/select/32 + (with-dataset *ds-employees* + (mapcar + #'%get-int + (clsql:select [emplid] :from [employee] + :where [= [emplid] [any [select [companyid] :from [company]]]] + :flatp t :result-types nil :field-names nil))) + (1)) + +(deftest :fdml/select/33 + (with-dataset *ds-employees* + (clsql:select [last-name] :from [employee] + :where [> [emplid] [all [select [groupid] :from [employee]]]] + :order-by [last-name] + :flatp t :result-types nil :field-names nil)) + ("Andropov" "Brezhnev" "Chernenko" "Gorbachev" "Kruschev" "Putin" "Stalin" + "Trotsky" "Yeltsin")) + +(deftest :fdml/select/34 + (with-dataset *ds-employees* + (loop for x from 1 below 5 + collect + (car + (clsql:select [last-name] :from [employee] + :where [= [emplid] x] + :flatp t :result-types nil :field-names nil)))) + ("Lenin" "Stalin" "Trotsky" "Kruschev")) + +;; test escaping of single quotes +(deftest :fdml/select/35 + (with-dataset *ds-fddl* + (first (clsql:select "What's up doc?" :from [alpha] :flatp t :field-names nil))) + "What's up doc?") + +;; test proper treatment of backslash (depending on backend) +(deftest :fdml/select/36 + (with-dataset *ds-fddl* + (first (clsql:select "foo\\bar\\baz" :from [alpha] :flatp t :field-names nil))) + "foo\\bar\\baz") + +(deftest :fdml/select/37 + (with-dataset *ds-employees* + (clsql:select [emplid] :from [employee] + :order-by [emplid] + :limit 5 + :field-names nil + :flatp t)) + (1 2 3 4 5)) + +(deftest :fdml/select/38 + (with-dataset *ds-employees* + (clsql:select [emplid] :from [employee] + :order-by [emplid] + :limit 5 + :offset 3 + :field-names nil + :flatp t)) + (4 5 6 7 8)) + +(deftest :fdml/do-query/1 + (with-dataset *ds-employees* + (let ((result '())) + (clsql:do-query ((name) [select [last-name] :from [employee] + :order-by [last-name]]) + (push name result)) + result)) + ("Yeltsin" "Trotsky" "Stalin" "Putin" "Lenin" "Kruschev" "Gorbachev" + "Chernenko" "Brezhnev" "Andropov")) + +(deftest :fdml/map-query/1 + (with-dataset *ds-employees* + (clsql:map-query 'list #'identity + [select [last-name] :from [employee] :flatp t + :order-by [last-name]])) + ("Andropov" "Brezhnev" "Chernenko" "Gorbachev" "Kruschev" "Lenin" "Putin" + "Stalin" "Trotsky" "Yeltsin")) + +(deftest :fdml/map-query/2 + (with-dataset *ds-employees* + (clsql:map-query 'vector #'identity + [select [last-name] :from [employee] :flatp t + :order-by [last-name]])) + #("Andropov" "Brezhnev" "Chernenko" "Gorbachev" "Kruschev" "Lenin" "Putin" + "Stalin" "Trotsky" "Yeltsin")) + +(deftest :fdml/map-query/3 + (with-dataset *ds-employees* + (clsql:map-query 'list #'identity + [select [last-name] :from [employee] :order-by [last-name]])) + (("Andropov") ("Brezhnev") ("Chernenko") ("Gorbachev") ("Kruschev") ("Lenin") + ("Putin") ("Stalin") ("Trotsky") ("Yeltsin"))) + +(deftest :fdml/map-query/4 + (with-dataset *ds-employees* + (clsql:map-query 'list #'identity + [select [first-name] [last-name] :from [employee] + :order-by [last-name]])) + (("Yuri" "Andropov") ("Leonid" "Brezhnev") ("Konstantin" "Chernenko") + ("Mikhail" "Gorbachev") ("Nikita" "Kruschev") ("Vladimir" "Lenin") + ("Vladimir" "Putin") ("Josef" "Stalin") ("Leon" "Trotsky") + ("Boris" "Yeltsin"))) + +(deftest :fdml/loop/1 + (with-dataset *ds-employees* + (loop for (forename surname) + being each tuple in + [select [first-name] [last-name] :from [employee] :order-by [last-name]] + collect (concatenate 'string forename " " surname))) + ("Yuri Andropov" "Leonid Brezhnev" "Konstantin Chernenko" "Mikhail Gorbachev" + "Nikita Kruschev" "Vladimir Lenin" "Vladimir Putin" + "Josef Stalin" "Leon Trotsky" "Boris Yeltsin")) + +(deftest :fdml/loop/2 + (with-dataset *ds-employees* + (loop for (addressid) + being each tuple in + [select [addressid] :from [addr] :order-by [addressid]] + collect addressid)) + (1 2 3)) + +(deftest :fdml/loop/3 + (with-dataset *ds-employees* + (loop for addressid + being each tuple in + [select [addressid] :from [addr] :order-by [addressid]] + collect addressid)) + (1 2 3)) + +;; inserts a record using all values only and then deletes it +(deftest :fdml/insert/1 + (with-dataset *ds-employees* + (let ((now (get-universal-time))) + (clsql:insert-records + :into [employee] + :values `(11 1 "clsql-sys::astronaut" "Yuri" "Gagarin" "gagarin@soviet.org" + 1 1 1.85 t ,(clsql:utime->time now) ,now)) + (values + (clsql:select [first-name] [last-name] [email] + :from [employee] :where [= [emplid] 11]) + (progn (clsql:delete-records :from [employee] :where [= [emplid] 11]) + (clsql:select [*] :from [employee] :where [= [emplid] 11]))))) + (("Yuri" "Gagarin" "gagarin@soviet.org")) nil) + +;; inserts a record using attributes and values and then deletes it +(deftest :fdml/insert/2 + (with-dataset *ds-employees* + (progn + (clsql:insert-records :into [employee] + :attributes '(emplid groupid first_name last_name + email ecompanyid managerid) + :values '(11 1 "Yuri" "Gagarin" "gagarin@soviet.org" + 1 1)) + (values + (clsql:select [first-name] [last-name] [email] :from [employee] + :where [= [emplid] 11]) + (progn (clsql:delete-records :from [employee] :where [= [emplid] 11]) + (clsql:select [*] :from [employee] :where [= [emplid] 11]))))) + (("Yuri" "Gagarin" "gagarin@soviet.org")) nil) + +;; inserts a record using av-pairs and then deletes it +(deftest :fdml/insert/3 + (with-dataset *ds-employees* + (progn + (clsql:insert-records :into [employee] + :av-pairs'((emplid 11) (groupid 1) + (first_name "Yuri") + (last_name "Gagarin") + (email "gagarin@soviet.org") + (ecompanyid 1) (managerid 1))) + (values + (clsql:select [first-name] [last-name] [email] :from [employee] + :where [= [emplid] 11]) + (progn (clsql:delete-records :from [employee] :where [= [emplid] 11]) + (clsql:select [first-name] [last-name] [email] :from [employee] + :where [= [emplid] 11]))))) + (("Yuri" "Gagarin" "gagarin@soviet.org")) nil) + +;; inserts a records using a query from another table +(deftest :fdml/insert/4 + (with-dataset *ds-employees* + (progn + (clsql:create-table [employee2] '(([forename] string) + ([surname] string) + ([email] string))) + (clsql:insert-records :into [employee2] + :query [select [first-name] [last-name] [email] + :from [employee]] + :attributes '(forename surname email)) + (prog1 + (equal (clsql:select [*] :from [employee2]) + (clsql:select [first-name] [last-name] [email] + :from [employee])) + (clsql:drop-table [employee2] :if-does-not-exist :ignore)))) + t) + +;; updates a record using attributes and values and then deletes it +(deftest :fdml/update/1 + (with-dataset *ds-employees* + (progn + (clsql:update-records [employee] + :attributes '(first_name last_name email) + :values '("Yuri" "Gagarin" "gagarin@soviet.org") + :where [= [emplid] 1]) + (values + (clsql:select [first-name] [last-name] [email] :from [employee] + :where [= [emplid] 1]) + (progn + (clsql:update-records [employee] + :av-pairs'((first_name "Vladimir") + (last_name "Lenin") + (email "lenin@soviet.org")) + :where [= [emplid] 1]) + (clsql:select [first-name] [last-name] [email] :from [employee] + :where [= [emplid] 1]))))) + (("Yuri" "Gagarin" "gagarin@soviet.org")) + (("Vladimir" "Lenin" "lenin@soviet.org"))) + +;; updates a record using av-pairs and then deletes it +(deftest :fdml/update/2 + (with-dataset *ds-employees* + (progn + (clsql:update-records [employee] + :av-pairs'((first_name "Yuri") + (last_name "Gagarin") + (email "gagarin@soviet.org")) + :where [= [emplid] 1]) + (values + (clsql:select [first-name] [last-name] [email] :from [employee] + :where [= [emplid] 1]) + (progn + (clsql:update-records [employee] + :av-pairs'((first_name "Vladimir") + (last_name "Lenin") + (email "lenin@soviet.org")) + :where [= [emplid] 1]) + (clsql:select [first-name] [last-name] [email] + :from [employee] :where [= [emplid] 1]))))) + (("Yuri" "Gagarin" "gagarin@soviet.org")) + (("Vladimir" "Lenin" "lenin@soviet.org"))) + +;; starts a transaction deletes a record and then rolls back the deletion +(deftest :fdml/transaction/1 + (with-dataset *ds-employees* + (let ((results '())) + ;; test if we are in a transaction + (push (clsql:in-transaction-p) results) + ;;start a transaction + (clsql:start-transaction) + ;; test if we are in a transaction + (push (clsql:in-transaction-p) results) + ;;Putin has got to go + (clsql:delete-records :from [employee] :where [= [last-name] "Putin"]) + ;;Should be nil + (push + (clsql:select [*] :from [employee] :where [= [last-name] "Putin"]) + results) + ;;Oh no, he's still there + (clsql:rollback) + ;; test that we are out of the transaction + (push (clsql:in-transaction-p) results) + ;; Check that we got him back alright + (push (clsql:select [email] :from [employee] :where [= [last-name] "Putin"] + :flatp t) + results) + (apply #'values (nreverse results)))) + nil t nil nil ("putin@soviet.org")) + +;; starts a transaction, updates a record and then rolls back the update +(deftest :fdml/transaction/2 + (with-dataset *ds-employees* + (let ((results '())) + ;; test if we are in a transaction + (push (clsql:in-transaction-p) results) + ;;start a transaction + (clsql:start-transaction) + ;; test if we are in a transaction + (push (clsql:in-transaction-p) results) + ;;Putin has got to go + (clsql:update-records [employee] + :av-pairs '((email "putin-nospam@soviet.org")) + :where [= [last-name] "Putin"]) + ;;Should be new value + (push (clsql:select [email] :from [employee] + :where [= [last-name] "Putin"] + :flatp t) + results) + ;;Oh no, he's still there + (clsql:rollback) + ;; test that we are out of the transaction + (push (clsql:in-transaction-p) results) + ;; Check that we got him back alright + (push (clsql:select [email] :from [employee] :where [= [last-name] "Putin"] + :flatp t) + results) + (apply #'values (nreverse results)))) + nil t ("putin-nospam@soviet.org") nil ("putin@soviet.org")) + +;; runs an update within a transaction and checks it is committed +(deftest :fdml/transaction/3 + (with-dataset *ds-employees* + (let ((results '())) + ;; check status + (push (clsql:in-transaction-p) results) + ;; update records + (push + (clsql:with-transaction () + (clsql:update-records [employee] + :av-pairs '((email "lenin-nospam@soviet.org")) + :where [= [emplid] 1])) + results) + ;; check status + (push (clsql:in-transaction-p) results) + ;; check that was committed + (push (clsql:select [email] :from [employee] :where [= [emplid] 1] + :flatp t) + results) + ;; undo the changes + (push + (clsql:with-transaction () + (clsql:update-records [employee] + :av-pairs '((email "lenin@soviet.org")) + :where [= [emplid] 1])) + results) + ;; and check status + (push (clsql:in-transaction-p) results) + ;; check that was committed + (push (clsql:select [email] :from [employee] :where [= [emplid] 1] + :flatp t) + results) + (apply #'values (nreverse results)))) + nil nil nil ("lenin-nospam@soviet.org") nil nil ("lenin@soviet.org")) + +;; runs a valid update and an invalid one within a transaction and checks +;; that the valid update is rolled back when the invalid one fails. +(deftest :fdml/transaction/4 + (with-dataset *ds-employees* + (let ((results '())) + ;; check status + (push (clsql:in-transaction-p) results) + (handler-case + (clsql:with-transaction () + ;; valid update + (clsql:update-records [employee] + :av-pairs '((email "lenin-nospam@soviet.org")) + :where [= [emplid] 1]) + ;; invalid update which generates an error + (clsql:update-records [employee] + :av-pairs + '((emale "lenin-nospam@soviet.org")) + :where [= [emplid] 1])) + (clsql:sql-database-error () + (progn + ;; check status + (push (clsql:in-transaction-p) results) + ;; and check nothing done + (push (clsql:select [email] :from [employee] :where [= [emplid] 1] + :flatp t) + results) + (apply #'values (nreverse results))))))) + nil nil ("lenin@soviet.org")) + + +)) + diff --git a/tests/test-i18n.lisp b/tests/test-i18n.lisp new file mode 100644 index 0000000..b00c6d5 --- /dev/null +++ b/tests/test-i18n.lisp @@ -0,0 +1,52 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: test-i18n.lisp +;;;; Purpose: Tests for passing non-ascii encoded strings to db and back +;;;; Author: Nathan Bird & Kevin M. Rosenberg +;;;; Created: Feb 2010 +;;;; +;;;; 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-tests) + +(setq *rt-i18n* + '( + +;;; The point of these two is to require proper encoding support +;;; UTF-8 for example can handle these easily. +;; I show this as a 20char string and 27 bytes in utf-8 +(deftest :basic/i18n/1 + (let ((uffi:*default-foreign-encoding* :utf-8)) + (first (query "SELECT 'Iñtërnâtiônà lizætiøn'" + :flatp t :field-names nil))) + "Iñtërnâtiônà lizætiøn") + +;; the z in this one is even stronger +;; I show this as a 20char string and 28 bytes in utf-8 +(deftest :basic/i18n/2 + (let ((uffi:*default-foreign-encoding* :utf-8)) + (first (query "SELECT 'Iñtërnâtiônà ližætiøn'" + :flatp t :field-names nil))) + "Iñtërnâtiônà ližætiøn") + +(deftest :basic/i18n/big/1 + (let ((test-string (with-output-to-string (str) + (dotimes (n 250) + (write-sequence "Iñtërnâtiônà ližætiøn" str))))) + (with-dataset *ds-bigtext* + (clsql-sys:execute-command + (format nil + "INSERT INTO testbigtext (a) VALUES ('~a')" + test-string)) + (let ((res (first (clsql:query "SELECT a from testbigtext" :flatp t :field-names nil)))) + (assert (equal test-string res) (test-string res) + "Returned internationalization string was incorrect. Test :basic/i18n/big/1"))))) + +)) diff --git a/tests/test-init.lisp b/tests/test-init.lisp new file mode 100644 index 0000000..8312784 --- /dev/null +++ b/tests/test-init.lisp @@ -0,0 +1,399 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ====================================================================== +;;;; File: test-init.lisp +;;;; Authors: Marcus Pearce <m.t.pearce@city.ac.uk>, Kevin Rosenberg +;;;; Created: 30/03/2004 +;;;; +;;;; Initialisation utilities for running regression tests on CLSQL. +;;;; +;;;; 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-tests) + +(defvar *report-stream* *standard-output* "Stream to send text report.") +(defvar *sexp-report-stream* nil "Stream to send sexp report.") +(defvar *rt-internal*) +(defvar *rt-basic*) +(defvar *rt-connection*) +(defvar *rt-fddl*) +(defvar *rt-fdml*) +(defvar *rt-ooddl*) +(defvar *rt-oodml*) +(defvar *rt-syntax*) +(defvar *rt-time*) +(defvar *rt-pool*) +;; Below must be set as nil since test-i18n.lisp is not loaded on all platforms. +(defvar *rt-i18n* nil) + +(defvar *test-database-type* nil) +(defvar *test-database-underlying-type* nil) +(defvar *test-database-user* nil) +(defvar *test-false-database-user* "adsfjalsdkfjlakjsdfl" + "For testing ownership, a user that isn't the owner.") +(defvar *test-start-utime* nil) +(defvar *test-connection-spec* nil) +(defvar *test-connection-db-type* nil) +(defvar *test-report-width* 80 "Width of test report in ems.") + + +(defun find-test-connection-spec (db-type &key position) + (nth (or position 0) + (db-type-spec db-type (read-specs)))) + +(defun test-connect + (&key + (db-type *test-database-type* db-type-p) + position pool spec) + (unless spec + (setf spec + (or (and (null db-type-p) *test-connection-spec*) + (find-test-connection-spec db-type :position position)))) + (when *default-database* + (disconnect :database *default-database*)) + (setf *test-database-type* db-type + *test-database-user* + (cond + ((member db-type '(:oracle :odbc :aodbc)) (second spec)) + ((>= (length spec) 3) (third spec))) + *test-connection-spec* spec + *default-database* + (clsql:connect + spec + :database-type db-type + :make-default t + :if-exists :old + :pool pool) + *test-database-underlying-type* + (clsql-sys:database-underlying-type *default-database*)) + *default-database*) + +(defun test-setup-database (db-type &key (spec (find-test-connection-spec 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))) + + ;; Connect to the database + (test-connect :db-type db-type :spec spec) + ;; Ensure database is empty + (truncate-database :database *default-database*) + + ;; If Postgres, turn off notices to console + (when (eql db-type :postgresql) + (clsql:execute-command "SET client_min_messages = WARNING")) + + *default-database*) + +(defun default-suites () + "The default list of tests to run." + (append *rt-connection* *rt-basic* *rt-fddl* *rt-fdml* + *rt-ooddl* *rt-oodml* *rt-syntax* *rt-time* *rt-i18n*)) + +(defun internal-suites () + "The default internal suites that should run without any specific backend" + (append *rt-internal* *rt-pool*)) + + +(defvar *error-count* 0) +(defvar *error-list* nil) + +(defun run-function-append-report-file (function report-file) + (let* ((report-path (etypecase report-file + (pathname report-file) + (string (parse-namestring report-file)))) + (sexp-report-path (make-pathname :defaults report-path + :type "sexp"))) + (with-open-file (rs report-path :direction :output + :if-exists :append + :if-does-not-exist :create) + (with-open-file (srs sexp-report-path :direction :output + :if-exists :append + :if-does-not-exist :create) + (funcall function :report-stream rs :sexp-report-stream srs))))) + +(defun run-tests-append-report-file (report-file) + (run-function-append-report-file 'run-tests report-file)) + + +(defun run-tests (&key (report-stream *standard-output*) (sexp-report-stream nil) + (suites (append (internal-suites) (default-suites)))) + ;; clear SQL-OUTPUT cache + (setq clsql-sys::*output-hash* (make-hash-table :test #'equal)) + (setf *test-database-underlying-type* nil) + (let ((specs (read-specs)) + (*report-stream* report-stream) + (*sexp-report-stream* sexp-report-stream) + (*error-count* 0) + (*error-list* nil)) + (unless specs + (warn "Not running tests because test configuration file is missing") + (return-from run-tests :skipped)) + (load-necessary-systems specs) + ;;run the internal suites + (do-tests-for-internals :suites (intersection suites (internal-suites))) + ;; run backend-specific tests + (let ((suites (intersection suites (default-suites)))) + (when suites + (dolist (db-type +all-db-types+) + (dolist (spec (db-type-spec db-type specs)) + (format report-stream "~%~%Start Running Tests Against: ~A ~A~%~%" db-type (ignore-errors (subseq spec 0 2))) + (do-tests-for-backend db-type spec :suites suites) + (format report-stream "~%~%Finished Running Tests Against: ~A ~A~%~%" db-type (ignore-errors (subseq spec 0 2))))))) + (zerop *error-count*))) + +(defun load-necessary-systems (specs) + (dolist (db-type +all-db-types+) + (when (db-type-spec db-type specs) + (clsql-sys:initialize-database-type :database-type db-type)))) + +(defun write-report-banner (report-type db-type stream db-name) + (format stream + "~& +****************************************************************************** +*** CLSQL ~A begun at ~A +*** ~A +*** ~A on ~A +*** Database ~:@(~A~) +*** Type: ~:@(~A~) backend~A. +****************************************************************************** +" + report-type + (clsql:format-time + nil + (clsql:utime->time (get-universal-time))) + (lisp-implementation-type) + (lisp-implementation-version) + (machine-type) + db-name + db-type + (if (not (eq db-type *test-database-underlying-type*)) + (format nil " with underlying type ~:@(~A~)" + *test-database-underlying-type*) + "") + )) + +(defun do-tests-for-internals (&key (suites (internal-suites))) + (write-report-banner "Test Suite" "CLSQL Internals" *report-stream* + "N/A") + (%do-tests suites nil)) + +(defun %do-tests (test-forms db-type) + (regression-test:rem-all-tests) + (dolist (test-form test-forms) + (eval test-form)) + + (let* ((cl:*print-right-margin* *test-report-width*) + (remaining (regression-test:do-tests *report-stream*))) + (when (regression-test:pending-tests) + (incf *error-count* (length remaining)))) + + (let ((sexp-error (list db-type + *test-database-underlying-type* + (get-universal-time) + (length test-forms) + (regression-test:pending-tests) + (lisp-implementation-type) + (lisp-implementation-version) + (machine-type)))) + (when *sexp-report-stream* + (write sexp-error :stream *sexp-report-stream* :readably t)) + (push sexp-error *error-list*)) + ) + +(defun do-tests-for-backend (db-type spec &key + (suites (default-suites)) ) + (test-setup-database db-type :spec spec) + (unwind-protect + (multiple-value-bind (test-forms skip-tests) + (compute-tests-for-backend db-type *test-database-underlying-type* :suites suites) + + (write-report-banner "Test Suite" db-type *report-stream* + (database-name-from-spec spec db-type)) + + (%do-tests test-forms db-type) + + (format *report-stream* "~&~D of ~D Tests skipped:" + (length skip-tests) + (length test-forms)) + (if skip-tests + (let ((max-test-name (length (symbol-name (caar skip-tests))))) + (dolist (skipped (cdr skip-tests)) + (let ((len (length (symbol-name (car skipped))))) + (when (> len max-test-name) + (setq max-test-name len)))) + (let ((fmt (format nil "~~& ~~~DA ~~A~~%" max-test-name))) + (dolist (skipped skip-tests) + ;; word-wrap the reason string field + (let* ((test (car skipped)) + (reason (cdr skipped)) + ;; (rlen (length reason)) + (rwidth (max 20 (- (or *test-report-width* 80) max-test-name 3))) + (rwords (clsql-sys::delimited-string-to-list reason #\space t)) + (rformat (format nil "~~{~~<~%~~1,~D:;~~A~~> ~~}" rwidth)) + (rwrapped (format nil rformat rwords)) + (rlines (clsql-sys::delimited-string-to-list rwrapped #\Newline t))) + (dolist (rline rlines) + (format *report-stream* fmt (if test + (prog1 + test + (setq test nil)) + "") + rline)))))) + (format *report-stream* " None~%"))) + (disconnect))) + + +(defun compute-tests-for-backend (db-type db-underlying-type + &key (suites (default-suites))) + (let ((test-forms '()) + (skip-tests '())) + (dolist (test-form (if (listp suites) suites (list suites))) + (let ((test (second test-form))) + (cond + ((and (not (eql db-underlying-type :mysql)) + (clsql-sys:in test :connection/query-command + :basic/reallybigintegers/1 + :connection/pool/procedure-mysql)) + (push (cons test "known to work only in MySQL as yet.") skip-tests)) + ((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 (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 (clsql-sys:db-type-has-subqueries? db-underlying-type)) + (clsql-sys:in test :fdml/select/5 :fdml/select/10 + :fdml/select/32 :fdml/select/33)) + (push (cons test "subqueries not supported.") skip-tests)) + ((and (null (clsql-sys:db-type-transaction-capable? db-underlying-type + *default-database*)) + (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 (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-sys:in test :fddl/view/4 :fdml/select/10 + :fdml/select/21 :fdml/select/32 + :fdml/select/33)) + (push (cons test "not supported by sqlite.") skip-tests)) + ((and (eql *test-database-type* :sqlite3) + (clsql-sys:in test :fddl/view/4 :fdml/select/10 + :fdml/select/21 :fdml/select/32 + :fdml/select/33)) + (push (cons test "not supported by sqlite3.") skip-tests)) + ((and (not (clsql-sys:db-type-has-bigint? db-type)) + (clsql-sys:in test :basic/bigint/1)) + (push (cons test "bigint not supported.") skip-tests)) + ((and (eql *test-database-underlying-type* :mysql) + (clsql-sys:in test :fdml/select/26)) + (push (cons test "string table aliases not supported on all MySQL versions.") skip-tests)) + ((and (eql *test-database-underlying-type* :mysql) + (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)) + ((and (null (clsql-sys:db-type-has-union? db-underlying-type)) + (clsql-sys:in test :fdml/query/6 :fdml/select/31)) + (push (cons test "union not supported") skip-tests)) + ((and (eq *test-database-type* :oracle) + (clsql-sys:in test :fdml/query/8 :fdml/select/21 + :fddl/table/6)) + (push (cons test "syntax not supported.") skip-tests)) + ((and (eq *test-database-type* :odbc) + (eq *test-database-underlying-type* :postgresql) + (clsql-sys:in test :fddl/owner/1 :fddl/owner/table + :fddl/owner/attributes + :fddl/owner/attribute-types + :fddl/owner/index + :fddl/owner/sequence)) + (push (cons test "table ownership not supported by postgresql odbc driver.") skip-tests)) + ((and (not (member *test-database-underlying-type* + '(:postgresql :oracle))) + (clsql-sys:in test :fddl/owner/1 :fddl/owner/table + :fddl/owner/attributes + :fddl/owner/attribute-types + :fddl/owner/index + :fddl/owner/sequence)) + (push (cons test "table ownership not supported.") skip-tests)) + ((and (null (clsql-sys:db-type-has-intersect? db-underlying-type)) + (clsql-sys:in test :fdml/query/7)) + (push (cons test "intersect not supported.") skip-tests)) + ((and (null (clsql-sys:db-type-has-except? db-underlying-type)) + (clsql-sys:in test :fdml/query/8)) + (push (cons test "except not supported.") skip-tests)) + ((and (eq *test-database-underlying-type* :mssql) + (clsql-sys:in test :fdml/select/9)) + (push (cons test "mssql uses integer math for AVG.") skip-tests)) + ((and (not (member *test-database-underlying-type* + '(:postgresql :mysql :sqlite3 ))) + (clsql-sys:in test :fdml/select/37 :fdml/select/38)) + (push (cons test "LIMIT keyword not supported in SELECT.") skip-tests)) + ((and (not (clsql-sys:db-type-has-auto-increment? db-underlying-type)) + (clsql-sys:in test :oodml/select/12 :oodml/select/13 :oodml/select/14 + :oodml/select/15 :oodml/select/16 :oodml/select/17 + :oodml/select/18 :oodml/select/19 :oodml/select/20 + :oodml/select/21 :oodml/select/22 :oodml/select/23 + :oodml/update-records/4 :oodml/update-records/4-slots + :oodml/update-records/5 :oodml/update-records/5-slots + :oodml/update-records/6 :oodml/update-records/7 + :oodml/update-records/8 :oodml/update-records/9 + :oodml/update-records/9-slots :oodml/update-records/10 + :oodml/update-records/11 :OODML/UPDATE-RECORDS/12 :oodml/update-instance/3 + :oodml/update-instance/4 :oodml/update-instance/5 + :oodml/update-instance/6 :oodml/update-instance/7 + :oodml/db-auto-sync/3 :oodml/db-auto-sync/4)) + (push (cons test ":auto-increment not supported.") skip-tests)) + ((and (not (member *test-database-underlying-type* + '(:postgresql :postgresql-socket))) + (clsql-sys:in test + :time/pg/fdml/usec :time/pg/oodml/no-usec :time/pg/oodml/usec)) + (push (cons test "Postgres specific test.") + skip-tests)) + ((and (eql *test-database-type* :postgresql-socket3) + (clsql-sys:in test :BASIC/SELECT/2 :basic/select/3)) + (push (cons test "Postgres-socket3 always auto types") + skip-tests)) + ((and (eql *test-database-type* :postgresql-socket3) + (clsql-sys:in test :fdml/select/18)) + (push (cons test "Postgres-socket3 doesnt support attribute based type coersion") + skip-tests)) + ((and (eql *test-database-type* :postgresql-socket3) + (clsql-sys:in test :basic/map/1 :basic/map/2 :basic/map/3 :basic/map/4 + :basic/do/1 :basic/do/2 :fdml/do-query/1 :fdml/map-query/1 + :fdml/map-query/2 :fdml/map-query/3 :fdml/map-query/4 :fdml/loop/1 + :fdml/loop/2 :fdml/loop/3 + )) + (push (cons test "postgresql-socket3 doesnt support cursoring interface") + skip-tests)) + ((and (member *test-database-underlying-type* '(:mysql)) + (clsql-sys:in test :time/cross-platform/msec + :time/cross-platform/usec/no-tz :time/cross-platform/usec/tz)) + (push (cons test "MySQL doesn't support fractional seconds on timestamp columns (http://forge.mysql.com/worklog/task.php?id=946).") + skip-tests)) + ((and (member *test-database-underlying-type* '(:mssql)) + (clsql-sys:in test :time/cross-platform/usec/no-tz :time/cross-platform/usec/tz)) + (push (cons test "MSSQL doesn't support micro-seconds on datetime columns.") + skip-tests)) + (t + (push test-form test-forms))))) + (values (nreverse test-forms) (nreverse skip-tests)))) + +(defun rapid-load (type &optional (position 0)) + "Rapid load for interactive testing." + (test-setup-database + type + :spec (find-test-connection-spec type :position position)) + *default-database*) + +(defun rl () + (rapid-load :postgresql)) + +(defun rlm () + (rapid-load :mysql)) + +(defun rlo () + (rapid-load :oracle)) diff --git a/tests/test-internal.lisp b/tests/test-internal.lisp new file mode 100644 index 0000000..61076c6 --- /dev/null +++ b/tests/test-internal.lisp @@ -0,0 +1,77 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: test-internal.lisp +;;;; Purpose: Tests for internal clsql functions +;;;; Author: Kevin M. Rosenberg +;;;; Created: May 2004 +;;;; +;;;; This file, part of CLSQL, is Copyright (c) 2004-2010 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-tests) +(clsql-sys:file-enable-sql-reader-syntax) + +(setq *rt-internal* + '( + (deftest :int/convert/1 + (clsql-sys::prepared-sql-to-postgresql-sql "SELECT FOO FROM BAR") + "SELECT FOO FROM BAR") + + (deftest :int/convert/2 + (clsql-sys::prepared-sql-to-postgresql-sql "SELECT FOO FROM BAR WHERE ID=?") + "SELECT FOO FROM BAR WHERE ID=$1") + + (deftest :int/convert/3 + (clsql-sys::prepared-sql-to-postgresql-sql "SELECT FOO FROM \"BAR\" WHERE ID=? AND CODE=?") + "SELECT FOO FROM \"BAR\" WHERE ID=$1 AND CODE=$2") + + (deftest :int/convert/4 + (clsql-sys::prepared-sql-to-postgresql-sql "SELECT FOO FROM BAR WHERE ID=\"Match?\" AND CODE=?") + "SELECT FOO FROM BAR WHERE ID=\"Match?\" AND CODE=$1") + + (deftest :int/convert/5 + (clsql-sys::prepared-sql-to-postgresql-sql "SELECT 'FOO' FROM BAR WHERE ID='Match?''?' AND CODE=?") + "SELECT 'FOO' FROM BAR WHERE ID='Match?''?' AND CODE=$1") + + (deftest :int/output-caching/1 + ;; ensure that key generation and matching is working + ;; so that this table doesnt balloon (more than designed) + (list + (progn (clsql:sql [foo]) + (clsql:sql [foo]) + (hash-table-count clsql-sys::*output-hash*)) + + (progn (clsql:sql [foo.bar]) + (clsql:sql [foo bar]) + (hash-table-count clsql-sys::*output-hash*)) + (progn (clsql:sql (clsql-sys:sql-expression + :table (clsql-sys::database-identifier 'foo) + :attribute (clsql-sys::database-identifier 'bar))) + (clsql:sql (clsql-sys:sql-expression + :table (clsql-sys::database-identifier 'foo) + :attribute (clsql-sys::database-identifier 'bar))) + (hash-table-count clsql-sys::*output-hash*))) + (1 2 2)) + + (deftest :int/output-caching/2 + ;; ensure that we can disable the output cache and + ;; still have everything work + (let ((clsql-sys::*output-hash*)) + (list (clsql:sql [foo]) (clsql:sql [foo]) (clsql:sql [foo.bar]))) + ("FOO" "FOO" "FOO.BAR")) + + (deftest :currency/read-value/1 + (list + (clsql-sys::read-decimal-value "$ 10,500.30") + (clsql-sys::read-decimal-value "$ 10.500,30") + (clsql-sys::read-decimal-value "-10 500,30") + (clsql-sys::read-decimal-value "$ 10.500,30")) + (1050030/100 1050030/100 -1050030/100 1050030/100)) + + )) diff --git a/tests/test-ooddl.lisp b/tests/test-ooddl.lisp new file mode 100644 index 0000000..9037e53 --- /dev/null +++ b/tests/test-ooddl.lisp @@ -0,0 +1,202 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: test-ooddl.lisp +;;;; Purpose: Tests for the CLSQL Object Oriented Data Definition Language +;;;; Authors: Marcus Pearce and Kevin M. Rosenberg +;;;; Created: March 2004 +;;;; +;;;; 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-tests) + +(clsql-sys:file-enable-sql-reader-syntax) + + +(def-view-class big () + ((i :type integer :initarg :i) + (bi :type bigint :initarg :bi))) + +(def-dataset *ds-big* + (:setup (lambda () + (clsql-sys:create-view-from-class 'big) + (let ((max (expt 2 60))) + (dotimes (i 555) + (update-records-from-instance + (make-instance 'big :i (1+ i) :bi (truncate max (1+ i)))))))) + (:cleanup + (lambda () (clsql-sys:drop-view-from-class 'big)))) + +(setq *rt-ooddl* + '( + +;; Ensure slots inherited from standard-classes are :virtual +(deftest :ooddl/metaclass/1 + (values + (clsql-sys::view-class-slot-db-kind + (clsql-sys::slotdef-for-slot-with-class 'extraterrestrial + (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-sys::view-class-effective-slot-definition)) + (clsql-sys::class-slots (find-class 'person))) + (every #'(lambda (slotd) + (typep slotd 'clsql-sys::view-class-effective-slot-definition)) + (clsql-sys::class-slots (find-class 'employee))) + (every #'(lambda (slotd) + (typep slotd 'clsql-sys::view-class-effective-slot-definition)) + (clsql-sys::class-slots (find-class 'setting))) + (every #'(lambda (slotd) + (typep slotd 'clsql-sys::view-class-effective-slot-definition)) + (clsql-sys::class-slots (find-class 'theme))) + (every #'(lambda (slotd) + (typep slotd 'clsql-sys::view-class-effective-slot-definition)) + (clsql-sys::class-slots (find-class 'node))) + (every #'(lambda (slotd) + (typep slotd 'clsql-sys::view-class-effective-slot-definition)) + (clsql-sys::class-slots (find-class 'company)))) + t t t t t t) + +;; Ensure classes are correctly marked normalized or not, default not +;(deftest :ooddl/metaclass/3 +; (values +; (clsql-sys::normalizedp derivednode1) +; (clsql-sys::normalizedp basenode) +; (clsql-sys::normalizedp company1) +; (clsql-sys::normalizedp employee3) +; (clsql-sys::normalizedp derivednode-sc-2)) +; t nil nil nil t) + +;(deftest :ooddl/metaclass/3 +; (values +; (normalizedp (find-class 'baseclass)) +; (normalizedp (find-class 'normderivedclass))) +; nil t) + +(deftest :ooddl/join/1 + (with-dataset *ds-employees* + (mapcar #'(lambda (e) (slot-value e 'ecompanyid)) + (company-employees company1))) + (1 1 1 1 1 1 1 1 1 1)) + +(deftest :ooddl/join/2 + (with-dataset *ds-employees* + (slot-value (president company1) 'last-name)) + "Lenin") + +(deftest :ooddl/join/3 + (with-dataset *ds-employees* + (slot-value (employee-manager employee2) 'last-name)) + "Lenin") + +(deftest :ooddl/join/4 + (with-dataset *ds-employees* + (values + (length (employee-addresses employee10)) + ;; add an address + (let ((*db-auto-sync* T)) + (make-instance 'address :addressid 50) + (make-instance 'employee-address :emplid 10 :addressid 50) + ;; again + (length (employee-addresses employee10))) + (progn + (update-objects-joins (list employee10) :slots '(addresses)) + (length (employee-addresses employee10))))) + 0 0 1) + +(deftest :ooddl/big/1 + ;;tests that we can create-view-from-class with a bigint slot, + ;; and stick a value in there. + (progn (clsql-sys:create-view-from-class 'big) + (values + (clsql:table-exists-p [big] ) + (progn + (clsql:drop-table [big] :if-does-not-exist :ignore) + (clsql:table-exists-p [big] ))) + ) + t nil) + +(deftest :ooddl/big/2 + (with-dataset *ds-big* + (let ((rows (clsql:select [*] :from [big] :order-by [i] :field-names nil))) + (values + (length rows) + (do ((i 0 (1+ i)) + (max (expt 2 60)) + (rest rows (cdr rest))) + ((= i (length rows)) t) + (let ((index (1+ i)) + (int (first (car rest))) + (bigint (second (car rest)))) + (when (and (or (eq *test-database-type* :oracle) + (and (eq *test-database-type* :odbc) + (eq *test-database-underlying-type* :postgresql))) + (stringp bigint)) + (setf bigint (parse-integer bigint))) + (unless (and (eql int index) + (eql bigint (truncate max index))) + (return nil))))))) + 555 t) + +(deftest :ooddl/time/1 + (with-dataset *ds-employees* + (sleep 1) ;force birthdays into the past + (let* ((now (clsql:get-time))) + (when (member *test-database-underlying-type* '(:postgresql :postgresql-socket)) + (clsql:execute-command "set datestyle to 'iso'")) + (clsql:update-records [employee] :av-pairs `((birthday ,now)) + :where [= [emplid] 1]) + (let ((dbobj (car (clsql:select 'employee :where [= [birthday] now] + :flatp t)))) + (values + (slot-value dbobj 'last-name) + (clsql:time= (slot-value dbobj 'birthday) now))))) + "Lenin" t) + +(deftest :ooddl/time/2 + (with-dataset *ds-employees* + (sleep 1) ;force birthdays into the past + (let* ((now (clsql:get-time)) + (fail-index -1)) + (when (member *test-database-underlying-type* '(:postgresql :postgresql-socket)) + (clsql:execute-command "set datestyle to 'iso'")) + (dotimes (x 40) + (clsql:update-records [employee] :av-pairs `((birthday ,now)) + :where [= [emplid] 1]) + (let ((dbobj (car (clsql:select 'employee :where [= [birthday] now] + :flatp t)))) + (unless (clsql:time= (slot-value dbobj 'birthday) now) + (setf fail-index x)) + (setf now (clsql:roll now :day (* 10 x))))) + fail-index)) + -1) + +(deftest :ooddl/time/3 + (with-dataset *ds-employees* + (progn + (when (member *test-database-underlying-type* '(:postgresql :postgresql-socket)) + (clsql:execute-command "set datestyle to 'iso'")) + (let ((dbobj (car (clsql:select 'employee :where [= [emplid] 10] + :flatp t)))) + (list + (eql *test-start-utime* (slot-value dbobj 'bd-utime)) + (clsql:time= (slot-value dbobj 'birthday) + (clsql:utime->time (slot-value dbobj 'bd-utime))))))) + (t t)) + +)) + + diff --git a/tests/test-oodml.lisp b/tests/test-oodml.lisp new file mode 100644 index 0000000..6278d73 --- /dev/null +++ b/tests/test-oodml.lisp @@ -0,0 +1,1242 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ====================================================================== +;;;; File: test-oodml.lisp +;;;; Created: 01/04/2004 +;;;; +;;;; Tests for the CLSQL Object Oriented Data Definition Language +;;;; (OODML). +;;;; +;;;; 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-tests) + +(clsql-sys:file-enable-sql-reader-syntax) + +(defmacro has-sql-value-conversion-error (() &body body) + `(let (*debugger-hook*) + (handler-case + (progn ,@body nil) + (clsql-sys::sql-value-conversion-error (c) + (declare (ignore c)) + t)))) + +(setq *rt-oodml* + '( + +(deftest :oodml/read-symbol-value/1-into-this-package + (clsql-sys::read-sql-value + (clsql-sys::database-output-sql-as-type 'symbol 'clsql-tests::foo nil nil) + 'symbol nil nil) + clsql-tests::foo) + +(deftest :oodml/read-symbol-value/2-into-another-pacakge + (clsql-sys::read-sql-value + (clsql-sys::database-output-sql-as-type 'symbol 'clsql-sys::foo nil nil) + 'symbol nil nil) + clsql-sys::foo) + +(deftest :oodml/read-symbol-value/3-keyword + (clsql-sys::read-sql-value + (clsql-sys::database-output-sql-as-type 'keyword ':foo nil nil) + 'keyword nil nil) + :foo) + +(deftest :oodml/read-symbol-value/4-keyword-error + (has-sql-value-conversion-error () + (clsql-sys::read-sql-value + (clsql-sys::database-output-sql-as-type 'keyword 'foo nil nil) + 'keyword nil nil)) + T) + +(deftest :oodml/read-symbol-value/5-unknown-type-error-1 + (has-sql-value-conversion-error () + (clsql-sys::read-sql-value + (clsql-sys::database-output-sql-as-type 'bloop 'foo nil nil) + 'bloop nil nil)) + t) + +(deftest :oodml/read-symbol-value/6-unknown-type-error-2 + (has-sql-value-conversion-error () + (clsql-sys::read-sql-value + (clsql-sys::database-output-sql-as-type 'bloop 'foo nil nil) + '(or integer float) nil nil)) + t) + +(deftest :oodml/read-symbol-value/read-list + (clsql-sys::read-sql-value + (clsql-sys::database-output-sql-as-type + 'list '(("status" "new" "open")) nil nil) + 'list nil nil) + (("status" "new" "open"))) + +(deftest :oodml/select/1 + (with-dataset *ds-employees* + (mapcar #'(lambda (e) (slot-value e 'last-name)) + (clsql:select 'employee :order-by [last-name] :flatp t :caching nil))) + ("Andropov" "Brezhnev" "Chernenko" "Gorbachev" "Kruschev" "Lenin" "Putin" + "Stalin" "Trotsky" "Yeltsin")) + +(deftest :oodml/select/2 + (with-dataset *ds-employees* + (mapcar #'(lambda (e) (slot-value e 'name)) + (clsql:select 'company :flatp t :caching nil))) + ("Widgets Inc.")) + +(deftest :oodml/select/3 + (with-dataset *ds-employees* + (mapcar #'(lambda (e) (slot-value e 'ecompanyid)) + (clsql:select 'employee + :where [and [= [slot-value 'employee 'ecompanyid] + [slot-value 'company 'companyid]] + [= [slot-value 'company 'name] + "Widgets Inc."]] + :flatp t + :caching nil))) + (1 1 1 1 1 1 1 1 1 1)) + +(deftest :oodml/select/4 + (with-dataset *ds-employees* + (mapcar #'(lambda (e) + (concatenate 'string (slot-value e 'first-name) + " " + (slot-value e 'last-name))) + (clsql:select 'employee :where [= [slot-value 'employee 'first-name] + "Vladimir"] + :flatp t + :order-by [last-name] + :caching nil))) + ("Vladimir Lenin" "Vladimir Putin")) + +(deftest :oodml/select/5 + (with-dataset *ds-employees* + (length (clsql:select 'employee :where [married] :flatp t :caching nil))) + 3) + +(deftest :oodml/select/6 + (with-dataset *ds-employees* + (let ((a (caar (clsql:select 'address :where [= 1 [addressid]] :caching nil)))) + (values + (slot-value a 'street-number) + (slot-value a 'street-name) + (slot-value a 'city) + (slot-value a 'postal-code)))) + 10 "Park Place" "Leningrad" 123) + +(deftest :oodml/select/7 + (with-dataset *ds-employees* + (let ((a (caar (clsql:select 'address :where [= 2 [addressid]] :caching nil)))) + (values + (slot-value a 'street-number) + (slot-value a 'street-name) + (slot-value a 'city) + (slot-value a 'postal-code)))) + nil "" "no city" 0) + +(deftest :oodml/select/8 + (with-dataset *ds-employees* + (mapcar #'(lambda (e) (slot-value e 'married)) + (clsql:select 'employee :flatp t :order-by [emplid] :caching nil))) + (t t t nil nil nil nil nil nil nil)) + +(deftest :oodml/select/9 + (with-dataset *ds-employees* + (mapcar #'(lambda (pair) + (list + (typep (car pair) 'address) + (typep (second pair) 'employee-address) + (slot-value (car pair) 'addressid) + (slot-value (second pair) 'aaddressid) + (slot-value (second pair) 'aemplid))) + (employee-addresses employee1))) + ((t t 1 1 1) (t t 2 2 1))) + +(deftest :oodml/select/10 + (with-dataset *ds-employees* + (mapcar #'(lambda (pair) + (list + (typep (car pair) 'address) + (typep (second pair) 'employee-address) + (slot-value (car pair) 'addressid) + (slot-value (second pair) 'aaddressid) + (slot-value (second pair) 'aemplid))) + (employee-addresses employee2))) + ((t t 2 2 2))) + +(deftest :oodml/select/11 + (with-dataset *ds-employees* + (values (mapcar #'(lambda (x) (slot-value x 'emplid)) + (clsql:select 'employee :order-by '(([emplid] :asc)) + :flatp t)) + (mapcar #'(lambda (x) (slot-value x 'emplid)) + (clsql:select 'employee :order-by '(([emplid] :desc)) + :flatp t)))) + (1 2 3 4 5 6 7 8 9 10) + (10 9 8 7 6 5 4 3 2 1)) + +;; test retrieval of node, derived nodes etc +(deftest :oodml/select/12 + (with-dataset *ds-nodes* + (length (clsql:select 'node :where [not [null [node-id]]] :flatp t :caching nil))) + 11) + +(deftest :oodml/select/13 + (with-dataset *ds-nodes* + (let ((a (car (clsql:select 'node :where [= 1 [node-id]] :flatp t :caching nil)))) + (values + (slot-value a 'node-id) + (slot-value a 'title)))) + 1 "Bare node") + +(deftest :oodml/select/14 + (with-dataset *ds-nodes* + (length (clsql:select 'setting :where [not [null [setting-id]]] :flatp t :caching nil))) + 4) + +(deftest :oodml/select/15 + (with-dataset *ds-nodes* + (let ((a (car (clsql:select 'setting :where [= 3 [setting-id]] :flatp t :caching nil)))) + (values + (slot-value a 'node-id) + (slot-value a 'setting-id) + (slot-value a 'title) + (slot-value a 'vars)))) + 3 3 "Setting2" "var 2") + +(deftest :oodml/select/16 + (with-dataset *ds-nodes* + (length (clsql:select 'user :where [not [null [user-id]]] :flatp t :caching nil))) + 2) + +(deftest :oodml/select/17 + (with-dataset *ds-nodes* + (let ((a (car (clsql:select 'user :where [= 4 [user-id]] :flatp t :caching nil)))) + (values + (slot-value a 'node-id) + (slot-value a 'user-id) + (slot-value a 'title) + (slot-value a 'nick)))) + 4 4 "user-1" "first user") + +(deftest :oodml/select/18 + (with-dataset *ds-nodes* + (length (clsql:select 'theme :where [not [null [theme-id]]] :flatp t :caching nil))) + 2) + +(deftest :oodml/select/19 + (with-dataset *ds-nodes* + (let ((a (car (clsql:select 'theme :where [= 6 [theme-id]] :flatp t :caching nil)))) + (slot-value a 'theme-id))) + 6) + +(deftest :oodml/select/20 + (with-dataset *ds-nodes* + (let ((a (car (clsql:select 'theme :where [= 7 [theme-id]] :flatp t :caching nil)))) + (values + (slot-value a 'node-id) + (slot-value a 'theme-id) + (slot-value a 'title) + (slot-value a 'vars) + (slot-value a 'doc) + ))) + 7 7 "theme-2" + nil "second theme") + +;; Some tests to check weird subclassed nodes (node without own table, or subclassed of same) +(deftest :oodml/select/21 + (with-dataset *ds-nodes* + (let ((a (car (clsql:select 'location :where [= [title] "location-1"] :flatp t :caching nil)))) + (values + (slot-value a 'node-id) + (slot-value a 'title)))) + 8 "location-1") + +(deftest :oodml/select/22 + (with-dataset *ds-nodes* + (let ((a (car (clsql:select 'subloc :where [not [null [subloc-id]]] :flatp t :caching nil)))) + (values + (slot-value a 'node-id) + (slot-value a 'subloc-id) + (slot-value a 'title) + (slot-value a 'loc)))) + 10 10 "subloc-1" "a subloc") + +(deftest :oodml/select/23 + (with-dataset *ds-artists* + (length (clsql:select 'artist :flatp t :caching nil))) + 0) + + + +;; test retrieval is deferred +(deftest :oodm/retrieval/1 + (with-dataset *ds-employees* + (every #'(lambda (e) (not (slot-boundp e 'company))) + (select 'employee :flatp t :caching nil))) + t) + +(deftest :oodm/retrieval/2 + (with-dataset *ds-employees* + (every #'(lambda (e) (not (slot-boundp e 'address))) + (select 'deferred-employee-address :flatp t :caching nil))) + t) + +;; :retrieval :immediate should be boundp before accessed +(deftest :oodm/retrieval/3 + (with-dataset *ds-employees* + (every #'(lambda (ea) (slot-boundp ea 'address)) + (select 'employee-address :flatp t :caching nil))) + t) + +(deftest :oodm/retrieval/4 + (with-dataset *ds-employees* + (every #'(lambda (ea) (typep (slot-value ea 'address) 'address)) + (select 'employee-address :flatp t :caching nil))) + t) + +(deftest :oodm/retrieval/5 + (with-dataset *ds-employees* + (every #'(lambda (ea) (typep (slot-value ea 'address) 'address)) + (select 'deferred-employee-address :flatp t :caching nil))) + t) + +(deftest :oodm/retrieval/6 + (with-dataset *ds-employees* + (every #'(lambda (ea) (slot-boundp (slot-value ea 'address) 'addressid)) + (select 'employee-address :flatp t :caching nil))) + t) + +(deftest :oodm/retrieval/7 + (with-dataset *ds-employees* + (every #'(lambda (ea) (slot-boundp (slot-value ea 'address) 'addressid)) + (select 'deferred-employee-address :flatp t :caching nil))) + t) + +(deftest :oodm/retrieval/8 + (with-dataset *ds-employees* + (mapcar #'(lambda (ea) (slot-value (slot-value ea 'address) 'street-number)) + (select 'employee-address :flatp t :order-by [aaddressid] :caching nil))) + (10 10 nil nil nil nil)) + +(deftest :oodm/retrieval/9 + (with-dataset *ds-employees* + (mapcar #'(lambda (ea) (slot-value (slot-value ea 'address) 'street-number)) + (select 'deferred-employee-address :flatp t :order-by [aaddressid] :caching nil))) + (10 10 nil nil nil nil)) + +(deftest :oodm/retrieval/10-slot-columns + (with-dataset *ds-employees* + (mapcar #'title + (select 'employee :flatp t :caching nil + :where [<= [emplid] 3] + :order-by `((,[emplid] :asc))))) + (supplicant :adherent cl-user::novice)) + +;; tests update-records-from-instance +(deftest :oodml/update-records/1 + (with-dataset *ds-employees* + (values + (progn + (let ((lenin (car (clsql:select 'employee + :where [= 1 [slot-value 'employee 'emplid]] + :flatp t + :caching nil)))) + (format nil "~a ~a: ~a" + (first-name lenin) + (last-name lenin) + (employee-email lenin)))) + (progn + (setf (slot-value employee1 'first-name) "Dimitriy" + (slot-value employee1 'last-name) "Ivanovich" + (slot-value employee1 'email) "ivanovich@soviet.org") + (clsql:update-records-from-instance employee1) + (let ((lenin (car (clsql:select 'employee + :where [= 1 [slot-value 'employee 'emplid]] + :flatp t + :caching nil)))) + (format nil "~a ~a: ~a" + (first-name lenin) + (last-name lenin) + (employee-email lenin)))))) + "Vladimir Lenin: lenin@soviet.org" + "Dimitriy Ivanovich: ivanovich@soviet.org") + +;; tests update-record-from-slot +(deftest :oodml/update-records/2 + (with-dataset *ds-employees* + ;(start-sql-recording :type :both) + (values + (employee-email + (car (clsql:select 'employee + :where [= 1 [slot-value 'employee 'emplid]] + :flatp t + :caching nil))) + (progn + (setf (slot-value employee1 'email) "lenin-nospam@soviet.org") + (clsql:update-record-from-slot employee1 'email) + (employee-email + (car (clsql:select 'employee + :where [= 1 [slot-value 'employee 'emplid]] + :flatp t + :caching nil)))))) + "lenin@soviet.org" "lenin-nospam@soviet.org") + +;; tests update-record-from-slots +(deftest :oodml/update-records/3 + (with-dataset *ds-employees* + (values + (let ((lenin (car (clsql:select 'employee + :where [= 1 [slot-value 'employee 'emplid]] + :flatp t + :caching nil)))) + (format nil "~a ~a: ~a" + (first-name lenin) + (last-name lenin) + (employee-email lenin))) + (progn + (setf (slot-value employee1 'first-name) "Dimitriy" + (slot-value employee1 'last-name) "Ivanovich" + (slot-value employee1 'email) "ivanovich@soviet.org") + (clsql:update-record-from-slots employee1 '(first-name last-name email)) + (let ((lenin (car (clsql:select 'employee + :where [= 1 [slot-value 'employee 'emplid]] + :flatp t + :caching nil)))) + (format nil "~a ~a: ~a" + (first-name lenin) + (last-name lenin) + (employee-email lenin)))))) + "Vladimir Lenin: lenin@soviet.org" + "Dimitriy Ivanovich: ivanovich@soviet.org") + +(deftest :oodml/update-records/4 + (with-dataset *ds-nodes* + (flet ((print-fresh-node () + (let ((base (car (clsql:select 'node + :where [= 1 [slot-value 'node 'node-id]] + :flatp t :caching nil)))) + (format nil "~a ~a" + (slot-value base 'node-id) + (slot-value base 'title))))) + (values + (print-fresh-node) + (let ((base (car (clsql:select 'node + :where [= 1 [slot-value 'node 'node-id]] + :flatp t :caching nil)))) + (setf (slot-value base 'title) "Altered title") + (clsql:update-records-from-instance base) + (print-fresh-node))))) + "1 Bare node" + "1 Altered title") + +(deftest :oodml/update-records/4-slots ;just like 4, but use slots fns. + (with-dataset *ds-nodes* + (flet ((print-fresh-setting () + (let ((node (car (clsql:select 'setting + :where [= 3 [slot-value 'setting 'setting-id]] + :flatp t :caching nil)))) + (format nil "~a ~a ~a" + (slot-value node 'setting-id) + (slot-value node 'title) + (slot-value node 'vars))))) + (values + (print-fresh-setting) + (let ((node (car (clsql:select 'setting + :where [= 3 [slot-value 'setting 'setting-id]] + :flatp t :caching nil)))) + (setf (slot-value node 'title) "Altered title") + (setf (slot-value node 'vars) "Altered vars") + (clsql-sys:update-record-from-slot node 'title) + (clsql-sys:update-record-from-slot node 'vars) + (print-fresh-setting)) + (let ((node (car (clsql:select 'setting + :where [= 3 [slot-value 'setting 'setting-id]] + :flatp t :caching nil)))) + (setf (slot-value node 'title) "Setting2") + (setf (slot-value node 'vars) "var 2") + (clsql:update-records-from-instance node) + (clsql-sys:update-record-from-slots node '(vars title)) + (print-fresh-setting))))) + "3 Setting2 var 2" + "3 Altered title Altered vars" + "3 Setting2 var 2") + +(deftest :oodml/update-records/5 + (with-dataset *ds-nodes* + (flet ((print-fresh-setting () + (let ((node (car (clsql:select 'setting + :where [= 3 [slot-value 'setting 'setting-id]] + :flatp t :caching nil)))) + (format nil "~a ~a ~a" + (slot-value node 'setting-id) + (slot-value node 'title) + (slot-value node 'vars))))) + (values + (print-fresh-setting) + (let ((node (car (clsql:select 'setting + :where [= 3 [slot-value 'setting 'setting-id]] + :flatp t :caching nil)))) + (setf (slot-value node 'title) "Altered title") + (setf (slot-value node 'vars) "Altered vars") + (clsql:update-records-from-instance node) + (print-fresh-setting))))) + "3 Setting2 var 2" + "3 Altered title Altered vars") + +(deftest :oodml/update-records/5-slots + (with-dataset *ds-nodes* + (flet ((print-fresh-setting () + (let ((node (car (clsql:select 'setting + :where [= 3 [slot-value 'setting 'setting-id]] + :flatp t :caching nil)))) + (format nil "~a ~a ~a" + (slot-value node 'setting-id) + (slot-value node 'title) + (slot-value node 'vars))))) + (values + (print-fresh-setting) + (let ((node (car (clsql:select 'setting + :where [= 3 [slot-value 'setting 'setting-id]] + :flatp t :caching nil)))) + (setf (slot-value node 'title) "Altered title") + (setf (slot-value node 'vars) "Altered vars") + (clsql-sys:update-record-from-slot node 'title) + (clsql-sys:update-record-from-slot node 'vars) + (print-fresh-setting)) + (let ((node (car (clsql:select 'setting + :where [= 3 [slot-value 'setting 'setting-id]] + :flatp t :caching nil)))) + (setf (slot-value node 'title) "Setting2") + (setf (slot-value node 'vars) "var 2") + (clsql-sys:update-record-from-slots node '(title vars)) + (print-fresh-setting))))) + "3 Setting2 var 2" + "3 Altered title Altered vars" + "3 Setting2 var 2") + +(deftest :oodml/update-records/6 + (with-dataset *ds-nodes* + (flet ((print-fresh-setting () + (let ((node (car (clsql:select 'setting + :where [= 7 [slot-value 'setting 'setting-id]] + :flatp t :caching nil)))) + (format nil "~a ~a ~a" + (slot-value node 'setting-id) + (slot-value node 'title) + (or (slot-value node 'vars) "NIL"))))) + (values + (print-fresh-setting) + (let ((node (car (clsql:select 'setting + :where [= 7 [slot-value 'setting 'setting-id]] + :flatp t :caching nil)))) + (setf (slot-value node 'title) "Altered title") + (setf (slot-value node 'vars) "Altered vars") + (clsql:update-records-from-instance node) + (print-fresh-setting)) + (let ((node (car (clsql:select 'setting + :where [= 7 [slot-value 'setting 'setting-id]] + :flatp t :caching nil)))) + (setf (slot-value node 'title) "theme-2") + (setf (slot-value node 'vars) nil) + (clsql:update-records-from-instance node) + (print-fresh-setting))))) + "7 theme-2 NIL" + "7 Altered title Altered vars" + "7 theme-2 NIL") + +(deftest :oodml/update-records/7 + (with-dataset *ds-nodes* + (flet ((print-fresh-user () + "requery to get what the db has, and print out." + (let ((node (car (clsql:select 'user + :where [= 5 [slot-value 'user 'user-id]] + :flatp t :caching nil)))) + (format nil "~a ~a ~a" + (slot-value node 'user-id) + (slot-value node 'title) + (slot-value node 'nick))))) + (values + (print-fresh-user) + (let ((node (car (clsql:select 'user + :where [= 5 [slot-value 'user 'user-id]] + :flatp t :caching nil)))) + (setf (slot-value node 'title) "Altered title") + (setf (slot-value node 'nick) "Altered nick") + (clsql:update-records-from-instance node) + (print-fresh-user))))) + "5 user-2 second user" + "5 Altered title Altered nick") + +(deftest :oodml/update-records/8 + (with-dataset *ds-nodes* + (flet ((print-fresh-theme () + (let ((node (car (clsql:select 'theme + :where [= 6 [slot-value 'theme 'theme-id]] + :flatp t :caching nil)))) + (with-slots (node-id setting-id theme-id title vars doc) node + (format nil "~a ~a ~a ~a ~a ~a" + node-id setting-id theme-id + title (or vars "NIL") doc))))) + (values + (print-fresh-theme) + (let ((node (car (clsql:select 'setting + :where [= 6 [slot-value 'setting 'setting-id]] + :flatp t :caching nil)))) + (setf (slot-value node 'title) "Altered title") + (setf (slot-value node 'vars) nil) + (clsql:update-records-from-instance node) + (print-fresh-theme)) + (let ((node (car (clsql:select 'theme + :where [= 6 [slot-value 'theme 'theme-id]] + :flatp t :caching nil)))) + (setf (slot-value node 'title) "Altered title again") + (setf (slot-value node 'doc) "altered doc") + (clsql:update-records-from-instance node) + (print-fresh-theme)) + (let ((node (car (clsql:select 'theme + :where [= 6 [slot-value 'theme 'theme-id]] + :flatp t :caching nil)))) + (setf (slot-value node 'title) "theme-1") + (setf (slot-value node 'vars) "empty") + (setf (slot-value node 'doc) "first theme") + (clsql:update-records-from-instance node) + (print-fresh-theme))))) + "6 6 6 theme-1 empty first theme" + "6 6 6 Altered title NIL first theme" + "6 6 6 Altered title again NIL altered doc" + "6 6 6 theme-1 empty first theme") + +(deftest :oodml/update-records/9 + (with-dataset *ds-nodes* + (flet ((print-fresh-subloc () + (let ((sl (car (clsql:select 'subloc + :where [= 10 [slot-value 'subloc 'subloc-id]] + :flatp t :caching nil)))) + (unless sl + (error "Couldn't find expected sublocation")) + (format nil "~a ~a ~a" + (slot-value sl 'subloc-id) + (slot-value sl 'title) + (slot-value sl 'loc))))) + (values + (print-fresh-subloc) + (let ((sl (car (clsql:select 'subloc + :where [= 10 [slot-value 'subloc 'subloc-id]] + :flatp t :caching nil)))) + (setf (slot-value sl 'title) "Altered subloc title") + (setf (slot-value sl 'loc) "Altered loc") + (clsql:update-records-from-instance sl) + (print-fresh-subloc))))) + "10 subloc-1 a subloc" + "10 Altered subloc title Altered loc") + +(deftest :oodml/update-records/9-slots ;like 9, but use slots fns. + (with-dataset *ds-nodes* + (flet ((print-fresh-subloc () + (let ((sl (car (clsql:select 'subloc + :where [= 10 [slot-value 'subloc 'subloc-id]] + :flatp t :caching nil)))) + (unless sl + (error "In psfl: found no sublocation with id = 10")) + (format nil "~a ~a ~a" + (slot-value sl 'subloc-id) + (slot-value sl 'title) + (slot-value sl 'loc))))) + (values + (print-fresh-subloc) + (let ((sl (car (clsql:select 'subloc + :where [= 10 [slot-value 'subloc 'subloc-id]] + :flatp t :caching nil)))) + (unless sl + (error "Select for modification: Found no sublocation with id = 10")) + (setf (slot-value sl 'title) "Altered subloc title") + (setf (slot-value sl 'loc) "Altered loc") + (clsql:update-record-from-slot sl 'title) + (clsql:update-record-from-slot sl 'loc) + (print-fresh-subloc)) + (let ((sl (car (clsql:select 'subloc + :where [= 10 [slot-value 'subloc 'subloc-id]] + :flatp t :caching nil)))) + (unless sl + (error "Select for next modification: Found no sublocation with id = 10")) + (setf (slot-value sl 'title) "subloc-1") + (setf (slot-value sl 'loc) "a subloc") + (clsql:update-record-from-slots sl '(title loc)) + (print-fresh-subloc))))) + "10 subloc-1 a subloc" + "10 Altered subloc title Altered loc" + "10 subloc-1 a subloc") + +;; Verify that we can set a float to nil and then read it back +;; (was failing in Postgresql at somepoint) +(deftest :oodml/update-records/10 + (with-dataset *ds-employees* + (let ((emp (first (clsql:select 'employee :where [= [emplid] 1] :flatp t)))) + (setf (height emp) nil) + (clsql-sys:update-record-from-slot emp 'height) + (values + (clsql:select [height] :from [employee] :where [= [emplid] 1]) + (progn + (setf (height emp) 42.0) + (clsql-sys:update-record-from-slot emp 'height) + (clsql:select [height] :from [employee] :where [= [emplid] 1])) + (progn + (setf (height emp) 24.13d0) + (clsql-sys:update-record-from-slot emp 'height) + (clsql:select [height] :from [employee] :where [= [emplid] 1]))))) + ((nil)) + ((42.0d0)) + ((24.13d0))) + +(deftest :oodml/update-records/11 + (with-dataset *ds-artists* + (clsql:update-records-from-instance artist1) + (list (name artist1) (artist_id artist1))) + ("Mogwai" 1)) + +(deftest :oodml/update-records/12 + (with-dataset *ds-artists* + (clsql:update-records-from-instance artist1) + (list (name artist1) (genre artist1))) + ("Mogwai" "Unknown")) + +;; tests update-instance-from-records +(deftest :oodml/update-instance/1 + (with-dataset *ds-employees* + (values + (format nil "~a ~a: ~a" + (slot-value employee1 'first-name) + (slot-value employee1 'last-name) + (slot-value employee1 'email)) + (progn + (clsql:update-records [employee] + :av-pairs '(([first-name] "Ivan") + ([last-name] "Petrov") + ([email] "petrov@soviet.org")) + :where [= [emplid] 1]) + (clsql:update-instance-from-records employee1) + (format nil "~a ~a: ~a" + (slot-value employee1 'first-name) + (slot-value employee1 'last-name) + (slot-value employee1 'email))))) + "Vladimir Lenin: lenin@soviet.org" + "Ivan Petrov: petrov@soviet.org") + +;; tests update-slot-from-record +(deftest :oodml/update-instance/2 + (with-dataset *ds-employees* + (values + (slot-value employee1 'email) + (progn + (clsql:update-records [employee] + :av-pairs '(([email] "lenin-nospam@soviet.org")) + :where [= [emplid] 1]) + (clsql:update-slot-from-record employee1 'email) + (slot-value employee1 'email)))) + "lenin@soviet.org" "lenin-nospam@soviet.org") + +;; tests normalizedp update-instance-from-records +(deftest :oodml/update-instance/3 + (with-dataset *ds-nodes* + (values + (with-output-to-string (out) + (format out "~a ~a ~a ~a" + (slot-value theme2 'theme-id) + (slot-value theme2 'title) + (or (slot-value theme2 'vars) "NIL") + (slot-value theme2 'doc))) + (progn + (clsql:update-records [node] :av-pairs '(([title] "Altered title")) + :where [= [node-id] 7]) + (clsql:update-records [setting] :av-pairs '(([vars] "Altered vars")) + :where [= [setting-id] 7]) + (clsql:update-records [theme] :av-pairs '(([doc] "Altered doc")) + :where [= [theme-id] 7]) + (clsql:update-instance-from-records theme2) + (with-output-to-string (out) + (format out "~a ~a ~a ~a" + (slot-value theme2 'theme-id) + (slot-value theme2 'title) + (slot-value theme2 'vars) + (slot-value theme2 'doc)))))) + "7 theme-2 NIL second theme" + "7 Altered title Altered vars Altered doc") + +(deftest :oodml/update-instance/4 + (with-dataset *ds-nodes* + (values + (progn + (setf loc2 (car (clsql:select 'location + :where [= [node-id] 9] + :flatp t :caching nil))) + (format nil "~a ~a" + (slot-value loc2 'node-id) + (slot-value loc2 'title))) + (progn + (clsql:update-records [node] :av-pairs '(([title] "Altered title")) + :where [= [node-id] 9]) + (clsql:update-instance-from-records loc2) + (format nil "~a ~a" + (slot-value loc2 'node-id) + (slot-value loc2 'title))))) + "9 location-2" + "9 Altered title") + +(deftest :oodml/update-instance/5 + (with-dataset *ds-nodes* + (values + (format nil "~a ~a ~a" + (slot-value subloc2 'subloc-id) + (slot-value subloc2 'title) + (slot-value subloc2 'loc)) + (progn + (clsql:update-records [node] :av-pairs '(([title] "Altered title")) + :where [= [node-id] 11]) + (clsql:update-records [subloc] :av-pairs '(([loc] "Altered loc")) + :where [= [subloc-id] 11]) + (clsql:update-instance-from-records subloc2) + (format nil "~a ~a ~a" + (slot-value subloc2 'subloc-id) + (slot-value subloc2 'title) + (slot-value subloc2 'loc))))) + "11 subloc-2 second subloc" + "11 Altered title Altered loc") + +;; tests update-slot-from-record with normalizedp stuff +(deftest :oodml/update-instance/6 + (with-dataset *ds-nodes* + (values + (slot-value theme1 'doc) + (slot-value theme1 'vars) + (progn + (clsql:update-records [theme] + :av-pairs '(([doc] "altered doc")) + :where [= [theme-id] 6]) + (clsql:update-slot-from-record theme1 'doc) + (slot-value theme1 'doc)) + (progn + (clsql:update-records [setting] + :av-pairs '(([vars] "altered vars")) + :where [= [setting-id] 6]) + (clsql:update-slot-from-record theme1 'vars) + (slot-value theme1 'vars)))) + "first theme" "empty" + "altered doc" "altered vars") + +(deftest :oodml/update-instance/7 + (flet ((print-loc (l) + (format nil "~a: ~a" + (slot-value l 'node-id) (slot-value l 'title))) + (print-subloc (sl) + (format nil "~a: ~a" + (slot-value sl 'node-id) (slot-value sl 'loc)))) + (with-dataset *ds-nodes* + (values + (print-loc loc2) + (print-subloc subloc2) + (progn + (clsql:update-records [node] + :av-pairs '(([title] "altered title")) + :where [= [node-id] (node-id loc2)]) + (clsql:update-slot-from-record loc2 'title) + (print-loc loc2)) + (progn + (clsql:update-records [subloc] + :av-pairs '(([loc] "altered loc")) + :where [= [subloc-id] (subloc-id subloc2)]) + (clsql:update-slot-from-record subloc2 'loc) + (print-subloc subloc2))))) + "9: location-2" "11: second subloc" + "9: altered title" "11: altered loc") + +(deftest :oodml/do-query/1 + (with-dataset *ds-employees* + (let ((result '())) + (clsql:do-query ((e) [select 'employee :order-by [emplid]]) + (push (slot-value e 'last-name) result)) + result)) + ("Putin" "Yeltsin" "Gorbachev" "Chernenko" "Andropov" "Brezhnev" "Kruschev" + "Trotsky" "Stalin" "Lenin")) + +(deftest :oodml/do-query/2 + (with-dataset *ds-employees* + (let ((result '())) + (clsql:do-query ((e c) [select 'employee 'company + :where [= [slot-value 'employee 'last-name] + "Lenin"]]) + (push (list (slot-value e 'last-name) (slot-value c 'name)) + result)) + result)) + (("Lenin" "Widgets Inc."))) + +(deftest :oodml/map-query/1 + (with-dataset *ds-employees* + (clsql:map-query 'list #'last-name [select 'employee :order-by [emplid]])) + ("Lenin" "Stalin" "Trotsky" "Kruschev" "Brezhnev" "Andropov" "Chernenko" + "Gorbachev" "Yeltsin" "Putin")) + +(deftest :oodml/map-query/2 + (with-dataset *ds-employees* + (clsql:map-query 'list #'(lambda (e c) (list (slot-value e 'last-name) + (slot-value c 'name))) + [select 'employee 'company :where [= [slot-value 'employee 'last-name] + "Lenin"]])) + (("Lenin" "Widgets Inc."))) + +(deftest :oodml/iteration/3 + (with-dataset *ds-employees* + (loop for (e) being the records in + [select 'employee :where [< [emplid] 4] :order-by [emplid]] + collect (slot-value e 'last-name))) + ("Lenin" "Stalin" "Trotsky")) + + +(deftest :oodml/cache/1 + (with-dataset *ds-employees* + (let ((*default-caching* t)) + (setf (clsql-sys:record-caches *default-database*) nil) + (let ((employees (select 'employee))) + (every #'(lambda (a b) (eq a b)) + employees (select 'employee))))) + t) + +(deftest :oodml/cache/2 + (with-dataset *ds-employees* + (let* ((*default-caching* t) + (employees (select 'employee))) + (equal employees (select 'employee :flatp t)))) + nil) + +(deftest :oodml/refresh/1 + (with-dataset *ds-employees* + (let* ((clsql-sys:*default-caching* t) + (addresses (select 'address))) + (equal addresses (select 'address :refresh t)))) + t) + +(deftest :oodml/refresh/2 + (with-dataset *ds-employees* + (let* ((clsql-sys:*default-caching* t) + (addresses (select 'address :order-by [addressid] :flatp t :refresh t)) + (city (slot-value (car addresses) 'city))) + (clsql:update-records [addr] + :av-pairs '((city_field "A new city")) + :where [= [addressid] (slot-value (car addresses) 'addressid)]) + (let* ((new-addresses (select 'address :order-by [addressid] :refresh t :flatp t)) + (new-city (slot-value (car addresses) 'city)) + ) + (clsql:update-records [addr] + :av-pairs `((city_field ,city)) + :where [= [addressid] (slot-value (car addresses) 'addressid)]) + (values (equal addresses new-addresses) + city + new-city)))) + t "Leningrad" "A new city") + +(deftest :oodml/refresh/3 + (with-dataset *ds-employees* + (let* ((clsql-sys:*default-caching* t) + (addresses (select 'address :order-by [addressid] :flatp t))) + (values + (equal addresses (select 'address :refresh t :flatp t)) + (equal addresses (select 'address :flatp t))))) + nil nil) + +(deftest :oodml/refresh/4 + (with-dataset *ds-employees* + (let* ((clsql-sys:*default-caching* t) + (addresses (select 'address :order-by [addressid] :flatp t :refresh t)) + (*db-auto-sync* t)) + (make-instance 'address :addressid 1000 :city "A new address city") + (let ((new-addresses (select 'address :order-by [addressid] :flatp t :refresh t))) + (values + (length addresses) + (length new-addresses) + (eq (first addresses) (first new-addresses)) + (eq (second addresses) (second new-addresses)))))) + 3 4 t t) + + +(deftest :oodml/uoj/full-set + (with-dataset *ds-employees* + (progn + (let* ((dea-list (select 'deferred-employee-address + :caching nil :order-by ["ea_join" aaddressid] + :flatp t)) + (dea-list-copy (copy-seq dea-list)) + (initially-unbound (every #'(lambda (dea) (not (slot-boundp dea 'address))) dea-list))) + (update-objects-joins dea-list :slots 'address :max-len nil) + (values + initially-unbound + (equal dea-list dea-list-copy) + (every #'(lambda (dea) (slot-boundp dea 'address)) dea-list) + (every #'(lambda (dea) (typep (slot-value dea 'address) 'address)) dea-list) + (mapcar #'(lambda (dea) (slot-value (slot-value dea 'address) 'addressid)) dea-list))))) + t t t t (1 1 2 2 2 3)) + +(deftest :oodml/uoj/batched + (with-dataset *ds-employees* + (progn + (let* ((dea-list (select 'deferred-employee-address + :caching nil :order-by ["ea_join" aaddressid] + :flatp t)) + (dea-list-copy (copy-seq dea-list)) + (initially-unbound (every #'(lambda (dea) (not (slot-boundp dea 'address))) dea-list))) + (update-objects-joins dea-list :slots 'address :max-len 2) + (values + initially-unbound + (equal dea-list dea-list-copy) + (every #'(lambda (dea) (slot-boundp dea 'address)) dea-list) + (every #'(lambda (dea) (typep (slot-value dea 'address) 'address)) dea-list) + (mapcar #'(lambda (dea) (slot-value (slot-value dea 'address) 'addressid)) dea-list))))) + t t t t (1 1 2 2 2 3)) + +;; update-object-joins needs to be fixed for multiple keys +#+ignore +(deftest :oodml/uoj/multi-key + (progn + (clsql:update-objects-joins (list company1)) + (mapcar #'(lambda (e) + (slot-value e 'ecompanyid)) + (company-employees company1))) + (1 1 1 1 1 1 1 1 1 1)) + +(deftest :oodml/big/1 + (with-dataset *ds-big* + (let ((objs (clsql:select 'big :order-by [i] :flatp t))) + (values + (length objs) + (do ((i 0 (1+ i)) + (max (expt 2 60)) + (rest objs (cdr rest))) + ((= i (length objs)) t) + (let ((obj (car rest)) + (index (1+ i))) + (unless (and (eql (slot-value obj 'i) index) + (eql (slot-value obj 'bi) (truncate max index))) + (print index) + (describe obj) + (return nil))))))) + 555 t) + +(deftest :oodml/db-auto-sync/1 + (with-dataset *ds-employees* + (values + (progn + (make-instance 'employee :emplid 20 :groupid 1 + :last-name "Ivanovich") + (select [last-name] :from [employee] :where [= [emplid] 20] + :flatp t :field-names nil)) + (let ((*db-auto-sync* t)) + (make-instance 'employee :emplid 20 :groupid 1 + :last-name "Ivanovich") + (prog1 (select [last-name] :from [employee] :flatp t + :field-names nil + :where [= [emplid] 20]) + (delete-records :from [employee] :where [= [emplid] 20]))))) + nil ("Ivanovich")) + +(deftest :oodml/db-auto-sync/2 + (with-dataset *ds-employees* + (values + (let ((instance (make-instance 'employee :emplid 20 :groupid 1 + :last-name "Ivanovich"))) + (setf (slot-value instance 'last-name) "Bulgakov") + (select [last-name] :from [employee] :where [= [emplid] 20] + :flatp t :field-names nil)) + (let* ((*db-auto-sync* t) + (instance (make-instance 'employee :emplid 20 :groupid 1 + :last-name "Ivanovich"))) + (setf (slot-value instance 'last-name) "Bulgakov") + (prog1 (select [last-name] :from [employee] :flatp t + :field-names nil + :where [= [emplid] 20]) + (delete-records :from [employee] :where [= [emplid] 20]))))) + nil ("Bulgakov")) + +(deftest :oodml/db-auto-sync/3 + (with-dataset *ds-nodes* + (values + (progn + (make-instance 'theme :title "test-theme" :vars "test-vars" + :doc "test-doc") + (select [node-id] :from [node] :where [= [title] "test-theme"] + :flatp t :field-names nil)) + (let ((*db-auto-sync* t)) + (make-instance 'theme :title "test-theme" :vars "test-vars" + :doc "test-doc") + (prog1 (select [title] :from [node] :where [= [title] "test-theme"] + :flatp t :field-names nil) + (delete-records :from [node] :where [= [title] "test-theme"]) + (delete-records :from [setting] :where [= [vars] "test-vars"]) + (delete-records :from [theme] :where [= [doc] "test-doc"]))))) + nil ("test-theme")) + +(deftest :oodml/db-auto-sync/4 + (with-dataset *ds-nodes* + (values + (let ((inst (make-instance 'theme + :title "test-theme" :vars "test-vars" + :doc "test-doc")) + (*print-circle* nil)) + (setf (slot-value inst 'title) "alternate-test-theme") + (format nil "~a ~a ~a ~a" + (or (select [title] :from [node] + :where [= [title] "test-theme"] + :flatp t :field-names nil) "NIL") + (or (select [vars] :from [setting] + :where [= [vars] "test-vars"] + :flatp t :field-names nil) "NIL") + (or (select [doc] :from [theme] + :where [= [doc] "test-doc"] + :flatp t :field-names nil) "NIL") + (or (select [title] :from [node] + :where [= [title] "alternate-test-theme"] + :flatp t :field-names nil) "NIL"))) + (let* ((*db-auto-sync* t) + (inst (make-instance 'theme + :title "test-theme" :vars "test-vars" + :doc "test-doc"))) + (setf (slot-value inst 'title) "alternate-test-theme") + (prog1 + (format nil "~a ~a ~a ~a" + (or (select [title] :from [node] + :where [= [title] "test-theme"] + :flatp t :field-names nil) "NIL") + (or (select [vars] :from [setting] + :where [= [vars] "test-vars"] + :flatp t :field-names nil) "NIL") + (or (select [doc] :from [theme] + :where [= [doc] "test-doc"] + :flatp t :field-names nil) "NIL") + (or (select [title] :from [node] + :where [= [title] "alternate-test-theme"] + :flatp t :field-names nil) "NIL")) + (delete-records :from [node] :where [= [title] "alternate-test-theme"]) + (delete-records :from [setting] :where [= [vars] "test-vars"]) + (delete-records :from [theme] :where [= [doc] "test-doc"]))))) + "NIL NIL NIL NIL" + "NIL (test-vars) (test-doc) (alternate-test-theme)") + +(deftest :oodml/setf-slot-value/1 + (with-dataset *ds-employees* + (let* ((*db-auto-sync* t) + (instance (make-instance 'employee :emplid 20 :groupid 1))) + (prog1 + (setf + (slot-value instance 'first-name) "Mikhail" + (slot-value instance 'last-name) "Bulgakov") + (delete-records :from [employee] :where [= [emplid] 20])))) + "Bulgakov") + +(deftest :oodml/float/1 + (with-dataset *ds-employees* + (let* ((emp1 (car (select 'employee + :where [= [slot-value 'employee 'emplid] + 1] + :flatp t + :caching nil))) + (height (slot-value emp1 'height))) + (prog1 + (progn + (setf (slot-value emp1 'height) 1.0E0) + (clsql:update-record-from-slot emp1 'height) + (= (car (clsql:select [height] :from [employee] + :where [= [emplid] 1] + :flatp t + :field-names nil)) + 1)) + (setf (slot-value emp1 'height) height) + (clsql:update-record-from-slot emp1 'height)))) + t) + +(deftest :oodml/float/2 + (with-dataset *ds-employees* + (let* ((emp1 (car (select 'employee + :where [= [slot-value 'employee 'emplid] + 1] + :flatp t + :caching nil))) + (height (slot-value emp1 'height))) + (prog1 + (progn + (setf (slot-value emp1 'height) 1.0S0) + (clsql:update-record-from-slot emp1 'height) + (= (car (clsql:select [height] :from [employee] + :where [= [emplid] 1] + :flatp t + :field-names nil)) + 1)) + (setf (slot-value emp1 'height) height) + (clsql:update-record-from-slot emp1 'height)))) + t) + +(deftest :oodml/float/3 + (with-dataset *ds-employees* + (let* ((emp1 (car (select 'employee + :where [= [slot-value 'employee 'emplid] + 1] + :flatp t + :caching nil))) + (height (slot-value emp1 'height))) + (prog1 + (progn + (setf (slot-value emp1 'height) 1.0F0) + (clsql:update-record-from-slot emp1 'height) + (= (car (clsql:select [height] :from [employee] + :where [= [emplid] 1] + :flatp t + :field-names nil)) + 1)) + (setf (slot-value emp1 'height) height) + (clsql:update-record-from-slot emp1 'height)))) + t) + +(deftest :oodml/float/4 + (with-dataset *ds-employees* + (let* ((emp1 (car (select 'employee + :where [= [slot-value 'employee 'emplid] + 1] + :flatp t + :caching nil))) + (height (slot-value emp1 'height))) + (prog1 + (progn + (setf (slot-value emp1 'height) 1.0D0) + (clsql:update-record-from-slot emp1 'height) + (= (car (clsql:select [height] :from [employee] + :where [= [emplid] 1] + :flatp t + :field-names nil)) + 1)) + (setf (slot-value emp1 'height) height) + (clsql:update-record-from-slot emp1 'height)))) + t) + +(deftest :oodml/float/5 + (with-dataset *ds-employees* + (let* ((emp1 (car (select 'employee + :where [= [slot-value 'employee 'emplid] + 1] + :flatp t + :caching nil))) + (height (slot-value emp1 'height))) + (prog1 + (progn + (setf (slot-value emp1 'height) 1.0L0) + (clsql:update-record-from-slot emp1 'height) + (= (car (clsql:select [height] :from [employee] + :where [= [emplid] 1] + :flatp t + :field-names nil)) + 1)) + (setf (slot-value emp1 'height) height) + (clsql:update-record-from-slot emp1 'height)))) + t) +)) + + diff --git a/tests/test-pool.lisp b/tests/test-pool.lisp new file mode 100644 index 0000000..ef0215b --- /dev/null +++ b/tests/test-pool.lisp @@ -0,0 +1,83 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: test-pool.lisp +;;;; Purpose: Tests for connection pools +;;;; Author: Ryan Davis +;;;; Created: June 27 2011 +;;;; +;;;; This file, part of CLSQL, is Copyright (c) 2004-2010 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-tests) + +;; setup a dummy database for the pool to use +(pushnew :dummy clsql-sys:*loaded-database-types*) +(defclass dummy-database (clsql-sys:database) () + (:default-initargs :database-type :dummy)) +(defmethod clsql-sys:database-connect (connection-spec (database-type (eql :dummy))) + (let ((db (make-instance 'dummy-database :connection-spec connection-spec))) + (setf (slot-value db 'clsql-sys::state) :open) + db)) +(defmethod clsql-sys::database-name-from-spec (connection-spec (database-type (eql :dummy))) + "dummy") +(defmethod clsql-sys::database-acquire-from-conn-pool ((db dummy-database)) T) + +(setq *rt-pool* + '( + (deftest :pool/acquire + (let ((pool (clsql-sys::find-or-create-connection-pool nil :dummy)) + dbx res) + (clsql-sys::clear-conn-pool pool) + (flet ((test-result (x) (push x res))) + (test-result (length (clsql-sys::all-connections pool))) + (test-result (length (clsql-sys::free-connections pool))) + + (clsql-sys:with-database (db nil :database-type :dummy :pool T) + (test-result (not (null db))) + (test-result (length (clsql-sys::all-connections pool))) + (test-result (length (clsql-sys::free-connections pool))) + (setf dbx db)) + (test-result (length (clsql-sys::all-connections pool))) + (test-result (length (clsql-sys::free-connections pool))) + (clsql-sys:with-database (db nil :database-type :dummy :pool T) + (test-result (eq db dbx))) + ) + (nreverse res)) + (0 0 T 1 0 1 1 T) + ) + + (deftest :pool/max-free-connections + (let ((pool (clsql-sys::find-or-create-connection-pool nil :dummy))) + (flet ((run (max-free dbs-to-release) + (let ((clsql-sys:*db-pool-max-free-connections* max-free) + dbs) + (clsql-sys::clear-conn-pool pool) + (dotimes (i dbs-to-release dbs) + (push (clsql-sys:connect nil :database-type :dummy + :pool T :if-exists :new) + dbs)) + (list (length (clsql-sys::all-connections pool)) + (progn + (dolist (db dbs) (clsql-sys:disconnect :database db)) + (length (clsql-sys::free-connections pool)) + ))))) + (append + (run 5 10) + (run nil 10)))) + (10 5 10 10) + ) + + + + (deftest :pool/find-or-create-connection-pool + (let ((p (clsql-sys::find-or-create-connection-pool nil :dummy))) + (values (null p) + (eq p (clsql-sys::find-or-create-connection-pool nil :dummy)) + (eq p (clsql-sys::find-or-create-connection-pool :spec :dummy)))) + nil T nil) + )) diff --git a/tests/test-syntax.lisp b/tests/test-syntax.lisp new file mode 100644 index 0000000..01a7612 --- /dev/null +++ b/tests/test-syntax.lisp @@ -0,0 +1,465 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: clsql.asd +;;;; Purpose: Tests for the CLSQL Symbolic SQL syntax. +;;;; Authors: Marcus Pearce and Kevin M. Rosenberg +;;;; Created: March 2004 +;;;; +;;;; 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-tests) + +(clsql-sys:file-enable-sql-reader-syntax) + + +(setq *rt-syntax* + '( + +(deftest :syntax/generic/1 + (clsql:sql "foo") + "'foo'") + +(deftest :syntax/generic/2 + (clsql:sql 23) + "23") + +(deftest :syntax/generic/3 + (clsql:sql 'bar) + "BAR") + +(deftest :syntax/generic/4 + (clsql:sql '("ten" 10 ten)) + "('ten',10,TEN)") + +(deftest :syntax/generic/5 + (clsql:sql ["SELECT FOO,BAR FROM BAZ"]) + "SELECT FOO,BAR FROM BAZ") + +(deftest :syntax/generic/6 + (clsql:sql "What's up Doc?") + "'What''s up Doc?'") + +(deftest :syntax/ident/1 + (clsql:sql [foo]) + "FOO") + +(deftest :syntax/ident/2 + (clsql:sql [foo bar]) + "FOO.BAR") + +(deftest :syntax/ident/3 + (clsql:sql [foo :integer]) + "FOO") + +(deftest :syntax/ident/4 + (clsql:sql [foo bar :integer]) + "FOO.BAR") + +(deftest :syntax/ident/5 + (clsql:sql [foo "bar"]) + "FOO \"bar\"") + +(deftest :syntax/ident/6 + (clsql:sql ["foo" bar]) + "\"foo\".BAR") + +(deftest :syntax/ident/7 + (clsql:sql ["foo" bar :integer]) + "\"foo\".BAR") + + +(deftest :syntax/attribute/1 + (clsql:sql (clsql:sql-expression :table 'foo :attribute 'bar)) + "FOO.BAR") + +(deftest :syntax/attribute/2 + (clsql:sql (clsql:sql-expression :table 'foo :attribute "bar")) + "FOO.\"bar\"") + +(deftest :syntax/attribute/3 + (clsql:sql (clsql:sql-expression :table "foo" :attribute 'bar)) + "\"foo\".BAR") + +(deftest :syntax/attribute/4 + (clsql:sql (clsql:sql-expression :table "foo" :attribute "bar")) + "\"foo\".\"bar\"") + + +(deftest :syntax/subquery/1 + (clsql:sql [any '(3 4)]) + "ANY((3,4))") + +(deftest :syntax/subquery/2 + (clsql:sql [in [foo] '(foo bar baz)]) + "(FOO IN (FOO,BAR,BAZ))") + +(deftest :syntax/subquery/3 + (clsql:sql [all '(foo bar baz)]) + "ALL((FOO,BAR,BAZ))") + +(deftest :syntax/subquery/4 + (clsql:sql [exists '(foo bar baz)]) + "EXISTS((FOO,BAR,BAZ))") + +(deftest :syntax/subquery/5 + (clsql:sql [some '(foo bar baz)]) + "SOME((FOO,BAR,BAZ))") + + +(deftest :syntax/aggregate/1 + (clsql:sql [max [+ [foo] [* 1000 [bar]]]]) + "MAX((FOO + (1000 * BAR)))") + +(deftest :syntax/aggregate/2 + (clsql:sql [avg [+ [foo] [* 1000 [bar]]]]) + "AVG((FOO + (1000 * BAR)))") + +(deftest :syntax/aggregate/3 + (clsql:sql [min [+ [foo] [* 1000 [bar]]]]) + "MIN((FOO + (1000 * BAR)))") + +(deftest :syntax/aggregate/4 + (clsql:sql [sum [foo] [bar]]) + "SUM(FOO,BAR)") + +(deftest :syntax/aggregate/5 + (clsql:sql [count [foo]]) + "COUNT(FOO)") + + +(deftest :syntax/logical/1 + (values (clsql:sql [and [foo] [bar]]) + (clsql:sql [or [foo] [bar]])) + "(FOO AND BAR)" + "(FOO OR BAR)") + +(deftest :syntax/logical/2 + (clsql:sql [not [foo]]) + "(NOT (FOO))") + +;;; Test how we apply logical operators when we have different numbers of children +;;; This is useful if we wish to (apply #'sql-and some-list) without having to do +;;; alot of length checking +(deftest :syntax/logical/3 + (values (clsql:sql [and ]) + (clsql:sql [and [foo]]) + (clsql:sql [and [not [foo]]]) + (clsql:sql [and [foo] [bar] [baz]])) + "" + "FOO" + "(NOT (FOO))" + "(FOO AND BAR AND BAZ)") + +(deftest :syntax/logical/4 + (clsql:sql [and [= [foo] [bar]]]) + "(FOO = BAR)") + +(deftest :syntax/logical/5 + (clsql:sql [and [= [foo] [bar]] + [= [bar] [bast]] + [= [block] [blech]]]) + "((FOO = BAR) AND (BAR = BAST) AND (BLOCK = BLECH))") + +(deftest :syntax/logical/6 + (clsql:sql + (apply #'sql-and + (list [= [foo] [bar]] + [and ] + [and [= [bar] [bast]]]))) + "((FOO = BAR) AND (BAR = BAST))") + + +(deftest :syntax/null/1 + (clsql:sql [null [foo]]) + "(FOO IS NULL)") + +(deftest :syntax/null/2 + (clsql:sql [not [null [foo]]]) + "(NOT ((FOO IS NULL)))") + +(deftest :syntax/null/3 + (clsql:sql [null]) + "NULL") + +(deftest :syntax/null/4 + (clsql:sql [not [null]]) + "(NOT (NULL))") + +(deftest :syntax/null/5 + (clsql:sql [is [foo.bar] [null]]) + "(FOO.BAR IS NULL)") + +(deftest :syntax/null/6 + (clsql:sql [is [foo.bar] [not-null]]) + "(FOO.BAR IS NOT NULL)") + +(deftest :syntax/null/7 + (clsql:sql [not-null [foo.bar]]) + "(FOO.BAR IS NOT NULL)") + + + +(deftest :syntax/relational/1 + (clsql:sql [> [baz] [beep]]) + "(BAZ > BEEP)") + +(deftest :syntax/relational/2 + (let ((x 10)) + (clsql:sql [> [foo] x])) + "(FOO > 10)") + +(deftest :syntax/relational/3 + (clsql:sql [>= [baz] [beep]]) + "(BAZ >= BEEP)") + +(deftest :syntax/relational/4 + (clsql:sql [< [baz] [beep]]) + "(BAZ < BEEP)") + +(deftest :syntax/relational/5 + (clsql:sql [= [baz] [beep]]) + "(BAZ = BEEP)") + +(deftest :syntax/relational/6 + (clsql:sql [<> [baz] [beep]]) + "(BAZ <> BEEP)") + + +(deftest :syntax/between/1 + (clsql:sql [between [- [foo] 1] [* [bar] 5] [/ [baz] 9]]) + "(FOO - 1) BETWEEN (BAR * 5) AND (BAZ / 9)") + +(deftest :syntax/between/2 + (clsql:sql [not [between [- [foo] 1] [* [bar] 5] [/ [baz] 9]]]) + "(NOT ((FOO - 1) BETWEEN (BAR * 5) AND (BAZ / 9)))") + + +(deftest :syntax/arithmetic/1 + (clsql:sql [+ [foo bar] [baz]]) + "(FOO.BAR + BAZ)") + +(deftest :syntax/arithmetic/2 + (clsql:sql [- [foo bar] [baz]]) + "(FOO.BAR - BAZ)") + +(deftest :syntax/arithmetic/3 + (clsql:sql [/ [foo bar] [baz]]) + "(FOO.BAR / BAZ)") + +(deftest :syntax/arithmetic/4 + (clsql:sql [* [foo bar] [baz]]) + "(FOO.BAR * BAZ)") + +(deftest :syntax/arithmetic/5 + (clsql:sql [- [foo bar]]) + "(- (FOO.BAR))") + +(deftest :syntax/arithmetic/6 + (clsql:sql [* 2 3]) + "(2 * 3)") + + +(deftest :syntax/substr/1 + (clsql:sql [substr [hello] 1 4]) + "SUBSTR(HELLO,1,4)") + +(deftest :syntax/substring/1 + (clsql:sql [substring [hello] 1 4]) + "SUBSTRING(HELLO,1,4)") + + +(deftest :syntax/concat/1 + (clsql:sql [|| [foo] [bar] [baz]]) + "(FOO || BAR || BAZ)") + +(deftest :syntax/concat/2 + (clsql:sql [concat [foo] [bar]]) + "CONCAT(FOO,BAR)") + + +(deftest :syntax/pattern/1 + (clsql:sql [like [foo] "%v"]) + "(FOO LIKE '%v')") + +(deftest :syntax/pattern/2 + (clsql:sql [not [like [foo] "%v"]]) + "(NOT ((FOO LIKE '%v')))") + + +(deftest :syntax/distinct/1 + (clsql:sql [distinct [foo bar :string]]) + "DISTINCT FOO.BAR") + +(deftest :syntax/distinct/2 + (clsql:sql [distinct [foo :string] [bar :integer]]) + "DISTINCT FOO, BAR") + + +(deftest :syntax/order-by/1 + (clsql:sql [order-by [foo]]) + "ORDER BY FOO") + +(deftest :syntax/group-by/1 + (clsql:sql [group-by [foo]]) + "GROUP BY FOO") + +(deftest :syntax/group-by/2 + (clsql:sql + (clsql-sys::make-query [foo] [bar] [count [foo]] + :from [table] + :group-by '([foo] [bar]) + :order-by '([foo] [bar]))) + "SELECT FOO,BAR,COUNT(FOO) FROM TABLE GROUP BY FOO,BAR ORDER BY FOO,BAR") + + +(deftest :syntax/coalesce/1 + (clsql:sql [coalesce [foo] [bar] "not specified"]) + "COALESCE(FOO,BAR,'not specified')") + +(deftest :syntax/coalesce/2 + (clsql:sql [nvl [foo] "not specified"]) + "COALESCE(FOO,'not specified')") + +(deftest :syntax/nvl/1 + (clsql:sql [nvl [foo] "not specified"]) + "COALESCE(FOO,'not specified')") + + + +(deftest :syntax/sets/1 + (clsql:sql [union [select [foo] :from [bar]] [select [baz] :from [bar]]]) + "SELECT FOO FROM BAR UNION SELECT BAZ FROM BAR") + +(deftest :syntax/sets/2 + (clsql:sql [intersect [select [foo] :from [bar]] [select [baz] :from [bar]]]) + "SELECT FOO FROM BAR INTERSECT SELECT BAZ FROM BAR") + +(deftest :syntax/sets/3 + (clsql:sql [except [select [foo] :from [bar]] [select [baz] :from [bar]]]) + "SELECT FOO FROM BAR EXCEPT SELECT BAZ FROM BAR") + +(deftest :syntax/sets/4 + (clsql:sql [minus [select [foo] :from [bar]] [select [baz] :from [bar]]]) + "SELECT FOO FROM BAR MINUS SELECT BAZ FROM BAR") + + +(deftest :syntax/function/1 + (clsql:sql [function "COS" [age]]) + "COS(AGE)") + +(deftest :syntax/function/2 + (clsql:sql [function "TO_DATE" "02/06/99" "mm/DD/RR"]) + "TO_DATE('02/06/99','mm/DD/RR')") + + +(deftest :syntax/query/1 + (clsql:sql [select [person_id] [surname] :from [person]]) + "SELECT PERSON_ID,SURNAME FROM PERSON") + +(deftest :syntax/query/2 + (clsql:sql [select [foo] [bar *] + :from '([baz] [bar]) + :where [or [= [foo] 3] + [> [baz.quux] 10]]]) + "SELECT FOO,BAR.* FROM BAZ,BAR WHERE ((FOO = 3) OR (BAZ.QUUX > 10))") + +(deftest :syntax/query/3 + (clsql:sql [select [foo bar] [baz] + :from '([foo] [quux]) + :where [or [> [baz] 3] + [like [foo bar] "SU%"]]]) + "SELECT FOO.BAR,BAZ FROM FOO,QUUX WHERE ((BAZ > 3) OR (FOO.BAR LIKE 'SU%'))") + +(deftest :syntax/query/4 + (clsql:sql [select [count [*]] :from [emp]]) + "SELECT COUNT(*) FROM EMP") + + +(deftest :syntax/expression/1 + (clsql:sql + (clsql:sql-operation + 'select + (clsql:sql-expression :table 'foo :attribute 'bar) + (clsql:sql-expression :attribute 'baz) + :from (list + (clsql:sql-expression :table 'foo) + (clsql:sql-expression :table 'quux)) + :where + (clsql:sql-operation 'or + (clsql:sql-operation + '> + (clsql:sql-expression :attribute 'baz) + 3) + (clsql:sql-operation + 'like + (clsql:sql-expression :table 'foo + :attribute 'bar) + "SU%")))) + "SELECT FOO.BAR,BAZ FROM FOO,QUUX WHERE ((BAZ > 3) OR (FOO.BAR LIKE 'SU%'))") + +(deftest :syntax/expression/2 + (clsql:sql + (apply (clsql:sql-operator 'and) + (loop for table in '(thistime nexttime sometime never) + for count from 42 + collect + [function "BETWEEN" + (clsql:sql-expression :table table + :attribute 'bar) + (clsql:sql-operation '* [hip] [hop]) + count] + collect + [like (clsql:sql-expression :table table + :attribute 'baz) + (clsql:sql table)]))) + "(BETWEEN(THISTIME.BAR,(HIP * HOP),42) AND (THISTIME.BAZ LIKE 'THISTIME') AND BETWEEN(NEXTTIME.BAR,(HIP * HOP),43) AND (NEXTTIME.BAZ LIKE 'NEXTTIME') AND BETWEEN(SOMETIME.BAR,(HIP * HOP),44) AND (SOMETIME.BAZ LIKE 'SOMETIME') AND BETWEEN(NEVER.BAR,(HIP * HOP),45) AND (NEVER.BAZ LIKE 'NEVER'))" + ) + +(deftest :syntax/subqueries/query + (clsql:sql + (clsql:sql-operation 'select [*] + :from [foo] + :where [in [id] [select [id] :from [bar]]])) + "SELECT * FROM FOO WHERE (ID IN (SELECT ID FROM BAR))") + +(deftest :syntax/subqueries/delete + (clsql:sql + (make-instance 'clsql-sys::sql-delete + :from [foo] + :where [in [id] [select [id] :from [bar]]])) + "DELETE FROM FOO WHERE (ID IN (SELECT ID FROM BAR))") + +(deftest :syntax/subqueries/update + (clsql:sql + (make-instance 'clsql-sys::sql-update + :attributes (list [id]) + :values '(0) + :table [foo] + :where [in [id] [select [id] :from [bar]]])) + "UPDATE FOO SET ID = 0 WHERE (ID IN (SELECT ID FROM BAR))") + + )) + +(let ((tests '(((:foo) "FOO") + ((:foo-bar) "FOO_BAR") + (("foo") "\"foo\"") + (('|foo bar|) "\"foo bar\"") + ((:foo :table-alias :bar) "FOO BAR" ) + ((:foo_bar :table-alias :bar-bast) "FOO_BAR BAR_BAST") + (("foo" :table-alias "Bar") "\"foo\" \"Bar\"") + (('|foo bar| :table-alias :bast) "\"foo bar\" BAST")))) + + (push + `(deftest :syntax/sql-ident-table + (values ,@(mapcar + #'(lambda (args) + `(clsql:sql (make-instance 'clsql-sys:sql-ident-table + :name ,@args))) + (mapcar #'first tests))) + ,@(mapcar #'second tests)) + *rt-syntax*)) diff --git a/tests/test-time.lisp b/tests/test-time.lisp new file mode 100644 index 0000000..e5b4d64 --- /dev/null +++ b/tests/test-time.lisp @@ -0,0 +1,466 @@ +;;; -*- Mode: Lisp -*- +;;; +;;; Copyright (c) 2000, 2001 onShore Development, Inc. +;;; +;;; Test time functions (time.lisp) + +(in-package #:clsql-tests) +(clsql-sys:file-enable-sql-reader-syntax) + +(def-view-class datetest () + ((id :column "id" + :type integer + :db-kind :key + :db-constraints (:not-null :unique) + :accessor id :initarg :id + :initform nil + :db-type "int4") + (testtimetz :column "testtimetz" + :type clsql-sys:wall-time + :db-kind :base + :db-constraints nil + :accessor testtimetz :initarg :testtimetz + :initform nil + :db-type "timestamp with time zone") + (testtime :column "testtime" + :type clsql-sys:wall-time + :db-kind :base + :db-constraints nil + :accessor testtime :initarg :testtime + :initform nil + :db-type "timestamp without time zone"))) + +(def-dataset *ds-datetest* + (:setup (lambda () (clsql-sys:create-view-from-class 'datetest))) + (:cleanup "DROP TABLE datetest")) + + +(def-dataset *cross-platform-datetest* + (:setup (lambda () (create-table [datetest] + '(([testtime] wall-time))))) + (:cleanup (lambda () + (drop-table [datetest])))) + + +(setq *rt-time* + '( + +;; we use parse timestring a lot through here verifying other things +;; start off just checking that. +(deftest :time/iso-parse/0 + (let* ((time1 (parse-timestring "2010-01-23"))) + (decode-time time1)) + 0 0 0 0 23 1 2010 6) + +(deftest :time/iso-parse/1 + (let* ((time1 (parse-timestring "2010-01-23T14:56:32Z"))) + (decode-time time1)) + 0 32 56 14 23 1 2010 6) + +(deftest :time/iso-parse/2 + (let* ((time1 (parse-timestring "2008-02-29 12:46:32"))) + (decode-time time1)) + 0 32 46 12 29 2 2008 5) + +(deftest :time/iso-parse/3 + (let* ((time1 (parse-timestring "2010-01-23 14:56:32.44"))) + (decode-time time1)) + 440000 32 56 14 23 1 2010 6) + +(deftest :time/iso-parse/4 + (let* ((time1 (parse-timestring "2010-01-23 14:56:32.0044"))) + (decode-time time1)) + 4400 32 56 14 23 1 2010 6) + +(deftest :time/iso-parse/5 + (let* ((time1 (parse-timestring "2010-01-23 14:56:32.000003"))) + (decode-time time1)) + 3 32 56 14 23 1 2010 6) + +(deftest :time/print-parse/1 + ;;make sure when we print and parse we get the same time. + (let* ((time (clsql-sys:make-time :year 2010 :month 1 :day 4 + :hour 14 :minute 15 :second 44)) + (string-time (iso-timestring time)) + (time2 (parse-timestring string-time))) + (decode-time time2)) + 0 44 15 14 4 1 2010 1) + +(deftest :time/print-parse/2 + ;;make sure when we print and parse we get the same time. + (let* ((time (clsql-sys:make-time :year 2010 :month 1 :day 4 + :hour 14 :minute 15 :second 44 :usec 3)) + (string-time (iso-timestring time)) + (time2 (parse-timestring string-time))) + (decode-time time2)) + 3 44 15 14 4 1 2010 1) + + +;; relations of intervals +(deftest :time/1 + (let* ((time-1 (clsql:parse-timestring "2002-01-01 10:00:00")) + (time-2 (clsql:parse-timestring "2002-01-01 11:00:00")) + (time-3 (clsql:parse-timestring "2002-01-01 12:00:00")) + (time-4 (clsql:parse-timestring "2002-01-01 13:00:00")) + (interval-1 (clsql:make-interval :start time-1 :end time-2)) + (interval-2 (clsql:make-interval :start time-2 :end time-3)) + (interval-3 (clsql:make-interval :start time-3 :end time-4)) + (interval-4 (clsql:make-interval :start time-1 :end time-3)) + (interval-5 (clsql:make-interval :start time-2 :end time-4)) + (interval-6 (clsql:make-interval :start time-1 :end time-4))) + (flet ((my-assert (number relation i1 i2) + (declare (ignore number)) + (let ((found-relation (clsql:interval-relation i1 i2))) + (equal relation found-relation)))) + (and + (my-assert 1 :contains interval-1 interval-1) + (my-assert 2 :precedes interval-1 interval-2) + (my-assert 3 :precedes interval-1 interval-3) + (my-assert 4 :contained interval-1 interval-4) + (my-assert 5 :precedes interval-1 interval-5) + (my-assert 6 :contained interval-1 interval-6) + (my-assert 7 :follows interval-2 interval-1) + (my-assert 8 :contains interval-2 interval-2) + (my-assert 9 :precedes interval-2 interval-3) + (my-assert 10 :contained interval-2 interval-4) + (my-assert 11 :contained interval-2 interval-5) + (my-assert 12 :contained interval-2 interval-6) + (my-assert 13 :follows interval-3 interval-1) + (my-assert 14 :follows interval-3 interval-2) + (my-assert 15 :contains interval-3 interval-3) + (my-assert 16 :follows interval-3 interval-4) + (my-assert 17 :contained interval-3 interval-5) + (my-assert 18 :contained interval-3 interval-6) + (my-assert 19 :contains interval-4 interval-1) + (my-assert 20 :contains interval-4 interval-2) + (my-assert 21 :precedes interval-4 interval-3) + (my-assert 22 :contains interval-4 interval-4) + (my-assert 23 :overlaps interval-4 interval-5) + (my-assert 24 :contained interval-4 interval-6) + (my-assert 25 :follows interval-5 interval-1) + (my-assert 26 :contains interval-5 interval-2) + (my-assert 27 :contains interval-5 interval-3) + (my-assert 28 :overlaps interval-5 interval-4) + (my-assert 29 :contains interval-5 interval-5) + (my-assert 30 :contained interval-5 interval-6) + (my-assert 31 :contains interval-6 interval-1) + (my-assert 32 :contains interval-6 interval-2) + (my-assert 33 :contains interval-6 interval-3) + (my-assert 34 :contains interval-6 interval-4) + (my-assert 35 :contains interval-6 interval-5) + (my-assert 36 :contains interval-6 interval-6)))) + t) + +;; adjacent intervals in list +(deftest :time/2 + (let* ((interval-list nil) + (time-1 (clsql:parse-timestring "2002-01-01 10:00:00")) + (time-3 (clsql:parse-timestring "2002-01-01 12:00:00")) + (time-4 (clsql:parse-timestring "2002-01-01 13:00:00"))) + (setf interval-list + (clsql:interval-push interval-list (clsql:make-interval :start time-1 :end time-3 + :type :open))) + (setf interval-list + (clsql:interval-push interval-list (clsql:make-interval :start time-3 :end time-4 + :type :open))) + (clsql:interval-relation (car interval-list) (cadr interval-list))) + :precedes) + +;; nested intervals in list +(deftest :time/3 + (let* ((interval-list nil) + (time-1 (clsql:parse-timestring "2002-01-01 10:00:00")) + (time-2 (clsql:parse-timestring "2002-01-01 11:00:00")) + (time-3 (clsql:parse-timestring "2002-01-01 12:00:00")) + (time-4 (clsql:parse-timestring "2002-01-01 13:00:00"))) + (setf interval-list + (clsql:interval-push interval-list (clsql:make-interval :start time-1 + :end time-4 + :type :open))) + (setf interval-list + (clsql:interval-push interval-list (clsql:make-interval :start time-2 + :end time-3 + :type :closed))) + (let* ((interval (car interval-list)) + (interval-contained + (when interval (car (clsql:interval-contained interval))))) + (when (and interval interval-contained) + (and (clsql:time= (clsql:interval-start interval) time-1) + (clsql:time= (clsql:interval-end interval) time-4) + (eq (clsql:interval-type interval) :open) + (clsql:time= (clsql:interval-start interval-contained) time-2) + (clsql:time= (clsql:interval-end interval-contained) time-3) + (eq (clsql:interval-type interval-contained) :closed))))) + t) + +;; interval-edit - nonoverlapping +(deftest :time/4 + (let* ((interval-list nil) + (time-1 (clsql:parse-timestring "2002-01-01 10:00:00")) + (time-2 (clsql:parse-timestring "2002-01-01 11:00:00")) + (time-3 (clsql:parse-timestring "2002-01-01 12:00:00")) + (time-4 (clsql:parse-timestring "2002-01-01 13:00:00"))) + (setf interval-list (clsql:interval-push interval-list (clsql:make-interval :start time-1 :end time-2 :type :open))) + (setf interval-list (clsql:interval-push interval-list (clsql:make-interval :start time-3 :end time-4 :type :closed))) + (setf interval-list (clsql:interval-edit interval-list time-1 time-1 time-3)) + ;; should be time-3 not time-2 + (clsql:time= (clsql:interval-end (car interval-list)) time-3)) + t) + +;; interval-edit - overlapping +(deftest :time/5 + (let* ((interval-list nil) + (time-1 (clsql:parse-timestring "2002-01-01 10:00:00")) + (time-2 (clsql:parse-timestring "2002-01-01 11:00:00")) + (time-3 (clsql:parse-timestring "2002-01-01 12:00:00")) + (time-4 (clsql:parse-timestring "2002-01-01 13:00:00"))) + (setf interval-list (clsql:interval-push interval-list (clsql:make-interval :start time-1 :end time-2 :type :open))) + (setf interval-list (clsql:interval-push interval-list (clsql:make-interval :start time-2 :end time-4 :type :closed))) + (let ((pass t)) + (handler-case + (progn + (setf interval-list + (clsql:interval-edit interval-list time-1 time-1 time-3)) + (setf pass nil)) + (error nil)) + pass)) + t) + +;; interval-edit - nested intervals in list +(deftest :time/6 + (let* ((interval-list nil) + (time-1 (clsql:parse-timestring "2002-01-01 10:00:00")) + (time-2 (clsql:parse-timestring "2002-01-01 11:00:00")) + (time-3 (clsql:parse-timestring "2002-01-01 12:00:00")) + (time-4 (clsql:parse-timestring "2002-01-01 13:00:00")) + (time-5 (clsql:parse-timestring "2002-01-01 14:00:00")) + (time-6 (clsql:parse-timestring "2002-01-01 15:00:00"))) + (setf interval-list (clsql:interval-push interval-list (clsql:make-interval :start time-1 :end time-6 :type :open))) + (setf interval-list (clsql:interval-push interval-list (clsql:make-interval :start time-2 :end time-3 :type :closed))) + (setf interval-list (clsql:interval-push interval-list (clsql:make-interval :start time-4 :end time-5 :type :closed))) + (setf interval-list (clsql:interval-edit interval-list time-1 time-1 time-4)) + ;; should be time-4 not time-6 + (clsql:time= (clsql:interval-end (car interval-list)) time-4)) + t) + +;; Test the boundaries of Local Time with granularity of 1 year +(deftest :time/7 + (let ((sec-in-year (* 60 60 24 365)) + (year (clsql:time-element (clsql:make-time) :year))) + (dotimes (n 50 n) + (let ((date (clsql:make-time :second (* n sec-in-year)))) + (unless (= (+ year n) + (clsql:time-element date :year)) + (return n))))) + 50) + +;; Test db-timestring +(deftest :time/9 + (flet ((grab-year (dbstring) + (parse-integer (subseq dbstring 1 5)))) + (let ((second-in-year (* 60 60 24 365))) + (dotimes (n 2000 n) + (let* ((second (* -1 n second-in-year)) + (date (clsql:make-time :year 2525 :second second))) + (unless + (= (grab-year (clsql:db-timestring date)) + (clsql:time-element date :year)) + (return n)))))) + 2000) + +;; Conversion between MJD and Gregorian +(deftest :time/10 + (dotimes (base 10000 base) + (unless (= (apply #'clsql:gregorian-to-mjd (clsql:mjd-to-gregorian base)) + base) + (return base))) + 10000) + +;; Clsql:Roll by minutes: +90 +(deftest :time/11 + (let ((now (clsql:get-time))) + (clsql:time= (clsql:time+ now (clsql:make-duration :minute 90)) + (clsql:roll now :minute 90))) + t) + +;;Clsql:Roll by minutes: +900 +(deftest :time/12 + (let ((now (clsql:get-time))) + (clsql:time= (clsql:time+ now (clsql:make-duration :minute 900)) + (clsql:roll now :minute 900))) + t) + + +;; Clsql:Roll by minutes: +900 +(deftest :time/13 + (let* ((now (clsql:get-time)) + (add-time (clsql:time+ now (clsql:make-duration :minute 9000))) + (roll-time (clsql:roll now :minute 9000))) + (clsql:time= add-time roll-time)) + t) + + + +;;; The cross platform dataset uses the 'timestamp' column type which is +;;; in sql-92, for all that means. + +(deftest :time/cross-platform/no-usec/no-tz + (with-dataset *cross-platform-datetest* + (let ((time (parse-timestring "2008-09-09T14:37:29"))) + (clsql-sys:insert-records :into [datetest] + :attributes '([testtime]) + :values (list time)) + (let ((testtime + (first (clsql:select [testtime] + :from [datetest] :flatp t + :where [= [testtime] time] )))) + (format-time nil (parse-timestring testtime) :format :iso) + ))) + #.(format-time nil (parse-timestring "2008-09-09T14:37:29") :format :iso)) + +(deftest :time/cross-platform/no-usec/tz + (with-dataset *cross-platform-datetest* + (let ((time (parse-timestring "2008-09-09T14:37:29-04:00"))) + (clsql-sys:insert-records :into [datetest] + :attributes '([testtime]) + :values (list time)) + (let ((testtime + (first (clsql:select [testtime] + :from [datetest] :flatp t + :where [= [testtime] time] )))) + (format-time nil (parse-timestring testtime) :format :iso) + ))) + #.(format-time nil (parse-timestring "2008-09-09T14:37:29-04:00") :format :iso)) + +;;;This test gets at the databases that only support miliseconds, +;;; not microseconds. +(deftest :time/cross-platform/msec + (with-dataset *cross-platform-datetest* + (let ((time (parse-timestring "2008-09-09T14:37:29.423"))) + (clsql-sys:insert-records :into [datetest] + :attributes '([testtime]) + :values (list time)) + (let ((testtime + (first (clsql:select [testtime] + :from [datetest] :flatp t + :where [= [testtime] time] )))) + (format-time nil (parse-timestring testtime) :format :iso) + ))) + #.(format-time nil (parse-timestring "2008-09-09T14:37:29.423") :format :iso)) + +(deftest :time/cross-platform/usec/no-tz + (with-dataset *cross-platform-datetest* + (let ((time (parse-timestring "2008-09-09T14:37:29.000213"))) + (clsql-sys:insert-records :into [datetest] + :attributes '([testtime]) + :values (list time)) + (let ((testtime + (first (clsql:select [testtime] + :from [datetest] :flatp t + :where [= [testtime] time] )))) + (format-time nil (parse-timestring testtime) :format :iso) + ))) + #.(format-time nil (parse-timestring "2008-09-09T14:37:29.000213") :format :iso)) + +(deftest :time/cross-platform/usec/tz + (with-dataset *cross-platform-datetest* + (let ((time (parse-timestring "2008-09-09T14:37:29.000213-04:00"))) + (clsql-sys:insert-records :into [datetest] + :attributes '([testtime]) + :values (list time)) + (let ((testtime + (first (clsql:select [testtime] + :from [datetest] + :limit 1 :flatp t + :where [= [testtime] time] )))) + (format-time nil (parse-timestring testtime) :format :iso) + ))) + #.(format-time nil (parse-timestring "2008-09-09T14:37:29.000213-04:00") :format :iso)) + + + + +;;; All odbc databases use local times exclusively (they do not send timezone info) +;;; Postgresql can use timezones, except when being used over odbc. This test when +;;; run through both postgres socket and postgres odbc should test a fairly +;;; broad swath of available problem space +;;; +;;; Things the following tests try to prove correct +;;; * Reading and writing usec and usec-less times +;;; * reading and writing timezones (Z=utc) when appropriate (eg: postgresql-socket) +;;; * reading and writing localtimes when appropriate (eg: ODBC) +;;; * reading and writing through both the oodml and fdml layers + + + +(deftest :time/pg/fdml/usec + (with-dataset *ds-datetest* + (let ((time (parse-timestring "2008-09-09T14:37:29.000213-04:00"))) + (clsql-sys:insert-records :into [datetest] + :attributes '([testtimetz] [testtime] [id]) + :values (list time time 1)) + (destructuring-bind (testtimetz testtime) + (first (clsql:select [testtimetz] [testtime] + :from [datetest] + :limit 1 :flatp t + :where [= [testtime] time] )) + (values (iso-timestring (parse-timestring testtime)) + (iso-timestring (parse-timestring testtimetz)))))) + #.(iso-timestring (parse-timestring "2008-09-09T14:37:29.000213-04:00")) + #.(iso-timestring (parse-timestring "2008-09-09T14:37:29.000213-04:00"))) + +(deftest :time/pg/oodml/no-usec + (with-dataset *ds-datetest* + (let ((time (parse-timestring "2008-09-09T14:37:29-04:00"))) + (clsql-sys:update-records-from-instance + (make-instance 'datetest :testtimetz time :testtime time :id 1)) + (let ((o (first (clsql:select + 'datetest + :limit 1 :flatp t + :where [= [testtime] time] )))) + (assert o (o) "o shouldnt be null here (we should have just inserted)") + (update-records-from-instance o) + (update-instance-from-records o) + (values (iso-timestring (testtime o)) + (iso-timestring (testtimetz o)))))) + #.(iso-timestring (parse-timestring "2008-09-09T14:37:29-04:00")) + #.(iso-timestring (parse-timestring "2008-09-09T14:37:29-04:00"))) + +(deftest :time/pg/oodml/usec + (with-dataset *ds-datetest* + (let ((time (parse-timestring "2008-09-09T14:37:29.000278-04:00"))) + (clsql-sys:update-records-from-instance + (make-instance 'datetest :testtimetz time :testtime time :id 1)) + (let ((o (first (clsql:select + 'datetest + :limit 1 :flatp t + :where [= [testtime] time] )))) + (assert o (o) "o shouldnt be null here (we should have just inserted)") + (update-records-from-instance o) + (update-instance-from-records o) + (values (iso-timestring (testtime o)) + (iso-timestring (testtimetz o))) + ))) + #.(iso-timestring (parse-timestring "2008-09-09T14:37:29.000278-04:00")) + #.(iso-timestring (parse-timestring "2008-09-09T14:37:29.000278-04:00"))) + +(deftest :time/historic-datetimes + (with-dataset *cross-platform-datetest* + (let ((time (parse-timestring "1800-09-09T14:37:29"))) + (clsql-sys:insert-records :into [datetest] + :attributes '([testtime]) + :values (list time)) + (let ((testtime + (first (clsql:select [testtime] + :from [datetest] :flatp t + :where [= [testtime] time] )))) + (format-time nil (parse-timestring testtime) :format :iso) + ))) + #.(format-time nil (parse-timestring "1800-09-09T14:37:29") :format :iso)) + +)) + + + + + diff --git a/tests/utils.lisp b/tests/utils.lisp new file mode 100644 index 0000000..396e303 --- /dev/null +++ b/tests/utils.lisp @@ -0,0 +1,100 @@ +;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: utils.lisp +;;;; Purpose: Classes and utilities for testing +;;;; Author: Kevin M. Rosenberg +;;;; Created: Mar 2002 +;;;; +;;;; This file, part of CLSQL, is Copyright (c) 2002-2010 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-tests) + +(defun %get-int (v) + (etypecase v + (string (parse-integer v :junk-allowed t)) + (integer v) + (number (truncate v)))) + +(defvar *config-pathname* + (make-pathname :defaults (user-homedir-pathname) + :name ".clsql-test" + :type "config")) + +(defvar +all-db-types+ + '(:postgresql :postgresql-socket :postgresql-socket3 :mysql :sqlite :sqlite3 :odbc :oracle + #+allegro :aodbc)) + +(defclass conn-specs () + ((aodbc :accessor aodbc-spec :initform nil) + (mysql :accessor mysql-spec :initform nil) + (postgresql :accessor postgresql-spec :initform nil) + (postgresql-socket :accessor postgresql-socket-spec :initform nil) + (postgresql-socket3 :accessor postgresql-socket3-spec :initform nil) + (sqlite :accessor sqlite-spec :initform nil) + (sqlite3 :accessor sqlite3-spec :initform nil) + (odbc :accessor odbc-spec :initform nil) + (oracle :accessor oracle-spec :initform nil)) + (:documentation "Connection specs for CLSQL testing")) + + +(defun read-specs (&optional (path *config-pathname*)) + (if (probe-file path) + (with-open-file (stream path :direction :input) + (let ((specs (make-instance 'conn-specs))) + (dolist (spec (read stream) specs) + (push (second spec) + (slot-value specs (intern (symbol-name (first spec)) + (find-package '#:clsql-tests))))))) + (progn + (warn "CLSQL test config file ~S not found" path) + nil))) + +(defun spec-fn (db-type) + (intern (concatenate 'string (symbol-name db-type) + (symbol-name '#:-spec)) + (find-package '#:clsql-tests))) + +(defun db-type-spec (db-type specs) + (funcall (spec-fn db-type) specs)) + + +(defun summarize-test-report (sexp &optional (output *standard-output*)) + (flet ((db-title (db-type underlying-db-type) + (format nil "~A~A" + db-type + (if (eq db-type underlying-db-type) + "" + (format nil "/~A" underlying-db-type))))) + (with-open-file (in sexp :direction :input) + (let ((eof (cons nil nil))) + (do ((form (read in nil eof) (read in nil eof))) + ((eq form eof)) + (destructuring-bind (db-type + underlying-db-type + utime + total-tests + failed-tests + impl-type + impl-version + machine-type) + form + (declare (ignorable utime impl-version)) + (if failed-tests + (format output "~&~A: ~D of ~D tests failed (~A, ~A).~&" + (db-title db-type underlying-db-type) + (length failed-tests) + total-tests + machine-type + impl-type) + (format output "~&~A: All ~D tests passed (~A, ~A).~%" + (db-title db-type underlying-db-type) + total-tests + machine-type + impl-type)))))))) diff --git a/uffi/Makefile b/uffi/Makefile new file mode 100644 index 0000000..7599380 --- /dev/null +++ b/uffi/Makefile @@ -0,0 +1,77 @@ +#!/usr/bin/make +# FILE IDENTIFICATION +# +# Name: Makefile +# Purpose: Makefile for CLSQL UFFI interface +# Programer: Kevin M. Rosenberg +# Date Started: Mar 2002 +# +# This file, part of CLSQL, is Copyright (c) 2002-2006 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. + +SUBDIRS= + +include ../Makefile.common + +base=clsql_uffi +source=$(base).c +object=$(base).o +shared_lib=$(base).so +shared64_lib=$(base)64.so +dylib=$(base).dylib + +ifneq ($(OS_DPKG_BUILDFLAGS),0) + CFLAGS:=$(CFLAGS) $(shell dpkg-buildflags --get CFLAGS) + LDFLAGS:=$(LDFLAGS) $(shell DEB_BUILD_MAINT_OPTIONS=hardening=+all,-pie dpkg-buildflags --get LDFLAGS | sed "s/-Wl\|,/ /ig") +endif + + +.PHONY: all +all: $(shared_lib) + +$(shared_lib): $(source) Makefile +ifneq ($(OS_AIX),0) + gcc -c -D_BSD -D_NO_PROTO -D_NONSTD_TYPES -D_MBI=void $(source) + make_shared -o $(shared_lib) $(object) +else + ifneq ($(OS_SUNOS),0) + cc -KPIC -c $(source) -o $(object) + cc -G $(object) -o $(shared_lib) + else + ifneq ($(OS_DARWIN64),0) + cc -arch x86_64 -arch i386 -bundle /usr/lib/bundle1.o -flat_namespace -undefined suppress $(source) -o $(dylib) + cc -arch x86_64 -arch i386 -bundle /usr/lib/bundle1.o -flat_namespace -undefined suppress /usr/lib/libz.dylib -o z.dylib + else + ifneq ($(OS_DARWIN),0) + cc -arch i386 -bundle /usr/lib/bundle1.o -flat_namespace -undefined suppress $(source) -o $(dylib) + cc -arch i386 -bundle /usr/lib/bundle1.o -flat_namespace -undefined suppress /usr/lib/libz.dylib -o z.dylib + else + ifneq ($(OS_CYGWIN),0) + gcc -c $(source) -o $(object) + ld -shared -soname=$(base) $(LDFLAGS) $(object) -o $(shared_lib) + else + ifneq ($(OS_LINUX64),0) + gcc $(CFLAGS) -fPIC -DPIC -c $(source) -o $(object) + gcc $(LDFLAGS) -fPIC -shared -Wl,-soname=$(base) -lc $(object) -o $(shared64_lib) + rm -f $(object) + @echo "Ensure that you have multiarch i386 build tools if you want to build 32-bit library" + -gcc -m32 $(CFLAGS) -fPIC -DPIC -c $(source) -o $(object) + -gcc -m32 $(LDFLAGS) -fPIC -shared -Wl,-soname=$(base) -lc $(object) -o $(shared_lib) + else + gcc -fPIC -DPIC -c $(source) -o $(object) + ld -shared -soname=$(base) -lc $(object) -o $(shared_lib) + endif + endif + endif + endif +endif +endif + rm -f $(object) + + +.PHONY: distclean +distclean: clean + @rm -f $(dylib) $(shared_lib) $(shared64_lib) $(object) z.dylib diff --git a/uffi/Makefile.32+64bits b/uffi/Makefile.32+64bits new file mode 100644 index 0000000..68d9743 --- /dev/null +++ b/uffi/Makefile.32+64bits @@ -0,0 +1,100 @@ +#!/usr/bin/make +########################################################################## +# FILE IDENTIFICATION +# +# Name: Makefile +# Purpose: Makefile for CLSQL UFFI interface +# Programer: Kevin M. Rosenberg +# Date Started: Mar 2002 +# +# This file, part of CLSQL, is Copyright (c) 2002-2010 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. +########################################################################## + + +SUBDIRS= + +include ../Makefile.common + +PTRBITS:=$(shell gcc -o ptrbits ptrbits.c && ./ptrbits) + +base:=clsql_uffi +basebits:=$(base) +ifeq ($(PTRBITS),64) + basebits:=$(base)64 +endif + +source=$(base).c +object=$(basebits).o +shared_lib=$(basebits).so +shared_lib32=$(base)32.so +object32=$(base)32.o + +.PHONY: all +ifeq ($(PTRBITS),64) + all: $(shared_lib) $(shared_lib32) +else + all: $(shared_lib) +endif + +$(shared_lib): $(source) Makefile +ifneq ($(OS_AIX),0) + gcc -c -D_BSD -D_NO_PROTO -D_NONSTD_TYPES -D_MBI=void $(source) + make_shared -o $(shared_lib) $(object) +else + ifneq ($(OS_SUNOS),0) + cc -KPIC -c $(source) -o $(object) + cc -G $(object) -o $(shared_lib) + else + ifneq ($(OS_DARWIN),0) + cc -dynamic -c $(source) -o $(object) + ld -bundle /usr/lib/bundle1.o -flat_namespace -undefined suppress -o $(base).dylib $(object) + ld -bundle /usr/lib/bundle1.o -flat_namespace -undefined suppress /usr/lib/libz.dylib -o z.dylib + else + ifneq ($(OS_CYGWIN),0) + gcc -c $(source) -o $(object) + ld -shared -soname=$(base) $(LDFLAGS) $(object) -o $(shared_lib) + else + gcc -fPIC -DPIC -c $(source) -o $(object) + ld -shared -soname=$(base) -lc $(object) -o $(shared_lib) + endif + endif + endif +endif + rm $(object) + +ifeq ($(PTRBITS),64) +$(shared_lib32): $(source) Makefile + ifneq ($(OS_AIX),0) + gcc -m32 -c -D_BSD -D_NO_PROTO -D_NONSTD_TYPES -D_MBI=void $(source) -o ($object32) + make_shared -o $(shared_lib32) $(object32) + else + ifneq ($(OS_SUNOS),0) + cc -m32 -KPIC -c $(source) -o $(object32) + cc -G $(object32) -o $(shared_lib32) + else + ifneq ($(OS_DARWIN),0) + cc -m32 -dynamic -c $(source) -o $(object32) + ld -bundle /usr/lib/bundle1.o -flat_namespace -undefined suppress -o $(base)32.dylib $(object32) + ld -bundle /usr/lib/bundle1.o -flat_namespace -undefined suppress /usr/lib/libz32.dylib -o z.dylib + else + ifneq ($(OS_CYGWIN),0) + gcc -m32 -c $(source) -o $(object32) + ld -shared -soname=$(base) $(LDFLAGS) $(object32) -o $(shared_lib32) + else + gcc -m32 -fPIC -DPIC -c $(source) -o $(object32) + ld -shared -soname=$(base) -L /lib32 -L /usr/lib32 -lc $(object32) -o $(shared_lib32) + endif + endif + endif + endif +endif + rm $(object32) + +.PHONY: distclean +distclean: clean + rm -f $(base).dylib $(base).dylib $(basebits).so $(base).o ptrbits + diff --git a/uffi/Makefile.msvc b/uffi/Makefile.msvc new file mode 100644 index 0000000..ea3b5b7 --- /dev/null +++ b/uffi/Makefile.msvc @@ -0,0 +1,31 @@ +# -*- Mode: Makefile -*- +########################################################################### +# FILE IDENTIFICATION +# +# Name: Makefile.msvc +# Purpose: Makefile for the CLSQL UFFI helper package (MSVC) +# Author: Kevin M. Rosenberg +# Created: Mar 2002 +# +# This file, part of CLSQL, is Copyright (c) 2002-2010 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. +########################################################################### + + +BASE=clsql_uffi + +# Nothing to configure beyond here + +SRC=$(BASE).c +OBJ=$(BASE).obj +DLL=$(BASE).dll + +$(DLL): $(SRC) + cl /MD /LD -D_MT /DWIN32=1 /D__LCC__=1 $(SRC) + del $(OBJ) $(BASE).exp + +clean: + del /q $(DLL) $(BASE).LIB diff --git a/uffi/clsql-uffi-loader.lisp b/uffi/clsql-uffi-loader.lisp new file mode 100644 index 0000000..8b12cc8 --- /dev/null +++ b/uffi/clsql-uffi-loader.lisp @@ -0,0 +1,52 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: clsql-uffi-loader.sql +;;;; Purpose: Library loader using CLSQL UFFI helper library +;;;; Author: Kevin M. Rosenberg +;;;; Created: Mar 2002 +;;;; +;;;; This file, part of CLSQL, is Copyright (c) 2002-2010 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-uffi) + +(defun find-and-load-foreign-library (filenames &key module supporting-libraries (errorp t)) + "Attempt to load a foreign library. This will search for any of the filenames, as +well as any of the filenames in any of the clsql:*foreign-library-search-paths*" + (setq filenames (if (listp filenames) filenames (list filenames))) + + (flet ((try-load (testpath) + (handler-case + (uffi:load-foreign-library testpath + :module module + :supporting-libraries supporting-libraries) + (error nil)))) ;(c) (warn "~A" c) nil)))) + (or + (loop for type in (uffi:foreign-library-types) + thereis + (loop for name in filenames + for pn = (make-pathname :name name :type type) + thereis (or + (try-load pn) + (loop for search-path in clsql:*foreign-library-search-paths* + thereis (try-load (merge-pathnames pn search-path)))))) + (when errorp + (error "Couldn't load foreign librar~@P ~{~S~^, ~}. (searched ~S: ~S)" + (length filenames) filenames + 'clsql:*foreign-library-search-paths* clsql:*foreign-library-search-paths*))))) + +;; searches clsql_uffi64 to accomodate both 32-bit and 64-bit libraries on same system +(defvar *clsql-uffi-library-filenames* + `(,@(when (> most-positive-fixnum (expt 2 32)) (list "clsql_uffi64")) + "clsql_uffi")) + +(defvar *clsql-uffi-supporting-libraries* '("c") + "Used only by CMU. List of library flags needed to be passed to ld to +load the MySQL client library succesfully. If this differs at your site, +set to the right path before compiling or loading the system.") diff --git a/uffi/clsql-uffi-package.lisp b/uffi/clsql-uffi-package.lisp new file mode 100644 index 0000000..2b792f4 --- /dev/null +++ b/uffi/clsql-uffi-package.lisp @@ -0,0 +1,32 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: clsql-uffi-package.cl +;;;; Purpose: Package definitions for common UFFI interface routines +;;;; Programmers: Kevin M. Rosenberg +;;;; Date Started: Mar 2002 +;;;; +;;;; This file, part of CLSQL, is Copyright (c) 2002-2010 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 #:clsql-uffi + (:use #:cl #:uffi) + (:export + #:find-and-load-foreign-library + #:canonicalize-type-list + #:convert-raw-field + #:atoi + #:atol + #:atof + #:make-64-bit-integer + #:make-128-bit-integer + #:split-64-bit-integer) + (:documentation "Common functions for interfaces using UFFI")) + diff --git a/uffi/clsql-uffi.lisp b/uffi/clsql-uffi.lisp new file mode 100644 index 0000000..6f62d95 --- /dev/null +++ b/uffi/clsql-uffi.lisp @@ -0,0 +1,167 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: clsql-uffi.cl +;;;; Purpose: Common functions for interfaces using UFFI +;;;; Programmers: Kevin M. Rosenberg +;;;; Date Started: Mar 2002 +;;;; +;;;; This file, part of CLSQL, is Copyright (c) 2002-2010 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-uffi) + + +(defun canonicalize-type-list (types auto-list) + "Ensure a field type list meets expectations" + (declare (optimize (speed 3) (safety 0))) + (do ((i 0 (1+ i)) + (new-types '()) + (length-types (length types)) + (length-auto-list (length auto-list))) + ((= i length-auto-list) + (nreverse new-types)) + (declare (fixnum length-types length-auto-list i)) + (if (>= i length-types) + (push t new-types) ;; types is shorter than num-fields + (push + (case (nth i types) + (:int + (case (nth i auto-list) + (:int32 + :int32) + (:int64 + :int64) + (t + t))) + (:double + (case (nth i auto-list) + (:double + :double) + (t + t))) + (:int32 + (if (eq :int32 (nth i auto-list)) + :int32 + t)) + (:int64 + (if (eq :int64 (nth i auto-list)) + :int64 + t)) + (:blob + :blob) + (:uint + :uint) + (t + t)) + new-types)))) + +(uffi:def-function "atoi" + ((str (* :unsigned-char))) + :returning :int) + +(uffi:def-function ("strtoul" c-strtoul) + ((str (* :unsigned-char)) + (endptr (* :unsigned-char)) + (radix :int)) + :returning :unsigned-long) + +#-windows +(uffi:def-function ("strtoull" c-strtoull) + ((str (* :unsigned-char)) + (endptr (* :unsigned-char)) + (radix :int)) + :returning :unsigned-long-long) + +#-windows +(uffi:def-function ("strtoll" c-strtoll) + ((str (* :unsigned-char)) + (endptr (* :unsigned-char)) + (radix :int)) + :returning :long-long) + +#+windows +(uffi:def-function ("_strtoui64" c-strtoull) + ((str (* :unsigned-char)) + (endptr (* :unsigned-char)) + (radix :int)) + :returning :unsigned-long-long) + +#+windows +(uffi:def-function ("_strtoi64" c-strtoll) + ((str (* :unsigned-char)) + (endptr (* :unsigned-char)) + (radix :int)) + :returning :long-long) + +(uffi:def-function "atol" + ((str (* :unsigned-char))) + :returning :long) + +(uffi:def-function "atof" + ((str (* :unsigned-char))) + :returning :double) + +(uffi:def-constant +2^32+ 4294967296) +(uffi:def-constant +2^64+ 18446744073709551616) +(uffi:def-constant +2^32-1+ (1- +2^32+)) + +(defmacro make-64-bit-integer (high32 low32) + `(if (zerop (ldb (byte 1 31) ,high32)) + (+ ,low32 (ash ,high32 32)) + (- (+ ,low32 (ash ,high32 32)) +2^64+))) + +;; From high to low ints +(defmacro make-128-bit-integer (a b c d) + `(+ ,d (ash ,c 32) (ash ,b 64) (ash ,a 96))) + +(defmacro split-64-bit-integer (int64) + `(values (ash ,int64 -32) (logand ,int64 +2^32-1+))) + +(uffi:def-type char-ptr-def (* :unsigned-char)) + +(defun strtoul (char-ptr) + (declare (optimize (speed 3) (safety 0) (space 0)) + (type char-ptr-def char-ptr)) + (c-strtoul char-ptr uffi:+null-cstring-pointer+ 10)) + +(defun strtoull (char-ptr) + (declare (optimize (speed 3) (safety 0) (space 0)) + (type char-ptr-def char-ptr)) + (c-strtoull char-ptr uffi:+null-cstring-pointer+ 10)) + +(defun strtoll (char-ptr) + (declare (optimize (speed 3) (safety 0) (space 0)) + (type char-ptr-def char-ptr)) + (c-strtoll char-ptr uffi:+null-cstring-pointer+ 10)) + +(defun convert-raw-field (char-ptr type &key length encoding) + (declare (optimize (speed 3) (safety 0) (space 0)) + (type char-ptr-def char-ptr)) + (unless (uffi:null-pointer-p char-ptr) + (case type + (:double (atof char-ptr)) + (:int (atol char-ptr)) + (:int32 (atoi char-ptr)) + (:uint32 (strtoul char-ptr)) + (:uint (strtoul char-ptr)) + (:int64 (strtoll char-ptr)) + (:uint64 (strtoull char-ptr)) + (:blob + (if length + (uffi:convert-from-foreign-usb8 char-ptr length) + (error "Can't return blob since length is not specified."))) + (t + ;; NB: this used to manually expand the arg list based on if length and encoding + ;; were provided. If this is required the macro is aweful and should be rewritten + ;; to accept nil args (as it appears to) + (uffi:convert-from-foreign-string + char-ptr + :null-terminated-p (null length) + :length length + :encoding encoding))))) diff --git a/uffi/clsql_uffi.c b/uffi/clsql_uffi.c new file mode 100644 index 0000000..95822b7 --- /dev/null +++ b/uffi/clsql_uffi.c @@ -0,0 +1,73 @@ +/**************************************************************************** + * FILE IDENTIFICATION + * + * Name: clsql-uffi.c + * Purpose: Helper functions for common interfaces using UFFI + * Programmer: Kevin M. Rosenberg + * Date Started: Mar 2002 + * + * This file, part of CLSQL, is Copyright (c) 2002-2010 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. + ***************************************************************************/ + +#if defined(WIN32)||defined(WIN64) +#include <windows.h> + +BOOL WINAPI DllEntryPoint(HINSTANCE hinstdll, DWORD fdwReason, + LPVOID lpvReserved) +{ + return 1; +} + +#define DLLEXPORT __declspec(dllexport) + +#else +#define DLLEXPORT +#endif + + +const unsigned int bitmask_32bits = 0xFFFFFFFF; +#define lower_32bits(int64) ((unsigned int) int64 & bitmask_32bits) +#define upper_32bits(int64) ((unsigned int) (int64 >> 32)) + +/* Reads a 64-bit integer string, returns result as two 32-bit integers */ + +DLLEXPORT +unsigned int +atol64 (const unsigned char* str, unsigned int* pHigh32) +{ +#if defined(WIN32)||defined(WIN64) + __int64 result = 0; +#else + long long result = 0; +#endif + int minus = 0; + int first_char = *str; + if (first_char == '+') + ++str; + else if (first_char == '-') { + minus = 1; + ++str; + } + + while (*str) { + int i = *str - '0'; + if (i < 0 || i > 9) /* Non-numeric character -- quit */ + break; + result = i + (10 * result); + str++; + } + if (minus) + result = -result; + + *pHigh32 = upper_32bits(result); + return lower_32bits(result); +} + + + + + diff --git a/uffi/clsql_uffi.lib b/uffi/clsql_uffi.lib Binary files differnew file mode 100644 index 0000000..a9ee8fe --- /dev/null +++ b/uffi/clsql_uffi.lib diff --git a/uffi/ptrbits.c b/uffi/ptrbits.c new file mode 100644 index 0000000..17f7bf8 --- /dev/null +++ b/uffi/ptrbits.c @@ -0,0 +1,11 @@ +/* Prints the number of bits in a pointer. + * Copyright (c) 2006 Kevin Rosenberg + */ + +#include <stdio.h> + +int main() { + char *p; + printf ("%d\n", 8*sizeof(p)); + return (0); +} |