Changeset vendor,3 for vendor/src/odbc/column.lisp
- Timestamp:
- 12/07/2007 02:13:22 PM (19 years ago)
- revision id:
- svn-v3-trunk1:1c22b0a8-4d0b-0410-a296-af6a2e6f35e3:plain-odbc%2Ftrunk:8
- File:
-
- 1 edited
-
vendor/src/odbc/column.lisp (modified) (16 diffs)
Legend:
- Unmodified
- Added
- Removed
-
vendor/src/odbc/column.lisp
r1 r3 77 77 column 78 78 ;(setf value-ptr (cffi:foreign-alloc :long buffer-length)) 79 (setf ind-ptr (cffi:foreign-alloc :long))79 (setf ind-ptr (cffi:foreign-alloc 'sql-len)) 80 80 (%bind-column hstmt 81 81 pos … … 113 113 114 114 (defmethod get-column-value ((column string-column)) 115 (let ((len (cffi:mem-ref (slot-value column 'ind-ptr) :long)))115 (let ((len (cffi:mem-ref (slot-value column 'ind-ptr) 'sql-len))) 116 116 (if (= len $SQL_NULL_DATA) 117 nil118 (progn119 (get-string (slot-value column 'value-ptr) len)))))117 nil 118 (progn 119 (get-string (slot-value column 'value-ptr) len))))) 120 120 ;;;------------------- 121 121 ;;; unicode-string … … 147 147 148 148 (defmethod get-column-value ((column unicode-string-column)) 149 (let ((len (cffi:mem-ref (slot-value column 'ind-ptr) :long)))149 (let ((len (cffi:mem-ref (slot-value column 'ind-ptr) 'sql-len))) 150 150 ;; len is size in bytes, not characters! 151 151 (if (= len $SQL_NULL_DATA) 152 nil153 (progn154 ;(break)155 (wchar-bytes-to-string (get-byte-vector (slot-value column 'value-ptr) len))))))152 nil 153 (progn 154 ;; (break) 155 (wchar-bytes-to-string (get-byte-vector (slot-value column 'value-ptr) len)))))) 156 156 157 157 … … 166 166 (declare (ignore args)) 167 167 (setf (slot-value column 'c-type) $SQL_C_SLONG) 168 (setf (slot-value column 'buffer-length) 169 (cffi:foreign-type-size :long))170 (setf (slot-value column 'value-ptr) 171 (cffi:foreign-alloc :long)))168 (setf (slot-value column 'buffer-length) 169 (cffi:foreign-type-size 'sql-integer)) 170 (setf (slot-value column 'value-ptr) 171 (cffi:foreign-alloc 'sql-integer))) 172 172 173 173 174 174 (defmethod get-column-value ((column integer-column)) 175 (let ((len (cffi:mem-ref (slot-value column 'ind-ptr) :long)))175 (let ((len (cffi:mem-ref (slot-value column 'ind-ptr) 'sql-len))) 176 176 (if (= len $SQL_NULL_DATA) 177 nil178 (cffi:mem-ref (slot-value column 'value-ptr) :long))))177 nil 178 (cffi:mem-ref (slot-value column 'value-ptr) 'sql-integer)))) 179 179 180 180 … … 193 193 194 194 (defmethod get-column-value ((column double-column)) 195 ; (%get-long (slot-value column 'ind-ptr))196 ; (%get-double-float (slot-value column 'value-ptr))197 (let ((len (cffi:mem-ref (slot-value column 'ind-ptr) :long)))198 199 nil200 (progn201 (cffi:mem-ref (slot-value column 'value-ptr) :double)))))195 ;; (%get-long (slot-value column 'ind-ptr)) 196 ;; (%get-double-float (slot-value column 'value-ptr)) 197 (let ((len (cffi:mem-ref (slot-value column 'ind-ptr) 'sql-len))) 198 (if (= len $SQL_NULL_DATA) 199 nil 200 (progn 201 (cffi:mem-ref (slot-value column 'value-ptr) :double))))) 202 202 203 203 ;;;------------------------ … … 214 214 215 215 (defmethod get-column-value ((column date-column)) 216 (let ((len (cffi:mem-ref (slot-value column 'ind-ptr) :long)))216 (let ((len (cffi:mem-ref (slot-value column 'ind-ptr) 'sql-len))) 217 217 (if (= len $SQL_NULL_DATA) 218 nil219 (funcall *universal-time-to-date-dataype*220 (timestamp-to-universal-time (slot-value column 'value-ptr))))))218 nil 219 (funcall *universal-time-to-date-dataype* 220 (timestamp-to-universal-time (slot-value column 'value-ptr)))))) 221 221 222 222 ;;;-------------------------- … … 241 241 242 242 (defmethod get-column-value ((column binary-column)) 243 (let ((len (cffi:mem-ref (slot-value column 'ind-ptr) :long)))243 (let ((len (cffi:mem-ref (slot-value column 'ind-ptr) 'sql-len))) 244 244 (if (= len $SQL_NULL_DATA) 245 245 nil … … 260 260 261 261 (defmethod get-column-value ((column bigint-column)) 262 (let ((len (cffi:mem-ref (slot-value column 'ind-ptr) :long)))263 (if (= len $SQL_NULL_DATA) 264 nil265 (parse-integer (get-string (slot-value column 'value-ptr) len)))))262 (let ((len (cffi:mem-ref (slot-value column 'ind-ptr) 'sql-len))) 263 (if (= len $SQL_NULL_DATA) 264 nil 265 (parse-integer (get-string (slot-value column 'value-ptr) len))))) 266 266 267 267 ;;;---------------------------- … … 313 313 314 314 (defmethod get-column-value ((column decimal-column)) 315 (let ((len (cffi:mem-ref (slot-value column 'ind-ptr) :long)))315 (let ((len (cffi:mem-ref (slot-value column 'ind-ptr) 'sql-len))) 316 316 (if (= len $SQL_NULL_DATA) 317 nil318 (let ((bytes (get-byte-vector (slot-value column 'value-ptr) len))319 (sum 0))320 (dotimes (i 16)321 (setf sum (+ (* 256 sum) (aref bytes (- (+ 3 16) 1 i)))))322 (*323 sum324 (if (zerop (aref bytes 2)) -1 1) ;sign325 (expt 10 (- (aref bytes 1))))))))317 nil 318 (let ((bytes (get-byte-vector (slot-value column 'value-ptr) len)) 319 (sum 0)) 320 (dotimes (i 16) 321 (setf sum (+ (* 256 sum) (aref bytes (- (+ 3 16) 1 i))))) 322 (* 323 sum 324 (if (zerop (aref bytes 2)) -1 1) ;sign 325 (expt 10 (- (aref bytes 1)))))))) 326 326 327 327 … … 341 341 (let* ((value-ptr (cffi:foreign-alloc :char 342 342 :count (slot-value column 'buffer-length))) 343 (ind-ptr (cffi:foreign-alloc :long)))343 (ind-ptr (cffi:foreign-alloc 'sql-len))) 344 344 (unwind-protect 345 345 (get-character-data … … 365 365 (defmethod get-column-value ((column uclob-column)) 366 366 (let* ((value-ptr (cffi:foreign-alloc :char :count (slot-value column 'buffer-length))) 367 (ind-ptr (cffi:foreign-alloc :long)))367 (ind-ptr (cffi:foreign-alloc 'sql-len))) 368 368 (unwind-protect 369 369 (get-unicode-character-data … … 389 389 (defmethod get-column-value ((column blob-column)) 390 390 (let* ((value-ptr (cffi:foreign-alloc :uchar :count (slot-value column 'buffer-length))) 391 (ind-ptr (cffi:foreign-alloc :long)))391 (ind-ptr (cffi:foreign-alloc 'sql-len))) 392 392 (unwind-protect 393 393 (get-binary-data … … 423 423 ind-ptr))) 424 424 (handle-error sqlret) 425 (let ((len (cffi:mem-ref ind-ptr :long)))426 ; (break)425 (let ((len (cffi:mem-ref ind-ptr 'sql-len))) 426 ;;(break) 427 427 (cond 428 428 ((= len $sql_null_data) nil) 429 ;; character data has a 0 byte appended, the length does not include it 430 ;; but it is taken into account when placing the data into the buffer 429 ;; character data has a 0 byte appended, the length does not 430 ;; include it but it is taken into account when placing the 431 ;; data into the buffer 431 432 ((and (/= len $SQL_NO_TOTAL) 432 433 (<= (+ 1 len) buffer-length)) 433 434 434 ;; the data fits into the buffer, return it 435 (get-string value-ptr len)) 435 436 436 437 ;; we have to fetch the data in several steps 437 438 (t 438 439 440 441 442 439 (let ((sos (make-string-output-stream))) 440 (loop 441 (if (and (= sqlret $SQL_SUCCESS_WITH_INFO) 442 (equal (sql-state nil nil hstmt) 443 "01004")) 443 444 ;; an 0 byte is append to a string, ignore that 444 445 … … 446 447 (write-string str sos) 447 448 (setf sqlret (%sql-get-data-raw hstmt 448 position449 $SQL_C_CHAR450 value-ptr451 buffer-length452 ind-ptr))449 position 450 $SQL_C_CHAR 451 value-ptr 452 buffer-length 453 ind-ptr)) 453 454 (handle-error sqlret)) 454 455 (return))) 455 456 (setf len (cffi:mem-ref ind-ptr :long))457 (let ((str (get-string value-ptr len)))458 (write-string str sos))459 (get-output-stream-string sos))))))))456 ;; fetch the last part of the data 457 (setf len (cffi:mem-ref ind-ptr 'sql-len)) 458 (let ((str (get-string value-ptr len))) 459 (write-string str sos)) 460 (get-output-stream-string sos)))))))) 460 461 461 462 ;;; the version for 16bit unicode 462 463 463 (defun get-unicode-character-data (hstmt position value-ptr buffer-length ind-ptr) 464 (defun get-unicode-character-data (hstmt position value-ptr buffer-length 465 ind-ptr) 464 466 ;; local error handling, we can not use the general error handling 465 467 ;; since this resets the sql-state … … 481 483 ind-ptr))) 482 484 (handle-error sqlret) 483 (let ((len (cffi:mem-ref ind-ptr :long)))485 (let ((len (cffi:mem-ref ind-ptr 'sql-len))) 484 486 (cond 485 487 ((= len $sql_null_data) nil) 486 ;; character data has a 0 byte appended, the length does not include it 487 ;; but it is taken into account when placing the data into the buffer 488 ;; character data has a 0 byte appended, the length does not 489 ;; include it but it is taken into account when placing the 490 ;; data into the buffer 488 491 ((and (/= len $SQL_NO_TOTAL) 489 492 (<= (+ 2 len) buffer-length)) 490 491 493 ;; the data fits into the buffer, return it 494 (%get-unicode-string value-ptr len)) 492 495 493 496 ;; we have to fetch the data in several steps 494 497 (t 495 496 497 498 499 498 (let ((sos (make-string-output-stream :element-type 'character))) 499 (loop 500 (if (and (= sqlret $SQL_SUCCESS_WITH_INFO) 501 (equal (sql-state nil nil hstmt) 502 "01004")) 500 503 ;; an 0 byte is append to a string, ignore that 501 504 502 (let ((str (%get-unicode-string value-ptr (- buffer-length 2)))) 505 (let ((str 506 (%get-unicode-string value-ptr (- buffer-length 2)))) 503 507 (write-string str sos) 504 508 (setf sqlret (%sql-get-data-raw hstmt 505 position506 $SQL_C_WCHAR507 value-ptr508 buffer-length509 ind-ptr))509 position 510 $SQL_C_WCHAR 511 value-ptr 512 buffer-length 513 ind-ptr)) 510 514 (handle-error sqlret)) 511 515 (return))) 512 513 (setf len (cffi:mem-ref ind-ptr :long))514 (let ((str (%get-unicode-string value-ptr len)))515 (write-string str sos))516 (get-output-stream-string sos))))))))516 ;; fetch the last part of the data 517 (setf len (cffi:mem-ref ind-ptr 'sql-len)) 518 (let ((str (%get-unicode-string value-ptr len))) 519 (write-string str sos)) 520 (get-output-stream-string sos)))))))) 517 521 518 522 (defun get-binary-data (hstmt position value-ptr buffer-length ind-ptr) … … 530 534 (error condition))))) 531 535 532 (let* ((sqlret (%sql-get-data-raw hstmt 533 position 534 $SQL_C_BINARY 535 value-ptr 536 buffer-length 537 ind-ptr))) 538 (handle-error sqlret) 539 (let ((len (cffi:mem-ref ind-ptr :long))) 540 (if (= len $sql_null_data) 541 nil 542 (let ((res (make-array 0 :element-type '(unsigned-byte 8) :adjustable t)) 543 (res-len 0)) 544 (loop 545 (if (and (= sqlret $SQL_SUCCESS_WITH_INFO) 546 (equal (sql-state nil nil hstmt) 547 "01004")) 536 (let* ((sqlret (%sql-get-data-raw hstmt 537 position 538 $SQL_C_BINARY 539 value-ptr 540 buffer-length 541 ind-ptr))) 542 (handle-error sqlret) 543 (let ((len (cffi:mem-ref ind-ptr 'sql-len))) 544 (if (= len $sql_null_data) 545 nil 546 (let ((res (make-array 0 547 :element-type '(unsigned-byte 8) 548 :adjustable t)) 549 (res-len 0)) 550 (loop 551 (if (and (= sqlret $SQL_SUCCESS_WITH_INFO) 552 (equal (sql-state nil nil hstmt) 553 "01004")) 548 554 549 (let ((vec (get-byte-vector value-ptr buffer-length)))550 (setf res (adjust-array res (+ res-len buffer-length)))551 (setf (subseq res res-len (+ res-len buffer-length)) vec)552 (setf res-len (length res))553 (setf sqlret (%sql-get-data-raw hstmt554 position555 $SQL_C_BINARY556 value-ptr557 buffer-length558 ind-ptr))559 (handle-error sqlret))560 (return)))555 (let ((vec (get-byte-vector value-ptr buffer-length))) 556 (setf res (adjust-array res (+ res-len buffer-length))) 557 (setf (subseq res res-len (+ res-len buffer-length)) vec) 558 (setf res-len (length res)) 559 (setf sqlret (%sql-get-data-raw hstmt 560 position 561 $SQL_C_BINARY 562 value-ptr 563 buffer-length 564 ind-ptr)) 565 (handle-error sqlret)) 566 (return))) 561 567 562 (setf len (cffi:mem-ref ind-ptr :long)) 563 (let ((vec (get-byte-vector value-ptr len))) 564 (setf res (adjust-array res (+ res-len len))) 565 (setf (subseq res res-len (+ res-len len)) vec)) 566 res)))))) 567 568 (setf len (cffi:mem-ref ind-ptr 'sql-len)) 569 (let ((vec (get-byte-vector value-ptr len))) 570 (setf res (adjust-array res (+ res-len len))) 571 (setf (subseq res res-len (+ res-len len)) vec)) 572 res))))))
Note: See TracChangeset
for help on using the changeset viewer.
