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.
+
+
;;;;
;;;; 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)
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))
+++ /dev/null
-;;;; -*- 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)))
-|#
(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))
+++ /dev/null
-;;;; -*- 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)))
-|#
;;;;
;;;; 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.
(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))
+++ /dev/null
-;;;; -*- 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)))
-|#
;;;; *************************************************************************
;;;; 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)))
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)))
+++ /dev/null
-;;;; -*- 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
projects / clsql.git / commitdiff