From: Kevin M. Rosenberg Date: Sun, 8 Jun 2003 12:48:55 +0000 (+0000) Subject: r5073: *** empty log message *** X-Git-Tag: v3.8.6~825 X-Git-Url: http://git.kpe.io/?p=clsql.git;a=commitdiff_plain;h=20e845656e846b8f48c6243c9ef7211a434a034f r5073: *** empty log message *** --- diff --git a/db-mysql/mysql-api.lisp b/db-mysql/mysql-api.lisp index 85631ea..c14cb7d 100644 --- a/db-mysql/mysql-api.lisp +++ b/db-mysql/mysql-api.lisp @@ -8,7 +8,7 @@ ;;;; Original code by Pierre R. Mai ;;;; Date Started: Feb 2002 ;;;; -;;;; $Id: mysql-api.lisp,v 1.2 2003/05/17 07:27:15 kevin Exp $ +;;;; $Id: mysql-api.lisp,v 1.3 2003/06/08 12:48:55 kevin Exp $ ;;;; ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; and Copyright (c) 1999-2001 by Pierre R. Mai @@ -18,9 +18,10 @@ ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;;;; ************************************************************************* -(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) +(eval-when (:compile-toplevel) + (declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))) -(in-package :mysql) +(in-package #:mysql) ;;;; Modifications from original code ;;;; - Updated C-structures to conform to structures in MySQL 3.23.46 diff --git a/db-mysql/mysql-sql.lisp b/db-mysql/mysql-sql.lisp index 5f834ea..fee81b5 100644 --- a/db-mysql/mysql-sql.lisp +++ b/db-mysql/mysql-sql.lisp @@ -8,7 +8,7 @@ ;;;; Original code by Pierre R. Mai ;;;; Date Started: Feb 2002 ;;;; -;;;; $Id: mysql-sql.lisp,v 1.4 2003/04/16 21:50:01 kevin Exp $ +;;;; $Id: mysql-sql.lisp,v 1.5 2003/06/08 12:48:55 kevin Exp $ ;;;; ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; and Copyright (c) 1999-2001 by Pierre R. Mai @@ -18,7 +18,8 @@ ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;;;; ************************************************************************* -(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) +(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 @@ -32,12 +33,12 @@ ;;;; Mar 2002 ;;;; Added field types -(defpackage :clsql-mysql +(defpackage #:clsql-mysql (:use #:common-lisp #:clsql-base-sys #:mysql #:clsql-uffi) (:export #:mysql-database) (:documentation "This is the CLSQL interface to MySQL.")) -(in-package :clsql-mysql) +(in-package #:clsql-mysql) ;;; Field conversion functions @@ -144,35 +145,39 @@ (defmethod database-query (query-expression (database mysql-database) types) - (with-slots (mysql-ptr) database + (declare (optimize (speed 3) (safety 0) (debug 0) (space 0))) + (let ((mysql-ptr (database-mysql-ptr database))) (uffi:with-cstring (query-native query-expression) - (if (zerop (mysql-query mysql-ptr query-native)) - (let ((res-ptr (mysql-use-result mysql-ptr))) - (if res-ptr - (unwind-protect - (let ((num-fields (mysql-num-fields res-ptr))) - (setq types (canonicalize-types - types num-fields - res-ptr)) - (loop for row = (mysql-fetch-row res-ptr) - until (uffi:null-pointer-p row) - collect - (loop for i from 0 below num-fields - collect - (convert-raw-field - (uffi:deref-array row '(:array (* :unsigned-char)) i) - types i)))) - (mysql-free-result res-ptr)) - (error 'clsql-sql-error - :database database - :expression query-expression - :errno (mysql-errno mysql-ptr) - :error (mysql-error-string mysql-ptr)))) - (error 'clsql-sql-error - :database database - :expression query-expression - :errno (mysql-errno mysql-ptr) - :error (mysql-error-string mysql-ptr)))))) + (if (zerop (mysql-query mysql-ptr query-native)) + (let ((res-ptr (mysql-use-result mysql-ptr))) + (if res-ptr + (unwind-protect + (let ((num-fields (mysql-num-fields res-ptr))) + (declare (fixnum num-fields)) + (setq types (canonicalize-types + types num-fields + res-ptr)) + (loop for row = (mysql-fetch-row res-ptr) + until (uffi:null-pointer-p row) + collect + (loop for i fixnum from 0 below num-fields + collect + (convert-raw-field + (uffi:deref-array row '(:array + (* :unsigned-char)) + i) + types i)))) + (mysql-free-result res-ptr)) + (error 'clsql-sql-error + :database database + :expression query-expression + :errno (mysql-errno mysql-ptr) + :error (mysql-error-string mysql-ptr)))) + (error 'clsql-sql-error + :database database + :expression query-expression + :errno (mysql-errno mysql-ptr) + :error (mysql-error-string mysql-ptr)))))) (defmethod database-execute-command (sql-expression (database mysql-database)) (uffi:with-cstring (sql-native sql-expression) diff --git a/uffi/clsql-uffi.lisp b/uffi/clsql-uffi.lisp index 41d38b0..aa62e6c 100644 --- a/uffi/clsql-uffi.lisp +++ b/uffi/clsql-uffi.lisp @@ -7,7 +7,7 @@ ;;;; Programmers: Kevin M. Rosenberg ;;;; Date Started: Mar 2002 ;;;; -;;;; $Id: clsql-uffi.lisp,v 1.29 2003/06/06 21:59:09 kevin Exp $ +;;;; $Id: clsql-uffi.lisp,v 1.30 2003/06/08 12:48:55 kevin Exp $ ;;;; ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -21,40 +21,43 @@ (defun canonicalize-type-list (types auto-list) "Ensure a field type list meets expectations" - (let ((length-types (length types)) - (new-types '())) - (loop for i from 0 below (length auto-list) - do - (if (>= i length-types) - (push t new-types) ;; types is shorted than num-fields - (push - (case (nth i types) - (:int - (case (nth i auto-list) - (:int32 - :int32) - (:int64 - :int64) - (t - t))) - (:double - (case (nth i auto-list) - (:double - :double) - (t - t))) - (:int32 - (if (eq :int32 (nth i auto-list)) - :int32 - t)) - (:int64 - (if (eq :int64 (nth i auto-list)) - :int64 - t)) - (t - t)) - new-types))) - (nreverse new-types))) + (declaim (optimize (speed 3) (safety 0))) + (do ((i 0 (1+ i)) + (new-types '()) + (length-types (length types)) + (length-auto-list (length auto-list))) + ((= i length-auto-list) + (nreverse new-types)) + (declaim (fixnum length-types length-auto-list i)) + (if (>= i length-types) + (push t new-types) ;; types is shorted than num-fields + (push + (case (nth i types) + (:int + (case (nth i auto-list) + (:int32 + :int32) + (:int64 + :int64) + (t + t))) + (:double + (case (nth i auto-list) + (:double + :double) + (t + t))) + (:int32 + (if (eq :int32 (nth i auto-list)) + :int32 + t)) + (:int64 + (if (eq :int64 (nth i auto-list)) + :int64 + t)) + (t + t)) + new-types)))) (uffi:def-function "atoi" ((str (* :unsigned-char))) @@ -77,7 +80,7 @@ (uffi:def-constant +2^32-1+ (1- +2^32+)) (defmacro make-64-bit-integer (high32 low32) - `(+ ,low32 (* ,high32 +2^32+))) + `(+ ,low32 (ash ,high32 32))) (defmacro split-64-bit-integer (int64) `(values (ash ,int64 -32) (logand ,int64 +2^32-1+))) @@ -93,6 +96,7 @@ (uffi:deref-pointer char-ptr :char)))) (defun convert-raw-field (char-ptr types index) + (declare (optimize (speed 3) (safety 0) (space 0))) (let ((type (if (listp types) (nth index types) types)))