X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=clsql%2Fsql.cl;fp=clsql%2Fsql.cl;h=1adedf773ecab149d98fedb038975768aa52286e;hb=6141152b9819fc7fc9fed8eaf60d5aaa461f8463;hp=0000000000000000000000000000000000000000;hpb=42a951e9f7152e7c145958f4dfed41d4e865c9fd;p=clsql.git

diff --git a/clsql/sql.cl b/clsql/sql.cl
new file mode 100644
index 0000000..1adedf7
--- /dev/null
+++ b/clsql/sql.cl
@@ -0,0 +1,262 @@
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          sql.cl
+;;;; Purpose:       High-level SQL interface
+;;;; Programmers:   Kevin M. Rosenberg based on
+;;;;                 Original code by Pierre R. Mai 
+;;;; Date Started:  Feb 2002
+;;;;
+;;;; $Id: sql.cl,v 1.1 2002/08/01 03:06:26 kevin Exp $
+;;;;
+;;;; 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.
+;;;; *************************************************************************
+
+(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
+(in-package :clsql-sys)
+
+;;; Modified by KMR 
+;;; - to use CMUCL-COMPAT library 
+;;; - fix format strings in error messages 
+;;; - use field types
+
+
+;;; Simple implementation of SQL along the lines of Harlequin's Common SQL
+
+
+;;; Database handling
+
+(defvar *connect-if-exists* :error
+  "Default value for the if-exists parameter of connect calls.")
+
+(defvar *connected-databases* nil
+  "List of active database objects.")
+
+(defun connected-databases ()
+  "Return the list of active database objects."
+  *connected-databases*)
+
+(defvar *default-database* nil
+  "Specifies the default database to be used.")
+
+(defun find-database (database &optional (errorp t))
+  (etypecase database
+    (database
+     ;; Return the database object itself
+     database)
+    (string
+     (or (find database (connected-databases)
+	       :key #'database-name
+	       :test #'string=)
+	 (when errorp
+	   (cerror "Return nil."
+		   'clsql-simple-error
+		   :format-control "There exists no database called ~A."
+		   :format-arguments (list database)))))))
+
+(defun connect (connection-spec
+		&key (if-exists *connect-if-exists*)
+		(database-type *default-database-type*)
+		(pool nil))
+  "Connects to a database of the given database-type, using the type-specific
+connection-spec.  if-exists is currently ignored.
+If pool is t the the connection will be taken from the general pool,
+if pool is a conn-pool object the connection will be taken from this pool.
+"
+  (if pool
+    (acquire-from-pool connection-spec database-type pool)
+    (let* ((db-name (database-name-from-spec connection-spec database-type))
+	   (old-db (unless (eq if-exists :new) (find-database db-name nil)))
+	   (result nil))
+      (if old-db
+	(case if-exists
+;	    (:new
+;	     (setq result
+;	       (database-connect connection-spec database-type)))
+	  (:warn-new
+	   (setq result
+		 (database-connect connection-spec database-type))
+	   (warn 'clsql-exists-warning :old-db old-db :new-db result))
+	  (:error
+	   (restart-case
+		 (error 'clsql-exists-error :old-db old-db)
+	       (create-new ()
+		   :report "Create a new connection."
+		 (setq result
+		   (database-connect connection-spec database-type)))
+	       (use-old ()
+		   :report "Use the existing connection."
+		 (setq result old-db))))
+	  (:warn-old
+	   (setq result old-db)
+	   (warn 'clsql-exists-warning :old-db old-db :new-db old-db))
+	  (:old
+	   (setq result old-db)))
+	(setq result
+	      (database-connect connection-spec database-type)))
+      (when result
+	(pushnew result *connected-databases*)
+	(setq *default-database* result)
+	result))))
+
+
+(defun disconnect (&key (database *default-database*))
+  "Closes the connection to database. Resets *default-database* if that
+database was disconnected and only one other connection exists.
+if the database is from a pool it will be released to this pool."
+  (if (conn-pool database)
+      (release-to-pool database)
+    (when (database-disconnect database)
+      (setq *connected-databases* (delete database *connected-databases*))
+      (when (eq database *default-database*)
+	(setq *default-database* (car *connected-databases*)))
+      (change-class database 'closed-database)
+      t)))
+
+;;; Basic operations on databases
+
+(defmethod query (query-expression &key (database *default-database*)  
+		  types)
+  "Execute the SQL query expression query-expression on the given database.
+Returns a list of lists of values of the result of that expression."
+  (database-query query-expression database types))
+
+
+
+(defmethod execute-command (sql-expression &key (database *default-database*))
+  "Execute the SQL command expression sql-expression on the given database.
+Returns true on success or nil on failure."
+  (database-execute-command sql-expression database))
+
+
+
+(defun map-query (output-type-spec function query-expression
+		  &key (database *default-database*)
+		  (types nil))
+  "Map the function over all tuples that are returned by the query in
+query-expression.  The results of the function are collected as
+specified in output-type-spec and returned like in MAP."
+  ;; DANGER Will Robinson: Parts of the code for implementing
+  ;; map-query (including the code below and the helper functions
+  ;; called) are highly CMU CL specific.
+  ;; KMR -- these have been replaced with cross-platform instructions above
+  (macrolet ((type-specifier-atom (type)
+	       `(if (atom ,type) ,type (car ,type))))
+    (case (type-specifier-atom output-type-spec)
+      ((nil) 
+       (map-query-for-effect function query-expression database types))
+      (list 
+       (map-query-to-list function query-expression database types))
+      ((simple-vector simple-string vector string array simple-array
+	bit-vector simple-bit-vector base-string
+	simple-base-string)
+       (map-query-to-simple output-type-spec function query-expression database types))
+      (t
+       (funcall #'map-query (cmucl-compat:result-type-or-lose output-type-spec t)
+              function query-expression :database database :types types)))))
+
+(defun map-query-for-effect (function query-expression database types)
+  (multiple-value-bind (result-set columns)
+      (database-query-result-set query-expression database :full-set nil
+				 :types types)
+    (when result-set
+      (unwind-protect
+	   (do ((row (make-list columns)))
+	       ((not (database-store-next-row result-set database row))
+		nil)
+	     (apply function row))
+	(database-dump-result-set result-set database)))))
+		     
+(defun map-query-to-list (function query-expression database types)
+  (multiple-value-bind (result-set columns)
+      (database-query-result-set query-expression database :full-set nil
+				 :types types)
+    (when result-set
+      (unwind-protect
+	   (let ((result (list nil)))
+	     (do ((row (make-list columns))
+		  (current-cons result (cdr current-cons)))
+		 ((not (database-store-next-row result-set database row))
+		  (cdr result))
+	       (rplacd current-cons (list (apply function row)))))
+	(database-dump-result-set result-set database)))))
+
+
+(defun map-query-to-simple (output-type-spec function query-expression database types)
+  (multiple-value-bind (result-set columns rows)
+      (database-query-result-set query-expression database :full-set t
+				 :types types)
+    (when result-set
+      (unwind-protect
+	   (if rows
+	       ;; We know the row count in advance, so we allocate once
+	       (do ((result
+		     (cmucl-compat:make-sequence-of-type output-type-spec rows))
+		    (row (make-list columns))
+		    (index 0 (1+ index)))
+		   ((not (database-store-next-row result-set database row))
+		    result)
+		 (declare (fixnum index))
+		 (setf (aref result index)
+		       (apply function row)))
+	       ;; Database can't report row count in advance, so we have
+	       ;; to grow and shrink our vector dynamically
+	       (do ((result
+		     (cmucl-compat:make-sequence-of-type output-type-spec 100))
+		    (allocated-length 100)
+		    (row (make-list columns))
+		    (index 0 (1+ index)))
+		   ((not (database-store-next-row result-set database row))
+		    (cmucl-compat:shrink-vector result index))
+		 (declare (fixnum allocated-length index))
+		 (when (>= index allocated-length)
+		   (setq allocated-length (* allocated-length 2)
+			 result (adjust-array result allocated-length)))
+		 (setf (aref result index)
+		       (apply function row))))
+	(database-dump-result-set result-set database)))))
+
+(defmacro do-query (((&rest args) query-expression
+		     &key (database '*default-database*)
+		     (types nil))
+		    &body body)
+  (let ((result-set (gensym))
+	(columns (gensym))
+	(row (gensym))
+	(db (gensym)))
+    `(let ((,db ,database))
+       (multiple-value-bind (,result-set ,columns)
+	   (database-query-result-set ,query-expression ,db
+				      :full-set nil :types ,types)
+	 (when ,result-set
+	   (unwind-protect
+		(do ((,row (make-list ,columns)))
+		    ((not (database-store-next-row ,result-set ,db ,row))
+		     nil)
+		  (destructuring-bind ,args ,row
+		    ,@body))
+	     (database-dump-result-set ,result-set ,db)))))))
+
+;;; Marc Battyani : Large objects support
+
+(defun create-large-object (&key (database *default-database*))
+  "Creates a new large object in the database and returns the object identifier"
+  (database-create-large-object database))
+
+(defun write-large-object (object-id data &key (database *default-database*))
+  "Writes data to the large object"
+  (database-write-large-object object-id data database))
+
+(defun read-large-object (object-id &key (database *default-database*))
+  "Reads the large object content"
+  (database-read-large-object object-id database))
+
+(defun delete-large-object (object-id &key (database *default-database*))
+  "Deletes the large object in the database"
+  (database-delete-large-object object-id database))