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)
-Nathan Bird (sponsored by http://www.acceleration.net/programming/)
+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
+
+
USQL Contributors
+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
-Note from Russ Tyndall <russ@acceleration.net> 2012-11-24 :
+Note from Russ Tyndall <russ@acceleration.net> 2013-01-30 :
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
+increasing the number of failing tests
:mysql
-1 out of 298 total tests failed: :FDDL/CACHE-TABLE-QUERIES/1.
+1 out of 301 total tests failed: :FDDL/CACHE-TABLE-QUERIES/1.
:odbc MSSQL2000/5
-1 out of 265 total tests failed: :FDDL/CACHE-TABLE-QUERIES/1.
+1 out of 298 total tests failed: :FDDL/CACHE-TABLE-QUERIES/1.
:odbc postgres
-32 out of 309 total tests failed: :OODML/DB-AUTO-SYNC/4, :OODML/DB-AUTO-SYNC/3,
- :OODML/UPDATE-INSTANCE/7, :OODML/UPDATE-INSTANCE/6, :OODML/UPDATE-INSTANCE/5,
- :OODML/UPDATE-INSTANCE/4, :OODML/UPDATE-INSTANCE/3, :OODML/UPDATE-RECORDS/12,
- :OODML/UPDATE-RECORDS/11, :OODML/UPDATE-RECORDS/9-SLOTS,
- :OODML/UPDATE-RECORDS/9, :OODML/UPDATE-RECORDS/8, :OODML/UPDATE-RECORDS/7,
- :OODML/UPDATE-RECORDS/6, :OODML/UPDATE-RECORDS/5-SLOTS,
- :OODML/UPDATE-RECORDS/5, :OODML/UPDATE-RECORDS/4-SLOTS,
- :OODML/UPDATE-RECORDS/4, :OODML/SELECT/23, :OODML/SELECT/22,
- :OODML/SELECT/21, :OODML/SELECT/20, :OODML/SELECT/19, :OODML/SELECT/18,
- :OODML/SELECT/17, :OODML/SELECT/16, :OODML/SELECT/15, :OODML/SELECT/14,
- :OODML/SELECT/13, :OODML/SELECT/12, :FDML/SELECT/36,
- :FDDL/CACHE-TABLE-QUERIES/1.
-
-Most of these seem to have to do with not correctly dispatching AUTO_INCREMENT
-or not correctly skipping those tests
-
+2 out of 311 total tests failed: :FDML/SELECT/36, :FDDL/CACHE-TABLE-QUERIES/1.
:postgres-socket :postgres-socket-3
-5 out of 315 total tests failed: :TIME/PG/OODML/USEC, :TIME/PG/OODML/NO-USEC,
+5 out of 300 total tests failed: :TIME/PG/OODML/USEC, :TIME/PG/OODML/NO-USEC,
:TIME/PG/FDML/USEC, :FDML/SELECT/36, :FDDL/CACHE-TABLE-QUERIES/1.
:sqlite3
-9 out of 267 total tests failed: :FDDL/CACHE-TABLE-QUERIES/1, :FDDL/INDEX/3,
- :FDDL/ATTRIBUTES/8, :FDDL/ATTRIBUTES/7, :FDDL/ATTRIBUTES/6,
- :FDDL/ATTRIBUTES/5, :FDDL/ATTRIBUTES/4, :FDDL/ATTRIBUTES/3,
- :FDDL/ATTRIBUTES/2.
+1 out of 300 total tests failed: :FDDL/INDEX/3.
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
Version 3.0.0 run on August 3, 2004 on x86, x86_64, and PowerPC platforms
SQLITE: All 224 tests passed (ppc, OpenMCL).
ODBC/POSTGRESQL: All 232 tests passed (ppc, OpenMCL).
ODBC/MYSQL: All 217 tests passed (ppc, OpenMCL).
+
: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-api" :depends-on ("sqlite3-loader"))
+ (:file "sqlite3-sql" :depends-on ("sqlite3-api"))
+ (:file "sqlite3-methods" :depends-on ("sqlite3-sql"))))))
(defpackage clsql-uffi-system (:use #:asdf #:cl))
(in-package clsql-uffi-system)
-(defvar *clsql-uffi-library-dir*
- (merge-pathnames "uffi/"
- (make-pathname :name nil :type nil :defaults *load-truename*)))
-
-(defclass clsql-uffi-source-file (c-source-file)
- ())
-
-
-(defmethod output-files ((o compile-op) (c clsql-uffi-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 *clsql-uffi-library-dir*)))))
-
-(defmethod perform ((o load-op) (c clsql-uffi-source-file))
- nil) ;;; library will be loaded by a loader file
-
-(defmethod operation-done-p ((o load-op) (c clsql-uffi-source-file))
- (and (find-package '#:clsql-uffi)
- (symbol-function (intern (symbol-name '#:atol64)
- (find-package '#:clsql-uffi)))
- t))
-
-(defmethod perform ((o compile-op) (c clsql-uffi-source-file))
- (unless (operation-done-p o c)
- #-(or win32 win64 windows mswindows)
- (unless (zerop (run-shell-command
- #-(or freebsd netbsd) "cd ~A; make"
- #+(or freebsd netbsd) "cd ~A; gmake"
- (namestring *clsql-uffi-library-dir*)))
- (error 'operation-error :component c :operation o))))
-
-(defmethod operation-done-p ((o compile-op) (c clsql-uffi-source-file))
- (or (and (probe-file #p"/usr/lib/clsql/clsql_uffi.so") t)
- (let ((lib (make-pathname :defaults (component-pathname c)
- :type (funcall (intern (symbol-name '#:default-foreign-library-type)
- (find-package '#:uffi))))))
- (and (probe-file lib) (probe-file (component-pathname c))
- (> (file-write-date lib) (file-write-date (component-pathname c)))))))
-
(defsystem clsql-uffi
:name "cl-sql-base"
:author "Kevin M. Rosenberg <kmr@debian.org>"
((:module :uffi
:components
((:file "clsql-uffi-package")
- (:clsql-uffi-source-file "clsql_uffi" :depends-on ("clsql-uffi-package"))
- (:file "clsql-uffi-loader" :depends-on ("clsql-uffi-package" "clsql_uffi"))
- (:file "clsql-uffi" :depends-on ("clsql-uffi-loader"))))))
+ (:file "clsql-uffi-loader" :depends-on ("clsql-uffi-package"))
+ (:file "clsql-uffi" :depends-on ("clsql-uffi-package"))))))
(in-package #:clsql-mysql)
-(defmethod database-get-type-specifier ((type (eql 'wall-time)) args database
+(defmethod database-get-type-specifier ((type symbol) args database
(db-type (eql :mysql)))
- (declare (ignore args database))
- "DATETIME")
+ (declare (ignore args database db-type))
+ (case type
+ (wall-time "DATETIME")
+ (tinyint "TINYINT")
+ (smallint "SMALLINT")
+ (mediumint "MEDIUMINT")
+ (t (call-next-method))))
-(defmethod database-get-type-specifier ((type (eql 'smallint)) args database
- (db-type (eql :mysql)))
- (declare (ignore args database))
- "SMALLINT")
-
-(defmethod database-get-type-specifier ((type (eql 'mediumint)) args database
- (db-type (eql :mysql)))
- (declare (ignore args database))
- "MEDIUMINT")
-
-(defmethod database-get-type-specifier ((type (eql 'tinyint)) args database
- (db-type (eql :mysql)))
- (declare (ignore args database))
- "TINYINT")
-
-(defmethod database-output-sql-as-type ((type (eql 'boolean)) val database
- (db-type (eql :mysql)))
- (declare (ignore database))
- (if val 1 0))
-
-(defmethod database-output-sql-as-type ((type (eql 'generalized-boolean)) val database
- (db-type (eql :mysql)))
- (declare (ignore database))
- (if val 1 0))
-
-(defmethod read-sql-value (val (type (eql 'boolean)) database
- (db-type (eql :mysql)))
- (declare (ignore database))
- (etypecase val
- (string (if (string= "0" val) nil t))
- (integer (if (zerop val) nil t))))
-
-(defmethod read-sql-value (val (type (eql 'generalized-boolean)) database
- (db-type (eql :mysql)))
- (declare (ignore database))
- (etypecase val
- (string (if (string= "0" val) nil t))
- (integer (if (zerop val) nil t))))
(:boolean-ptr
(uffi:with-foreign-object (fo :byte)
(setf (uffi:deref-pointer fo :byte)
- (if (or (zerop value) (null value))
- 0
- 1))
+ (case value
+ ((nil 0) 0)
+ (t 1)))
(mysql-options mysql-ptr option-code fo)))))))))))
(defmethod database-connect (connection-spec (database-type (eql :mysql)))
;; ODBC interface
(defclass odbc-database (generic-odbc-database)
- ((odbc-db-type :accessor database-odbc-db-type)))
+ ())
+
+(defclass odbc-postgresql-database (generic-odbc-database
+ generic-postgresql-database)
+ ())
(defmethod database-name-from-spec (connection-spec
(database-type (eql :odbc)))
(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))))
+ :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)
- db)
+ (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
:connection-spec connection-spec
:message "Connection failed")))))
-(defmethod database-underlying-type ((database odbc-database))
- (database-odbc-db-type database))
+(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))
((or (search "oracle" server-name :test #'char-equal)
(search "oracle" dbms-name :test #'char-equal))
:oracle))))
- (setf (database-odbc-db-type db) type)))
+ (setf (clsql-sys::database-odbc-db-type db) type)))
(clsql-sys:initialize-database-type :database-type :postgresql-socket3))
-;; Type munging functions
-
-(defmethod read-sql-value (val (type (eql 'boolean)) (database postgresql-socket3-database) db-type)
- (declare (ignore database db-type))
- val)
-
-(defmethod read-sql-value (val (type (eql 'generalized-boolean)) (database postgresql-socket3-database) db-type)
- (declare (ignore database db-type))
- val)
--- /dev/null
+;;;; -*- 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))))
+
(sqlite3:sqlite3-column-blob stmt i)
(car types)
:length (sqlite3:sqlite3-column-bytes stmt i)
- :encoding (encoding database))
+ :encoding (or (encoding database)
+ :utf-8))
(clsql-uffi:convert-raw-field
(sqlite3:sqlite3-column-text stmt i)
(car types)
- :encoding (encoding database))))))
+ :encoding (or (encoding database)
+ :utf-8))))))
(when field-names
(setf col-names (loop for n from 0 below n-col
collect (sqlite3:sqlite3-column-name stmt n))))
(declaim (inline sqlite3-table-info))
(defun sqlite3-table-info (table database)
- (database-query (format nil "PRAGMA table_info('~A')" table)
- database nil nil))
+ (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))
(database sqlite3-database)
&key (owner nil))
(declare (ignore owner))
-
+
(loop for field-info in (sqlite3-table-info table database)
- when (string= attribute (second field-info))
+ when (string= (clsql-sys::unescaped-database-identifier attribute)
+ (second field-info))
return
(let* ((raw-type (third field-info))
(start-length (position #\( raw-type))
(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
(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)
'(([id] integer)
([height] float)
([name] (string 24))
- ([comments] longchar)))
+ ([comments] text)))
=>
(table-exists-p [foo])
=> T
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.
+ 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>
is called by database backends."
`(handler-case
(destructuring-bind ,template ,connection-spec
- (declare (ignore ,@(remove '&optional template)))
+ (declare (ignore ,@(remove-if
+ (lambda (x) (member x '(&key &rest &optional)))
+ template)))
t)
(error ()
(error 'sql-user-error
;;
;; Column constraint types and conversion to SQL
;;
-
-(defparameter *constraint-types*
- (list
- (cons (symbol-name-default-case "NOT-NULL") "NOT NULL")
- (cons (symbol-name-default-case "PRIMARY-KEY") "PRIMARY KEY")
- (cons (symbol-name-default-case "NOT") "NOT")
- (cons (symbol-name-default-case "NULL") "NULL")
- (cons (symbol-name-default-case "PRIMARY") "PRIMARY")
- (cons (symbol-name-default-case "KEY") "KEY")
- (cons (symbol-name-default-case "UNSIGNED") "UNSIGNED")
- (cons (symbol-name-default-case "ZEROFILL") "ZEROFILL")
- (cons (symbol-name-default-case "AUTO-INCREMENT") "AUTO_INCREMENT")
- (cons (symbol-name-default-case "DEFAULT") "DEFAULT")
- (cons (symbol-name-default-case "UNIQUE") "UNIQUE")
- (cons (symbol-name-default-case "IDENTITY") "IDENTITY (1,1)") ;; added for sql-server support
- ))
-
(defmethod database-constraint-statement (constraint-list database)
- (declare (ignore database))
- (make-constraints-description constraint-list))
-
-(defun make-constraints-description (constraint-list)
- (if constraint-list
- (let ((string ""))
- (do ((constraint constraint-list (cdr constraint)))
- ((null constraint) string)
- (let ((output (assoc (symbol-name (car constraint))
- *constraint-types*
- :test #'equal)))
- (if (null output)
- (error 'sql-user-error
- :message (format nil "unsupported column constraint '~A'"
- constraint))
- (setq string (concatenate 'string string (cdr output))))
- (when (equal (symbol-name (car constraint)) "DEFAULT")
- (setq constraint (cdr constraint))
- (setq string (concatenate 'string string " " (car constraint))))
- (if (< 1 (length constraint))
- (setq string (concatenate 'string string " "))))))))
+ (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)
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-ident attribute-cache)
+ (multiple-value-bind (val found)
+ (gethash table attribute-cache)
(if (and found (second val))
(second val)
(let ((types (mapcar #'(lambda (attribute)
:owner owner))))
(cond
((and (not found) (eq t *cache-table-queries-default*))
- (setf (gethash table-ident attribute-cache)
+ (setf (gethash table attribute-cache)
(list :unspecified types)))
((and found (eq t (first val))
- (setf (gethash table-ident attribute-cache)
+ (setf (gethash table attribute-cache)
(list t types)))))
types))))))
(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))
+ (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)
(slot-value db 'list-all-table-columns-fn)
(intern (symbol-name '#:list-all-table-columns) pkg))))
-;;; Object methods
-
-(defmethod read-sql-value (val (type (eql 'boolean))
- (database generic-odbc-database)
- (db-type (eql :postgresql)))
- (if (string= "0" val) nil t))
-
-(defmethod read-sql-value (val (type (eql 'generalized-boolean))
- (database generic-odbc-database)
- (db-type (eql :postgresql)))
- (if (string= "0" val) nil t))
-
-(defmethod read-sql-value (val (type (eql 'boolean)) database
- (db-type (eql :mssql)))
- (declare (ignore database))
- (etypecase val
- (string (if (string= "0" val) nil t))
- (integer (if (zerop val) nil t))))
-
-(defmethod read-sql-value (val (type (eql 'generalized-boolean)) database
- (db-type (eql :mssql)))
- (declare (ignore database))
- (etypecase val
- (string (if (string= "0" val) nil t))
- (integer (if (zerop val) nil t))))
-
;;; Type methods
-(defmethod database-get-type-specifier ((type (eql 'wall-time)) args database
- (db-type (eql :mssql)))
- (declare (ignore args database))
- "DATETIME")
-
-(defmethod database-get-type-specifier ((type (eql 'date)) args database
- (db-type (eql :mssql)))
- (declare (ignore args database))
- "SMALLDATETIME")
-
-(defmethod database-get-type-specifier ((type (eql 'boolean)) args database
+(defmethod database-get-type-specifier ((type symbol) args database
(db-type (eql :mssql)))
- (declare (ignore args database))
- "BIT")
-
-(defmethod database-get-type-specifier ((type (eql 'generalized-boolean)) args database
- (db-type (eql :mssql)))
- (declare (ignore args database))
- "BIT")
+ "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
(:mssql "1")
(t "'Y'")))
-(defmethod database-output-sql-as-type ((type (eql 'boolean)) val database
- (db-type (eql :mssql)))
- (declare (ignore database))
- (if val 1 0))
-
-(defmethod database-output-sql-as-type ((type (eql 'generalized-boolean)) val database
- (db-type (eql :mssql)))
- (declare (ignore database))
- (if val 1 0))
-
;;; Database backend capabilities
(defmethod db-type-use-fully-qualified-column-on-drop-index? ((db-type (eql :mssql)))
(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)
;; Object functions
-(defmethod database-get-type-specifier (type args database
+(defmethod database-get-type-specifier ((type symbol) args database
(db-type (eql :postgresql)))
- (declare (ignore type args database))
- "VARCHAR")
-
-(defmethod database-get-type-specifier ((type (eql 'string)) args database
- (db-type (eql :postgresql)))
- (declare (ignore database))
- (if args
- (format nil "CHAR(~A)" (car args))
- "VARCHAR"))
-
-(defmethod database-get-type-specifier ((type (eql 'tinyint)) args database
- (db-type (eql :postgresql)))
- (declare (ignore args database))
- "INT2")
-
-(defmethod database-get-type-specifier ((type (eql 'smallint)) args database
- (db-type (eql :postgresql)))
- (declare (ignore args database))
- "INT2")
-
-(defmethod database-get-type-specifier ((type (eql 'wall-time)) args database
- (db-type (eql :postgresql)))
- (declare (ignore args database))
- "TIMESTAMP WITHOUT TIME ZONE")
-
-(defmethod database-get-type-specifier ((type (eql 'number)) args database
- (db-type (eql :postgresql)))
- (declare (ignore database))
- (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")))
+ "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
(when seq
(setf const (remove :auto-increment const))
(unless (member :default const)
- (let* ((next (format nil "nextval('~a')" (escaped-database-identifier seq))))
+ (let* ((next (format nil " nextval('~a')" (escaped-database-identifier seq))))
(setf const (append const (list :default next))))))
(append cdef const))))
(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"))
(defmethod auto-increment-column-p (slotdef &optional (database clsql-sys:*default-database*))
(declare (ignore database))
- (or (member :auto-increment (listify (view-class-slot-db-constraints slotdef)))
+ (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
(defun update-auto-increments-keys (class obj database)
" handle pulling any autoincrement values into the object
- if normalized and we now that all the "
+ Also handles normalized key chaining"
(let ((pk-slots (keyslots-for-class class))
(table (view-table class))
new-pk-value)
- (labels ((do-update (slot)
- (when (and (null (easy-slot-value obj slot))
- (auto-increment-column-p slot database))
- (update-slot-from-db-value
- obj slot
- (or new-pk-value
- (setf new-pk-value
- (database-last-auto-increment-id
- database table slot))))))
+ (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"
(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
the public api"
(update-record-from-slots obj slot :database database))
-(defmethod view-classes-and-storable-slots (class)
+(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 (key-or-base-slot-p sd)
+ 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)))
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)))
+ (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)
Can we just call build-objects?, update-objects-joins?
"
- (let* ((classes-and-slots (view-classes-and-storable-slots instance))
+ (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))
+ (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
(error "No view-table for class ~A" classname))
(sql-expression :table (view-table class))))
-
-(defmethod database-get-type-specifier (type args database db-type)
- (declare (ignore type args database db-type))
- (format nil "VARCHAR(~D)" *default-string-length*))
-
-(defmethod database-get-type-specifier ((type (eql 'integer)) args database db-type)
- (declare (ignore database db-type))
- (if args
- (format nil "INT(~A)" (car args))
- "INT"))
-
(deftype tinyint ()
"An 8-bit integer, this width may vary by SQL implementation."
'integer)
-(defmethod database-get-type-specifier ((type (eql 'tinyint)) args database db-type)
- (declare (ignore args database db-type))
- "INT")
-
(deftype smallint ()
"An integer smaller than a 32-bit integer. this width may vary by SQL implementation."
'integer)
-(defmethod database-get-type-specifier ((type (eql 'smallint)) args database db-type)
- (declare (ignore args database db-type))
- "INT")
-
(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)
-(defmethod database-get-type-specifier ((type (eql 'mediumint)) args database db-type)
- (declare (ignore args database db-type))
- "INT")
-
(deftype bigint ()
"An integer larger than a 32-bit integer, this width may vary by SQL implementation."
'integer)
-(defmethod database-get-type-specifier ((type (eql 'bigint)) args database db-type)
- (declare (ignore args database db-type))
- "BIGINT")
-
(deftype varchar (&optional size)
"A variable length string for the SQL varchar type."
(declare (ignore size))
'string)
-(defmethod database-get-type-specifier ((type (eql 'varchar)) args
- database db-type)
- (declare (ignore database db-type))
- (if args
- (format nil "VARCHAR(~A)" (car args))
- (format nil "VARCHAR(~D)" *default-string-length*)))
-
-(defmethod database-get-type-specifier ((type (eql 'string)) args database db-type)
- (declare (ignore database db-type))
- (if args
- (format nil "CHAR(~A)" (car args))
- (format nil "VARCHAR(~D)" *default-string-length*)))
-
(deftype universal-time ()
"A positive integer as returned by GET-UNIVERSAL-TIME."
'(integer 1 *))
-(defmethod database-get-type-specifier ((type (eql 'universal-time)) args database db-type)
- (declare (ignore args database db-type))
- "BIGINT")
-
-(defmethod database-get-type-specifier ((type (eql 'wall-time)) args database db-type)
- (declare (ignore args database db-type))
- "TIMESTAMP")
-
-(defmethod database-get-type-specifier ((type (eql 'date)) args database db-type)
- (declare (ignore args database db-type))
- "DATE")
-
-(defmethod database-get-type-specifier ((type (eql 'duration)) args database db-type)
- (declare (ignore database args db-type))
- "VARCHAR")
-
-(defmethod database-get-type-specifier ((type (eql 'money)) args database db-type)
- (declare (ignore database args db-type))
- "INT8")
+(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 (eql 'float)) args database db-type)
- (declare (ignore database db-type))
- (if args
- (format nil "FLOAT(~A)" (car args))
- "FLOAT"))
-
-(defmethod database-get-type-specifier ((type (eql 'long-float)) args database db-type)
- (declare (ignore database db-type))
- (if args
- (format nil "FLOAT(~A)" (car args))
- "FLOAT"))
-
-(deftype generalized-boolean ()
- "A type which outputs a SQL boolean value, though any lisp type can be stored in the slot."
- t)
-
-(defmethod database-get-type-specifier ((type (eql 'boolean)) args database db-type)
- (declare (ignore args database db-type))
- "BOOL")
-
-(defmethod database-get-type-specifier ((type (eql 'generalized-boolean)) args database db-type)
+(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))
- "BOOL")
-
-(defmethod database-get-type-specifier ((type (eql 'number)) args database db-type)
- (declare (ignore database db-type))
- (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")))
-
-(defmethod database-get-type-specifier ((type (eql 'char)) args database db-type)
- (declare (ignore database db-type))
- (if args
- (format nil "CHAR(~D)" (first args))
- "CHAR(1)"))
-
+ 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)
+ (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*))))
(defmethod database-output-sql-as-type (type val database db-type)
(declare (ignore type database db-type))
val)
-(defmethod database-output-sql-as-type ((type (eql 'list)) val database db-type)
- (declare (ignore database db-type))
- (progv '(*print-circle* *print-array*) '(t t)
- (let ((escaped (prin1-to-string val)))
- (substitute-char-string
- escaped #\Null " "))))
-
-(defmethod database-output-sql-as-type ((type (eql 'symbol)) val database db-type)
- (declare (ignore database db-type))
- (if val
- (concatenate 'string
- (package-name (symbol-package val))
- "::"
- (symbol-name val))
- ""))
-
-(defmethod database-output-sql-as-type ((type (eql 'keyword)) val database db-type)
- (declare (ignore database db-type))
- (if val
- (symbol-name val)
- ""))
-
-(defmethod database-output-sql-as-type ((type (eql 'vector)) val database db-type)
- (declare (ignore database db-type))
- (progv '(*print-circle* *print-array*) '(t t)
- (prin1-to-string val)))
-
-(defmethod database-output-sql-as-type ((type (eql 'array)) val database db-type)
- (declare (ignore database db-type))
- (progv '(*print-circle* *print-array*) '(t t)
- (prin1-to-string val)))
-
-(defmethod database-output-sql-as-type ((type (eql 'boolean)) val database db-type)
- (declare (ignore database db-type))
- (if val "t" "f"))
-
-(defmethod database-output-sql-as-type ((type (eql 'generalized-boolean)) val database db-type)
- (declare (ignore database db-type))
- (if val "t" "f"))
-
-(defmethod database-output-sql-as-type ((type (eql 'string)) val database db-type)
- (declare (ignore database db-type))
- val)
-
-(defmethod database-output-sql-as-type ((type (eql 'char)) val database db-type)
- (declare (ignore database db-type))
- (etypecase val
- (character (write-to-string val))
- (string val)))
-
-(defmethod database-output-sql-as-type ((type (eql 'float)) val database db-type)
+(defmethod database-output-sql-as-type ((type symbol) val database db-type)
+ (declare (ignore database))
+ (case type ;; booleans handle null differently
+ ((boolean generalized-boolean)
+ (case db-type
+ ;; done here so it can be done once
+ ((:mssql :mysql) (if val 1 0))
+ (otherwise (if val "t" "f"))))
+ (otherwise
+ ;; in all other cases if we have nil give everyone else a shot at it,
+ ;; which by default returns nil
+ (if (null val)
+ (call-next-method)
+ (case type
+ (symbol
+ (format nil "~A::~A"
+ (package-name (symbol-package val))
+ (symbol-name val)))
+ (keyword (symbol-name val))
+ (string val)
+ (char (etypecase val
+ (character (write-to-string val))
+ (string val)))
+ (float (format nil "~F" val))
+ ((list vector array)
+ (let* ((*print-circle* t)
+ (*print-array* t)
+ (*print-length* nil)
+ (value (prin1-to-string val)))
+ value))
+ (otherwise (call-next-method)))))))
+
+(defmethod read-sql-value (val type database db-type
+ &aux *read-eval*)
(declare (ignore database db-type))
- (if (eq (type-of val) 'null)
- nil
- (let ((*read-default-float-format* (type-of val)))
- (format nil "~F" val))))
+ ;; TODO: All the read-from-strings in here do not check that
+ ;; what we read was of the correct type, should this change?
-(defmethod read-sql-value (val type database db-type)
- (declare (ignore database db-type))
+ ;; TODO: Should this case `(typep val type)=>t` be an around
+ ;; method that short ciruits?
(cond
((null type) val) ;;we have no desired type, just give the value
((typep val type) val) ;;check that it hasn't already been converted.
((typep val 'string) (read-from-string val)) ;;maybe read will just take care of it?
(T (error "Unable to read-sql-value ~a as type ~a" val type))))
-(defmethod read-sql-value (val (type (eql 'string)) database db-type)
- (declare (ignore database db-type))
- val)
-
-(defmethod read-sql-value (val (type (eql 'varchar)) database db-type)
- (declare (ignore database db-type))
- val)
-
-(defmethod read-sql-value (val (type (eql 'char)) database db-type)
- (declare (ignore database db-type))
- (schar val 0))
-
-(defmethod read-sql-value (val (type (eql 'keyword)) database db-type)
- (declare (ignore database db-type))
- (when (< 0 (length val))
- (intern (symbol-name-default-case val)
- (find-package '#:keyword))))
-
-(defmethod read-sql-value (val (type (eql 'symbol)) database db-type)
- (declare (ignore database db-type))
- (when (< 0 (length val))
- (unless (string= val (symbol-name-default-case "NIL"))
- (read-from-string val))))
-
-(defmethod read-sql-value (val (type (eql 'integer)) database db-type)
- (declare (ignore database db-type))
- (etypecase val
- (string
- (unless (string-equal "NIL" val)
- (parse-integer val)))
- (number val)))
-
-(defmethod read-sql-value (val (type (eql 'smallint)) database db-type)
- (declare (ignore database db-type))
- (etypecase val
- (string
- (unless (string-equal "NIL" val)
- (parse-integer val)))
- (number val)))
-
-(defmethod read-sql-value (val (type (eql 'bigint)) database db-type)
- (declare (ignore database db-type))
- (etypecase val
- (string
- (unless (string-equal "NIL" val)
- (parse-integer val)))
- (number val)))
-
-(defmethod read-sql-value (val (type (eql 'float)) database db-type)
- (declare (ignore database db-type))
- ;; writing 1.0 writes 1, so we we *really* want a float, must do (float ...)
- (etypecase val
- (string (float (read-from-string val)))
- (float val)))
-
-(defmethod read-sql-value (val (type (eql 'double-float)) database db-type)
- (declare (ignore database db-type))
- ;; writing 1.0 writes 1, so if we *really* want a float, must do (float ...)
- (etypecase val
- (string (float
- (let ((*read-default-float-format* 'double-float))
- (read-from-string val))
- 1.0d0))
- (double-float val)
- (float (coerce val 'double-float))))
-
-(defmethod read-sql-value (val (type (eql 'boolean)) database db-type)
- (declare (ignore database db-type))
- (equal "t" val))
-
-(defmethod read-sql-value (val (type (eql 'generalized-boolean)) database db-type)
- (declare (ignore database db-type))
- (equal "t" val))
-
-(defmethod read-sql-value (val (type (eql 'number)) database db-type)
- (declare (ignore database db-type))
- (etypecase val
- (string
- (unless (string-equal "NIL" val)
- (read-from-string val)))
- (number val)))
-
-(defmethod read-sql-value (val (type (eql 'universal-time)) database db-type)
- (declare (ignore database db-type))
- (unless (eq 'NULL val)
- (etypecase val
- (string
- (parse-integer val))
- (number val))))
-
-(defmethod read-sql-value (val (type (eql 'wall-time)) database db-type)
- (declare (ignore database db-type))
- (unless (eq 'NULL val)
- (parse-timestring val)))
-
-(defmethod read-sql-value (val (type (eql 'date)) database db-type)
- (declare (ignore database db-type))
- (unless (eq 'NULL val)
- (parse-datestring val)))
-
-(defmethod read-sql-value (val (type (eql 'duration)) database db-type)
- (declare (ignore database db-type))
- (unless (or (eq 'NULL val)
- (equal "NIL" val))
- (parse-timestring val)))
+(defmethod read-sql-value (val (type symbol) database db-type
+ ;; never eval while reading values
+ &aux *read-eval*)
+ ;; TODO: All the read-from-strings in here do not check that
+ ;; what we read was of the correct type, should this change?
+ (unless (or (equalp "nil" val) (eql 'null val))
+ (case type
+ ((string varchar) val)
+ (char (etypecase val
+ (string (schar val 0))
+ (character val)))
+ (keyword
+ (when (< 0 (length val))
+ (intern (symbol-name-default-case val) :keyword)))
+ (symbol
+ (when (< 0 (length val))
+ (intern (symbol-name-default-case val))))
+ ((smallint mediumint bigint integer universal-time)
+ (etypecase val
+ (string (parse-integer val))
+ (number 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)))
+ (float val))
+ (if (eql type 'double-float) 1.0d0 1.0s0)))
+ (number
+ (etypecase val
+ (string (read-from-string val))
+ (number 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))
+ (t (call-next-method)))))
;; ------------------------------------------------------------
;; Logic for 'faulting in' :join slots
(defmethod sql-table ((o select-list))
(sql-expression :table (view-table o)))
-(defun make-select-list (class-and-slots &key (do-joins-p nil))
+(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
;; 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-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)
finally (return (values slots sqls)))
(unless slots
(error "No slots of type :base in view-class ~A" (class-name class)))
- (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)))))))
+ (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
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)))
+ 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))))
#|
#:view-table
#:bigint
#:varchar
+ #:longchar
+ #:text
#:generalized-boolean
#:mediumint
#:smallint
#:*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*
(defun %dataset-init (name)
"Run initialization code and fill database for given dataset."
- ;;find items that looks like '(:setup ...),
- ;; dispatch the rest.
- (let ((setup (rest (find :setup name :key #'first)))
- (sqldata (rest (find :sqldata name :key #'first)))
- (objdata (rest (find :objdata name :key #'first))))
- (when setup
- (%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)))))
+ ;;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
+ (restart-case
(handler-bind ((error #'generic-error))
(let ((cleanup (rest (find :cleanup name :key #'first))))
(when cleanup
(genre :accessor genre :initarg :genre :type (varchar 10) :db-constraints (:default "'Unknown'"))))
(defun initialize-ds-artists ()
- ; (start-sql-recording :type :both)
- ; (let ((*backend-warning-behavior*
- ; (if (member *test-database-type* '(:postgresql :postgresql-socket))
- ; :ignore
- ; :warn)))
(mapc #'clsql:create-view-from-class
'(artist))
(defun initialize-ds-employees ()
;; (start-sql-recording :type :both)
- (let ((*backend-warning-behavior*
- (if (member *test-database-type* '(:postgresql :postgresql-socket))
- :ignore
- :warn)))
- (mapc #'clsql:create-view-from-class
- '(employee company address employee-address)))
-
+ (mapc #'clsql:create-view-from-class
+ '(employee company address employee-address))
(setq *test-start-utime* (get-universal-time))
(let* ((*db-auto-sync* t)
(def-view-class setting (node)
((setting-id :accessor setting-id :initarg :setting-id
- :type integer :db-kind :key :db-constraints (:not-null :auto-increment))
+ :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 :auto-increment))
+ :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 :auto-increment))
+ :type integer :db-kind :key :db-constraints (:not-null ))
(doc :accessor doc :initarg :doc :type (varchar 240)))
(:normalizedp t))
(def-view-class subloc (location)
((subloc-id :accessor subloc-id :initarg :subloc-id
- :type integer :db-kind :key :db-constraints (:not-null :auto-increment))
+ :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)
- (let ((*backend-warning-behavior*
- (if (member *test-database-type* '(:postgresql :postgresql-socket))
- :ignore
- :warn)))
- (mapc #'clsql:create-view-from-class
- '(node setting user theme location subloc)))
+ (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"))))
+ :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"))))
"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-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"))
;; list current tables
(deftest :fddl/table/1
(with-dataset *ds-fddl*
- (sort (mapcar #'string-downcase
- (clsql:list-tables ))
- #'string<))
+ (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
(progn
(let ((*backend-warning-behavior*
(if (member *test-database-type*
- '(:postgresql :postgresql-socket))
+ '(:postgresql :postgresql-socket :postgresql-socket3))
:ignore
:warn)))
(case *test-database-underlying-type*
(progn
(let ((*backend-warning-behavior*
(if (member *test-database-type*
- '(:postgresql :postgresql-socket))
+ '(:postgresql :postgresql-socket :postgresql-socket3))
:ignore
:warn)))
(clsql:create-table [foo] '(([bar] integer :not-null)
(with-dataset *ds-fddl*
(multiple-value-bind (type length scale nullable)
(clsql:attribute-type [c] [alpha])
- (values (clsql-sys:in type :varchar :varchar2) length scale nullable)))
+ (values (clsql-sys:in type :varchar :varchar2 :nvarchar)
+ length scale nullable)))
t 30 nil 1)
(deftest :fddl/attributes/5
being each tuple in
[select [addressid] :from [addr] :order-by [addressid]]
collect addressid))
- (1 2))
+ (1 2 3))
(deftest :fdml/loop/3
(with-dataset *ds-employees*
being each tuple in
[select [addressid] :from [addr] :order-by [addressid]]
collect addressid))
- (1 2))
+ (1 2 3))
;; inserts a record using all values only and then deletes it
(deftest :fdml/insert/1
(let ((test (second test-form)))
(cond
((and (not (eql db-underlying-type :mysql))
- (clsql-sys:in test :connection/query-command))
+ (clsql-sys:in test :connection/query-command
+ :basic/reallybigintegers/1))
(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))
(progn
(clsql:update-records [node]
:av-pairs '(([title] "altered title"))
- :where [= [node-id] 9])
+ :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] 11])
+ :where [= [subloc-id] (subloc-id subloc2)])
(clsql:update-slot-from-record subloc2 'loc)
(print-subloc subloc2)))))
"9: location-2" "11: second subloc"
(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)"
+ (error "Couldn't load foreign librar~@P ~{~S~^, ~}. (searched ~S: ~S)"
(length filenames) filenames
- 'clsql:*foreign-library-search-paths*)))))
+ '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*
"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 *uffi-library-loaded* nil
- "T if foreign library was able to be loaded successfully")
-
-(defun load-uffi-foreign-library ()
- (clsql:push-library-path clsql-uffi-system::*clsql-uffi-library-dir*)
- (find-and-load-foreign-library *clsql-uffi-library-filenames*
- :module "clsql-uffi"
- :supporting-libraries
- *clsql-uffi-supporting-libraries*)
- (setq *uffi-library-loaded* t))
-
-(load-uffi-foreign-library)
#:atoi
#:atol
#:atof
- #:atol64
#:make-64-bit-integer
#:make-128-bit-integer
#:split-64-bit-integer)
(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)
((str (* :unsigned-char)))
:returning :double)
-(uffi:def-function "atol64"
- ((str (* :unsigned-char))
- (high32 (* :unsigned-int)))
- :module "clsql-uffi"
- :returning :unsigned-int)
-
(uffi:def-constant +2^32+ 4294967296)
(uffi:def-constant +2^64+ 18446744073709551616)
(uffi:def-constant +2^32-1+ (1- +2^32+))
(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))
- (cond
- ((uffi:null-pointer-p char-ptr)
- nil)
- (t
+ (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 :uint64)
- (uffi:with-foreign-object (high32-ptr :unsigned-int)
- (let ((low32 (atol64 char-ptr high32-ptr))
- (high32 (uffi:deref-pointer high32-ptr :unsigned-int)))
- (if (zerop high32)
- low32
- (make-64-bit-integer high32 low32)))))
+ (: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
- (if encoding
- (if length
- (uffi:convert-from-foreign-string char-ptr
- :null-terminated-p nil
- :length length
- :encoding encoding)
- (uffi:convert-from-foreign-string char-ptr
- :null-terminated-p t
- :encoding encoding))
- (if length
- (uffi:convert-from-foreign-string char-ptr
- :null-terminated-p nil
- :length length)
- (uffi:convert-from-foreign-string char-ptr
- :null-terminated-p 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)))))
projects / clsql.git / commitdiff