From: Kevin M. Rosenberg Date: Wed, 7 Apr 2004 15:52:28 +0000 (+0000) Subject: r8849: fold db-*/*-usql files into db-*/*-sql files X-Git-Tag: v3.8.6~726 X-Git-Url: http://git.kpe.io/?p=clsql.git;a=commitdiff_plain;h=e2c86e8c664d8b3ecfd215843a9a1fbf5fa83693 r8849: fold db-*/*-usql files into db-*/*-sql files --- diff --git a/ChangeLog b/ChangeLog index 3643de2..080c257 100644 --- a/ChangeLog +++ b/ChangeLog @@ -181,3 +181,16 @@ 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. + + diff --git a/db-mysql/mysql-sql.lisp b/db-mysql/mysql-sql.lisp index afadd6c..7a59077 100644 --- a/db-mysql/mysql-sql.lisp +++ b/db-mysql/mysql-sql.lisp @@ -4,35 +4,15 @@ ;;;; ;;;; Name: mysql-sql.lisp ;;;; Purpose: High-level MySQL interface using UFFI -;;;; Programmers: Kevin M. Rosenberg based on -;;;; Original code by Pierre R. Mai ;;;; Date Started: Feb 2002 ;;;; ;;;; $Id$ ;;;; -;;;; This file, part of CLSQL, is Copyright (c) 2002 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. ;;;; ************************************************************************* -(eval-when (:compile-toplevel) - (declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))) - -;;;; Modified by Kevin Rosenberg, Feb 20002 -;;;; -- 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. -;;;; -;;;; Mar 2002 -;;;; Added field types - (defpackage #:clsql-mysql (:use #:common-lisp #:clsql-base-sys #:mysql #:clsql-uffi) (:export #:mysql-database) @@ -309,5 +289,130 @@ list))) +;; Table and attribute introspection + +(defmethod database-list-tables ((database mysql-database) &key (owner nil)) + (declare (ignore owner)) + (remove-if #'(lambda (s) + (and (>= (length s) 10) + (string= (subseq s 0 10) "_usql_seq_"))) + (mapcar #'car (database-query "SHOW TABLES" database nil)))) + +;; MySQL 4.1 does not support views +(defmethod database-list-views ((database mysql-database) + &key (owner nil)) + (declare (ignore owner)) + nil) + +(defmethod database-list-indexes ((database mysql-database) + &key (owner nil)) + (let ((result '())) + (dolist (table (database-list-tables database :owner owner) result) + (mapc #'(lambda (index) (push (nth 2 index) result)) + (database-query + (format nil "SHOW INDEX FROM ~A" (string-upcase table)) + database nil))))) + +(defmethod database-list-attributes ((table string) (database mysql-database) + &key (owner nil)) + (declare (ignore owner)) + (mapcar #'car + (database-query + (format nil "SHOW COLUMNS FROM ~A" table) + database nil))) + +(defmethod database-attribute-type (attribute (table string) + (database mysql-database) + &key (owner nil)) + (declare (ignore owner)) + (let ((result + (mapcar #'cadr + (database-query + (format nil + "SHOW COLUMNS FROM ~A LIKE '~A'" table attribute) + database nil)))) + (let* ((str (car result)) + (end-str (position #\( str)) + (substr (subseq str 0 end-str))) + (if substr + (intern (string-upcase substr) :keyword) nil)))) + +;;; Sequence functions + +(defun %sequence-name-to-table (sequence-name) + (concatenate 'string "_usql_seq_" (sql-escape sequence-name))) + +(defun %table-name-to-sequence-name (table-name) + (and (>= (length table-name) 10) + (string= (subseq table-name 0 10) "_usql_seq_") + (subseq table-name 10))) + +(defmethod database-create-sequence (sequence-name + (database mysql-database)) + (let ((table-name (%sequence-name-to-table sequence-name))) + (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)) + +(defmethod database-list-sequences ((database mysql-database) + &key (owner nil)) + (declare (ignore owner)) + (mapcar #'(lambda (s) (%table-name-to-sequence-name (car s))) + (database-query "SHOW TABLES LIKE '%usql_seq%'" + database 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) + position) + database) + (mysql:mysql-insert-id (clsql-mysql::database-mysql-ptr database))) + +(defmethod database-sequence-next (sequence-name (database mysql-database)) + (database-execute-command + (concatenate 'string "UPDATE " (%sequence-name-to-table sequence-name) + " 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)) + (declare (ignore sequence-name))) + +;; Functions depending upon high-level CommonSQL classes/functions +#| +(defmethod database-output-sql ((expr clsql-sys::sql-typecast-exp) + (database mysql-database)) + (with-slots (clsql-sys::modifier clsql-sys::components) + expr + (if clsql-sys::modifier + (progn + (clsql-sys::output-sql clsql-sys::components database) + (write-char #\: sql-sys::*sql-stream*) + (write-char #\: sql-sys::*sql-stream*) + (write-string (symbol-name clsql-sys::modifier) + clsql-sys::*sql-stream*))))) + +(defmethod database-output-sql-as-type ((type (eql 'integer)) val + (database mysql-database)) + ;; typecast it so it uses the indexes + (when val + (make-instance 'clsql-sys::sql-typecast-exp + :modifier 'int8 + :components val))) +|# + (when (clsql-base-sys:database-type-library-loaded :mysql) (clsql-base-sys:initialize-database-type :database-type :mysql)) diff --git a/db-mysql/mysql-usql.lisp b/db-mysql/mysql-usql.lisp deleted file mode 100644 index e14d31f..0000000 --- a/db-mysql/mysql-usql.lisp +++ /dev/null @@ -1,148 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ************************************************************************* -;;;; FILE IDENTIFICATION -;;;; -;;;; Name: mysql-usql.cl -;;;; Purpose: MySQL interface functions to support UncommonSQL -;;;; Programmers: Kevin M. Rosenberg and onShore Development Inc -;;;; Date Started: Mar 2002 -;;;; -;;;; $Id$ -;;;; -;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg -;;;; and by 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-mysql) - -;; Table and attribute introspection - -(defmethod database-list-tables ((database mysql-database) &key (owner nil)) - (declare (ignore owner)) - (remove-if #'(lambda (s) - (and (>= (length s) 10) - (string= (subseq s 0 10) "_usql_seq_"))) - (mapcar #'car (database-query "SHOW TABLES" database nil)))) - -;; MySQL 4.1 does not support views -(defmethod database-list-views ((database mysql-database) - &key (owner nil)) - (declare (ignore owner)) - nil) - -(defmethod database-list-indexes ((database mysql-database) - &key (owner nil)) - (let ((result '())) - (dolist (table (database-list-tables database :owner owner) result) - (mapc #'(lambda (index) (push (nth 2 index) result)) - (database-query - (format nil "SHOW INDEX FROM ~A" (string-upcase table)) - database nil))))) - -(defmethod database-list-attributes ((table string) (database mysql-database) - &key (owner nil)) - (declare (ignore owner)) - (mapcar #'car - (database-query - (format nil "SHOW COLUMNS FROM ~A" table) - database nil))) - -(defmethod database-attribute-type (attribute (table string) - (database mysql-database) - &key (owner nil)) - (declare (ignore owner)) - (let ((result - (mapcar #'cadr - (database-query - (format nil - "SHOW COLUMNS FROM ~A LIKE '~A'" table attribute) - database nil)))) - (let* ((str (car result)) - (end-str (position #\( str)) - (substr (subseq str 0 end-str))) - (if substr - (intern (string-upcase substr) :keyword) nil)))) - -;;; Sequence functions - -(defun %sequence-name-to-table (sequence-name) - (concatenate 'string "_usql_seq_" (sql-escape sequence-name))) - -(defun %table-name-to-sequence-name (table-name) - (and (>= (length table-name) 10) - (string= (subseq table-name 0 10) "_usql_seq_") - (subseq table-name 10))) - -(defmethod database-create-sequence (sequence-name - (database mysql-database)) - (let ((table-name (%sequence-name-to-table sequence-name))) - (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)) - -(defmethod database-list-sequences ((database mysql-database) - &key (owner nil)) - (declare (ignore owner)) - (mapcar #'(lambda (s) (%table-name-to-sequence-name (car s))) - (database-query "SHOW TABLES LIKE '%usql_seq%'" - database 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) - position) - database) - (mysql:mysql-insert-id (clsql-mysql::database-mysql-ptr database))) - -(defmethod database-sequence-next (sequence-name (database mysql-database)) - (database-execute-command - (concatenate 'string "UPDATE " (%sequence-name-to-table sequence-name) - " 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)) - (declare (ignore sequence-name))) - -;; Misc USQL functions - -#| -#+ignore -(defmethod database-output-sql ((expr clsql-sys::sql-typecast-exp) - (database mysql-database)) - (with-slots (clsql-sys::modifier clsql-sys::components) - expr - (if clsql-sys::modifier - (progn - (clsql-sys::output-sql clsql-sys::components database) - (write-char #\: sql-sys::*sql-stream*) - (write-char #\: sql-sys::*sql-stream*) - (write-string (symbol-name clsql-sys::modifier) - clsql-sys::*sql-stream*))))) - -#+ignore -(defmethod database-output-sql-as-type ((type (eql 'integer)) val - (database mysql-database)) - ;; typecast it so it uses the indexes - (when val - (make-instance 'clsql-sys::sql-typecast-exp - :modifier 'int8 - :components val))) -|# diff --git a/db-postgresql-socket/postgresql-socket-sql.lisp b/db-postgresql-socket/postgresql-socket-sql.lisp index 176dfcb..cdaa9e8 100644 --- a/db-postgresql-socket/postgresql-socket-sql.lisp +++ b/db-postgresql-socket/postgresql-socket-sql.lisp @@ -310,5 +310,145 @@ doesn't depend on UFFI." (setf (postgresql-socket-result-set-done result-set) t) (wait-for-query-results (database-connection database))))))) +;;; Object listing + +(defmethod database-list-objects-of-type ((database postgresql-socket-database) + type owner) + (let ((owner-clause + (cond ((stringp owner) + (format nil " AND (relowner=(SELECT usesysid FROM pg_user WHERE (usename='~A')))" owner)) + ((null owner) + (format nil " AND (NOT (relowner=1))")) + (t "")))) + (mapcar #'car + (database-query + (format nil + "SELECT relname FROM pg_class WHERE (relkind = '~A')~A" + type + owner-clause) + database nil)))) + +(defmethod database-list-tables ((database postgresql-socket-database) + &key (owner nil)) + (database-list-objects-of-type database "r" owner)) + +(defmethod database-list-views ((database postgresql-socket-database) + &key (owner nil)) + (database-list-objects-of-type database "v" owner)) + +(defmethod database-list-indexes ((database postgresql-socket-database) + &key (owner nil)) + (database-list-objects-of-type database "i" owner)) + +(defmethod database-list-attributes ((table string) + (database postgresql-socket-database) + &key (owner nil)) + (let* ((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 relname='~A'~A" + (string-downcase table) + owner-clause) + database nil)))) + (if result + (reverse + (remove-if #'(lambda (it) (member it '("cmin" + "cmax" + "xmax" + "xmin" + "oid" + "ctid" + ;; kmr -- added tableoid + "tableoid") :test #'equal)) + result))))) + +(defmethod database-attribute-type (attribute (table string) + (database postgresql-socket-database) + &key (owner nil)) + (let* ((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 pg_type.typname 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) + database nil)))) + (when result + (intern (string-upcase (car result)) :keyword)))) + +(defmethod database-create-sequence (sequence-name + (database postgresql-socket-database)) + (database-execute-command + (concatenate 'string "CREATE SEQUENCE " (sql-escape sequence-name)) + database)) + +(defmethod database-drop-sequence (sequence-name + (database postgresql-socket-database)) + (database-execute-command + (concatenate 'string "DROP SEQUENCE " (sql-escape sequence-name)) database)) + +(defmethod database-list-sequences ((database postgresql-socket-database) + &key (owner nil)) + (database-list-objects-of-type database "S" owner)) + +(defmethod database-set-sequence-position (name (position integer) + (database postgresql-socket-database)) + (values + (parse-integer + (caar + (database-query + (format nil "SELECT SETVAL ('~A', ~A)" name position) + database nil))))) + +(defmethod database-sequence-next (sequence-name + (database postgresql-socket-database)) + (values + (parse-integer + (caar + (database-query + (concatenate 'string "SELECT NEXTVAL ('" (sql-escape sequence-name) "')") + database nil))))) + +(defmethod database-sequence-last (sequence-name (database postgresql-socket-database)) + (values + (parse-integer + (caar + (database-query + (concatenate 'string "SELECT LAST_VALUE ('" sequence-name "')") + database nil))))) + + +;; Functions depending upon high-level CommonSQL classes/functions +#| +(defmethod database-output-sql ((expr clsql-sys::sql-typecast-exp) + (database postgresql-socket-database)) + (with-slots (clsql-sys::modifier clsql-sys::components) + expr + (if clsql-sys::modifier + (progn + (clsql-sys::output-sql clsql-sys::components database) + (write-char #\: clsql-sys::*sql-stream*) + (write-char #\: clsql-sys::*sql-stream*) + (write-string (symbol-name clsql-sys::modifier) + clsql-sys::*sql-stream*))))) + +(defmethod database-output-sql-as-type ((type (eql 'integer)) val + (database postgresql-socket-database)) + (when val ;; typecast it so it uses the indexes + (make-instance 'clsql-sys::sql-typecast-exp + :modifier 'int8 + :components val))) +|# + (when (clsql-base-sys:database-type-library-loaded :postgresql-socket) (clsql-base-sys:initialize-database-type :database-type :postgresql-socket)) diff --git a/db-postgresql-socket/postgresql-socket-usql.lisp b/db-postgresql-socket/postgresql-socket-usql.lisp deleted file mode 100644 index 3c134e2..0000000 --- a/db-postgresql-socket/postgresql-socket-usql.lisp +++ /dev/null @@ -1,160 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ************************************************************************* -;;;; FILE IDENTIFICATION -;;;; -;;;; Name: postgresql-socket-usql.sql -;;;; Purpose: PostgreSQL interface for USQL routines -;;;; Programmers: Kevin M. Rosenberg and onShore Development Inc -;;;; Date Started: Mar 2002 -;;;; -;;;; $Id: postgresql-socket-usql.lisp 7061 2003-09-07 06:34:45Z kevin $ -;;;; -;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg -;;;; and by 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-postgresql-socket) - - -(defmethod database-list-objects-of-type ((database postgresql-socket-database) - type owner) - (let ((owner-clause - (cond ((stringp owner) - (format nil " AND (relowner=(SELECT usesysid FROM pg_user WHERE (usename='~A')))" owner)) - ((null owner) - (format nil " AND (NOT (relowner=1))")) - (t "")))) - (mapcar #'car - (database-query - (format nil - "SELECT relname FROM pg_class WHERE (relkind = '~A')~A" - type - owner-clause) - database nil)))) - -(defmethod database-list-tables ((database postgresql-socket-database) - &key (owner nil)) - (database-list-objects-of-type database "r" owner)) - -(defmethod database-list-views ((database postgresql-socket-database) - &key (owner nil)) - (database-list-objects-of-type database "v" owner)) - -(defmethod database-list-indexes ((database postgresql-socket-database) - &key (owner nil)) - (database-list-objects-of-type database "i" owner)) - -(defmethod database-list-attributes ((table string) - (database postgresql-socket-database) - &key (owner nil)) - (let* ((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 relname='~A'~A" - (string-downcase table) - owner-clause) - database nil)))) - (if result - (reverse - (remove-if #'(lambda (it) (member it '("cmin" - "cmax" - "xmax" - "xmin" - "oid" - "ctid" - ;; kmr -- added tableoid - "tableoid") :test #'equal)) - result))))) - -(defmethod database-attribute-type (attribute (table string) - (database postgresql-socket-database) - &key (owner nil)) - (let* ((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 pg_type.typname 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) - database nil)))) - (when result - (intern (string-upcase (car result)) :keyword)))) - -(defmethod database-create-sequence (sequence-name - (database postgresql-socket-database)) - (database-execute-command - (concatenate 'string "CREATE SEQUENCE " (sql-escape sequence-name)) - database)) - -(defmethod database-drop-sequence (sequence-name - (database postgresql-socket-database)) - (database-execute-command - (concatenate 'string "DROP SEQUENCE " (sql-escape sequence-name)) database)) - -(defmethod database-list-sequences ((database postgresql-socket-database) - &key (owner nil)) - (database-list-objects-of-type database "S" owner)) - -(defmethod database-set-sequence-position (name (position integer) - (database postgresql-socket-database)) - (values - (parse-integer - (caar - (database-query - (format nil "SELECT SETVAL ('~A', ~A)" name position) - database nil))))) - -(defmethod database-sequence-next (sequence-name - (database postgresql-socket-database)) - (values - (parse-integer - (caar - (database-query - (concatenate 'string "SELECT NEXTVAL ('" (sql-escape sequence-name) "')") - database nil))))) - -(defmethod database-sequence-last (sequence-name (database postgresql-socket-database)) - (values - (parse-integer - (caar - (database-query - (concatenate 'string "SELECT LAST_VALUE ('" sequence-name "')") - database nil))))) - - -;; Functions depending upon high-level USQL classes/functions - -#| -(defmethod database-output-sql ((expr clsql-sys::sql-typecast-exp) - (database postgresql-socket-database)) - (with-slots (clsql-sys::modifier clsql-sys::components) - expr - (if clsql-sys::modifier - (progn - (clsql-sys::output-sql clsql-sys::components database) - (write-char #\: clsql-sys::*sql-stream*) - (write-char #\: clsql-sys::*sql-stream*) - (write-string (symbol-name clsql-sys::modifier) - clsql-sys::*sql-stream*))))) - -(defmethod database-output-sql-as-type ((type (eql 'integer)) val - (database postgresql-socket-database)) - (when val ;; typecast it so it uses the indexes - (make-instance 'clsql-sys::sql-typecast-exp - :modifier 'int8 - :components val))) -|# diff --git a/db-postgresql/postgresql-sql.lisp b/db-postgresql/postgresql-sql.lisp index 09b72e7..c268b82 100644 --- a/db-postgresql/postgresql-sql.lisp +++ b/db-postgresql/postgresql-sql.lisp @@ -4,15 +4,10 @@ ;;;; ;;;; Name: postgresql-sql.lisp ;;;; Purpose: High-level PostgreSQL interface using UFFI -;;;; Programmers: Kevin M. Rosenberg based on -;;;; Original code by Pierre R. Mai ;;;; Date Started: Feb 2002 ;;;; ;;;; $Id$ ;;;; -;;;; This file, part of CLSQL, is Copyright (c) 2002 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. @@ -362,5 +357,146 @@ (defmethod database-delete-large-object (object-id (database postgresql-database)) (lo-unlink (database-conn-ptr database) object-id)) + +;;; Object listing + +(defmethod database-list-objects-of-type ((database postgresql-database) + type owner) + (let ((owner-clause + (cond ((stringp owner) + (format nil " AND (relowner=(SELECT usesysid FROM pg_user WHERE (usename='~A')))" owner)) + ((null owner) + (format nil " AND (NOT (relowner=1))")) + (t "")))) + (mapcar #'car + (database-query + (format nil + "SELECT relname FROM pg_class WHERE (relkind = '~A')~A" + type + owner-clause) + database nil)))) + +(defmethod database-list-tables ((database postgresql-database) + &key (owner nil)) + (database-list-objects-of-type database "r" owner)) + +(defmethod database-list-views ((database postgresql-database) + &key (owner nil)) + (database-list-objects-of-type database "v" owner)) + +(defmethod database-list-indexes ((database postgresql-database) + &key (owner nil)) + (database-list-objects-of-type database "i" owner)) + +(defmethod database-list-attributes ((table string) + (database postgresql-database) + &key (owner nil)) + (let* ((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 relname='~A'~A" + (string-downcase table) + owner-clause) + database nil)))) + (if result + (reverse + (remove-if #'(lambda (it) (member it '("cmin" + "cmax" + "xmax" + "xmin" + "oid" + "ctid" + ;; kmr -- added tableoid + "tableoid") :test #'equal)) + result))))) + +(defmethod database-attribute-type (attribute (table string) + (database postgresql-database) + &key (owner nil)) + (let* ((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 pg_type.typname 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) + database nil)))) + (when result + (intern (string-upcase (car result)) :keyword)))) + +(defmethod database-create-sequence (sequence-name + (database postgresql-database)) + (database-execute-command + (concatenate 'string "CREATE SEQUENCE " (sql-escape sequence-name)) + database)) + +(defmethod database-drop-sequence (sequence-name + (database postgresql-database)) + (database-execute-command + (concatenate 'string "DROP SEQUENCE " (sql-escape sequence-name)) database)) + +(defmethod database-list-sequences ((database postgresql-database) + &key (owner nil)) + (database-list-objects-of-type database "S" owner)) + +(defmethod database-set-sequence-position (name (position integer) + (database postgresql-database)) + (values + (parse-integer + (caar + (database-query + (format nil "SELECT SETVAL ('~A', ~A)" name position) + database nil))))) + +(defmethod database-sequence-next (sequence-name + (database postgresql-database)) + (values + (parse-integer + (caar + (database-query + (concatenate 'string "SELECT NEXTVAL ('" (sql-escape sequence-name) "')") + database nil))))) + +(defmethod database-sequence-last (sequence-name (database postgresql-database)) + (values + (parse-integer + (caar + (database-query + (concatenate 'string "SELECT LAST_VALUE ('" sequence-name "')") + database nil))))) + + +;; Functions depending upon high-level CommonSQL classes/functions +#| +(defmethod database-output-sql ((expr clsql-sys::sql-typecast-exp) + (database postgresql-database)) + (with-slots (clsql-sys::modifier clsql-sys::components) + expr + (if clsql-sys::modifier + (progn + (clsql-sys::output-sql clsql-sys::components database) + (write-char #\: clsql-sys::*sql-stream*) + (write-char #\: clsql-sys::*sql-stream*) + (write-string (symbol-name clsql-sys::modifier) + clsql-sys::*sql-stream*))))) + +(defmethod database-output-sql-as-type ((type (eql 'integer)) val + (database postgresql-database)) + (when val ;; typecast it so it uses the indexes + (make-instance 'clsql-sys::sql-typecast-exp + :modifier 'int8 + :components val))) +|# + (when (clsql-base-sys:database-type-library-loaded :postgresql) (clsql-base-sys:initialize-database-type :database-type :postgresql)) diff --git a/db-postgresql/postgresql-usql.lisp b/db-postgresql/postgresql-usql.lisp deleted file mode 100644 index ef85e7d..0000000 --- a/db-postgresql/postgresql-usql.lisp +++ /dev/null @@ -1,160 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ************************************************************************* -;;;; FILE IDENTIFICATION -;;;; -;;;; Name: postgresql-usql.sql -;;;; Purpose: PostgreSQL interface for USQL routines -;;;; Programmers: Kevin M. Rosenberg and onShore Development Inc -;;;; Date Started: Mar 2002 -;;;; -;;;; $Id$ -;;;; -;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg -;;;; and by 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-postgresql) - - -(defmethod database-list-objects-of-type ((database postgresql-database) - type owner) - (let ((owner-clause - (cond ((stringp owner) - (format nil " AND (relowner=(SELECT usesysid FROM pg_user WHERE (usename='~A')))" owner)) - ((null owner) - (format nil " AND (NOT (relowner=1))")) - (t "")))) - (mapcar #'car - (database-query - (format nil - "SELECT relname FROM pg_class WHERE (relkind = '~A')~A" - type - owner-clause) - database nil)))) - -(defmethod database-list-tables ((database postgresql-database) - &key (owner nil)) - (database-list-objects-of-type database "r" owner)) - -(defmethod database-list-views ((database postgresql-database) - &key (owner nil)) - (database-list-objects-of-type database "v" owner)) - -(defmethod database-list-indexes ((database postgresql-database) - &key (owner nil)) - (database-list-objects-of-type database "i" owner)) - -(defmethod database-list-attributes ((table string) - (database postgresql-database) - &key (owner nil)) - (let* ((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 relname='~A'~A" - (string-downcase table) - owner-clause) - database nil)))) - (if result - (reverse - (remove-if #'(lambda (it) (member it '("cmin" - "cmax" - "xmax" - "xmin" - "oid" - "ctid" - ;; kmr -- added tableoid - "tableoid") :test #'equal)) - result))))) - -(defmethod database-attribute-type (attribute (table string) - (database postgresql-database) - &key (owner nil)) - (let* ((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 pg_type.typname 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) - database nil)))) - (when result - (intern (string-upcase (car result)) :keyword)))) - -(defmethod database-create-sequence (sequence-name - (database postgresql-database)) - (database-execute-command - (concatenate 'string "CREATE SEQUENCE " (sql-escape sequence-name)) - database)) - -(defmethod database-drop-sequence (sequence-name - (database postgresql-database)) - (database-execute-command - (concatenate 'string "DROP SEQUENCE " (sql-escape sequence-name)) database)) - -(defmethod database-list-sequences ((database postgresql-database) - &key (owner nil)) - (database-list-objects-of-type database "S" owner)) - -(defmethod database-set-sequence-position (name (position integer) - (database postgresql-database)) - (values - (parse-integer - (caar - (database-query - (format nil "SELECT SETVAL ('~A', ~A)" name position) - database nil))))) - -(defmethod database-sequence-next (sequence-name - (database postgresql-database)) - (values - (parse-integer - (caar - (database-query - (concatenate 'string "SELECT NEXTVAL ('" (sql-escape sequence-name) "')") - database nil))))) - -(defmethod database-sequence-last (sequence-name (database postgresql-database)) - (values - (parse-integer - (caar - (database-query - (concatenate 'string "SELECT LAST_VALUE ('" sequence-name "')") - database nil))))) - - -;; Functions depending upon high-level USQL classes/functions - -#| -(defmethod database-output-sql ((expr clsql-sys::sql-typecast-exp) - (database postgresql-database)) - (with-slots (clsql-sys::modifier clsql-sys::components) - expr - (if clsql-sys::modifier - (progn - (clsql-sys::output-sql clsql-sys::components database) - (write-char #\: clsql-sys::*sql-stream*) - (write-char #\: clsql-sys::*sql-stream*) - (write-string (symbol-name clsql-sys::modifier) - clsql-sys::*sql-stream*))))) - -(defmethod database-output-sql-as-type ((type (eql 'integer)) val - (database postgresql-database)) - (when val ;; typecast it so it uses the indexes - (make-instance 'clsql-sys::sql-typecast-exp - :modifier 'int8 - :components val))) -|# diff --git a/db-sqlite/sqlite-sql.lisp b/db-sqlite/sqlite-sql.lisp index a2526ed..24b4727 100644 --- a/db-sqlite/sqlite-sql.lisp +++ b/db-sqlite/sqlite-sql.lisp @@ -2,23 +2,22 @@ ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; -;;;; Name: sqlite-sql.lisp -;;;; Purpose: High-level SQLite interface -;;;; Programmers: Aurelio Bignoli -;;;; Date Started: Aug 2003 +;;;; Name: sqlite-sql.lisp +;;;; Purpose: High-level SQLite interface +;;;; Authors: Aurelio Bignoli and Marcus Pearce +;;;; Created: Aug 2003 ;;;; ;;;; $Id: sqlite-sql.lisp,v 1.5 2004/03/09 20:57:44 aurelio Exp $ ;;;; -;;;; This file, part of CLSQL, is Copyright (c) 2003 by Aurelio Bignoli +;;;; This file, part of CLSQL, is Copyright (c) 2003 by Aurelio Bignoli 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. ;;;; ************************************************************************* -(declaim (optimize (speed 3) (debug 0) (safety 0))) - -(in-package :clsql-sqlite) +(in-package #:clsql-sqlite) (defclass sqlite-database (database) ((sqlite-db :initarg :sqlite-db :accessor sqlite-db))) @@ -180,3 +179,107 @@ row i))) #-clisp (sqlite:sqlite-free-row row) t)))) + +;;; Object listing + +(defmethod database-list-tables ((database sqlite-database) &key owner) + (declare (ignore owner)) + ;; Query is copied from .table command of sqlite comamnd line utility. + (remove-if #'(lambda (s) + (and (>= (length s) 10) + (string= (subseq s 0 10) "_usql_seq_"))) + (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 '())))) + +(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))) + +(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))) + +(declaim (inline sqlite-table-info)) +(defun sqlite-table-info (table database) + (database-query (format nil "PRAGMA table_info('~A')" table) + database '())) + +(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 (third field-info))) + +(defun %sequence-name-to-table-name (sequence-name) + (concatenate 'string "_usql_seq_" (sql-escape sequence-name))) + +(defun %table-name-to-sequence-name (table-name) + (and (>= (length table-name) 10) + (string= (subseq table-name 0 10) "_usql_seq_") + (subseq table-name 10))) + +(defmethod database-create-sequence (sequence-name + (database sqlite-database)) + (let ((table-name (%sequence-name-to-table-name sequence-name))) + (database-execute-command + (concatenate 'string "CREATE TABLE " table-name + " (id INTEGER PRIMARY KEY)") + database) + (database-execute-command + (format nil "INSERT INTO ~A VALUES (-1)" table-name) + database))) + +(defmethod database-drop-sequence (sequence-name + (database sqlite-database)) + (database-execute-command + (concatenate 'string "DROP TABLE " + (%sequence-name-to-table-name sequence-name)) + database)) + +(defmethod database-list-sequences ((database sqlite-database) + &key (owner nil)) + (declare (ignore owner)) + (mapcan #'(lambda (s) + (let ((sn (%table-name-to-sequence-name (car s)))) + (and sn (list sn)))) + (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 '()))) + +(defmethod database-sequence-next (sequence-name (database sqlite-database)) + (let ((table-name (%sequence-name-to-table-name sequence-name))) + (database-execute-command + (format nil "UPDATE ~A SET id=(SELECT id FROM ~A)+1" + table-name table-name) + database) + (sqlite:sqlite-last-insert-rowid (sqlite-db database)) + (parse-integer + (caar (database-query (format nil "SELECT id from ~A" table-name) + database nil))))) + +(defmethod database-set-sequence-position (sequence-name + (position integer) + (database sqlite-database)) + (let ((table-name (%sequence-name-to-table-name sequence-name))) + (database-execute-command + (format nil "UPDATE ~A SET id=~A" table-name position) + database) + (sqlite:sqlite-last-insert-rowid (sqlite-db database)))) + +(defmethod database-sequence-last (sequence-name (database sqlite-database)) + (declare (ignore sequence-name database))) diff --git a/db-sqlite/sqlite-usql.lisp b/db-sqlite/sqlite-usql.lisp deleted file mode 100644 index 852cf92..0000000 --- a/db-sqlite/sqlite-usql.lisp +++ /dev/null @@ -1,121 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ************************************************************************* -;;;; FILE IDENTIFICATION -;;;; -;;;; Name: sqlite-usql.lisp -;;;; Purpose: SQLite interface for USQL routines -;;;; Programmers: Aurelio Bignoli -;;;; Date Started: Aug 2003 -;;;; -;;;; $Id: sqlite-usql.lisp,v 1.3 2004/03/09 20:58:38 aurelio Exp $ -;;;; -;;;; 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) - -(defmethod database-list-tables ((database sqlite-database) &key owner) - (declare (ignore owner)) - ;; Query is copied from .table command of sqlite comamnd line utility. - (remove-if #'(lambda (s) - (and (>= (length s) 10) - (string= (subseq s 0 10) "_usql_seq_"))) - (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 '())))) - -(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))) - -(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))) - -(declaim (inline sqlite-table-info)) -(defun sqlite-table-info (table database) - (database-query (format nil "PRAGMA table_info('~A')" table) - database '())) - -(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 (third field-info))) - -(defun %sequence-name-to-table-name (sequence-name) - (concatenate 'string "_usql_seq_" (sql-escape sequence-name))) - -(defun %table-name-to-sequence-name (table-name) - (and (>= (length table-name) 10) - (string= (subseq table-name 0 10) "_usql_seq_") - (subseq table-name 10))) - -(defmethod database-create-sequence (sequence-name - (database sqlite-database)) - (let ((table-name (%sequence-name-to-table-name sequence-name))) - (database-execute-command - (concatenate 'string "CREATE TABLE " table-name - " (id INTEGER PRIMARY KEY)") - database) - (database-execute-command - (format nil "INSERT INTO ~A VALUES (-1)" table-name) - database))) - -(defmethod database-drop-sequence (sequence-name - (database sqlite-database)) - (database-execute-command - (concatenate 'string "DROP TABLE " - (%sequence-name-to-table-name sequence-name)) - database)) - -(defmethod database-list-sequences ((database sqlite-database) - &key (owner nil)) - (declare (ignore owner)) - (mapcan #'(lambda (s) - (let ((sn (%table-name-to-sequence-name (car s)))) - (and sn (list sn)))) - (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 '()))) - -(defmethod database-sequence-next (sequence-name (database sqlite-database)) - (let ((table-name (%sequence-name-to-table-name sequence-name))) - (database-execute-command - (format nil "UPDATE ~A SET id=(SELECT id FROM ~A)+1" - table-name table-name) - database) - (sqlite:sqlite-last-insert-rowid (sqlite-db database)) - (parse-integer - (caar (database-query (format nil "SELECT id from ~A" table-name) - database nil))))) - -(defmethod database-set-sequence-position (sequence-name - (position integer) - (database sqlite-database)) - (let ((table-name (%sequence-name-to-table-name sequence-name))) - (database-execute-command - (format nil "UPDATE ~A SET id=~A" table-name position) - database) - (sqlite:sqlite-last-insert-rowid (sqlite-db database)))) - -(defmethod database-sequence-last (sequence-name (database sqlite-database)) - (declare (ignore sequence-name database))) \ No newline at end of file