1;;; 2;;; Monkey patch mssql to add missing bits, will cook a patch later. 3;;; 4 5(in-package :mssql) 6 7;; 8;; See freetds/include/freetds/proto.h for reference 9;; 10(defcenum %syb-value-type 11 (:syb-char 47) 12 (:syb-varchar 39) 13 (:syb-intn 38) 14 (:syb-int1 48) 15 (:syb-int2 52) 16 (:syb-int4 56) 17 (:syb-int8 127) 18 (:syb-flt8 62) 19 (:syb-datetime 61) 20 (:syb-bit 50) 21 (:syb-text 35) 22 (:syb-image 34) 23 (:syb-money4 122) 24 (:syb-money 60) 25 (:syb-datetime4 58) 26 (:syb-real 59) 27 (:syb-binary 45) 28 (:syb-varbinary 37) 29 (:syb-bitn 104) 30 (:syb-numeric 108) 31 (:syb-decimal 106) 32 (:syb-fltn 109) 33 (:syb-moneyn 110) 34 (:syb-datetimn 111) 35 36 ;; MS only types 37 (:syb-nvarchar 103) 38 ;(:syb-int8 127) 39 (:xsy-bchar 175) 40 (:xsy-bvarchar 167) 41 (:xsy-bnvarchar 231) 42 (:xsy-bnchar 239) 43 (:xsy-bvarbinary 165) 44 (:xsy-bbinary 173) 45 (:syb-unique 36) 46 (:syb-variant 98) 47 (:syb-msudt 240) 48 (:syb-msxml 241) 49 (:syb-msdate 40) 50 (:syb-mstime 41) 51 (:syb-msdatetime2 42) 52 (:syb-msdatetimeoffset 43) 53 54 ;; Sybase only types 55 (:syb-longbinary 225) 56 (:syb-uint1 64) 57 (:syb-uint2 65) 58 (:syb-uint4 66) 59 (:syb-uint8 67) 60 (:syb-blob 36) 61 (:syb-boundary 104) 62 (:syb-date 49) 63 (:syb-daten 123) 64 (:syb-5int8 191) 65 (:syb-interval 46) 66 (:syb-longchar 175) 67 (:syb-sensitivity 103) 68 (:syb-sint1 176) 69 (:syb-time 51) 70 (:syb-timen 147) 71 (:syb-uintn 68) 72 (:syb-unitext 174) 73 (:syb-xml 163) 74 ) 75 76(defun unsigned-to-signed (byte n) 77 (declare (type fixnum n) (type unsigned-byte byte)) 78 (logior byte (- (mask-field (byte 1 (1- (* n 8))) byte)))) 79 80(defun sysdb-data-to-lisp (%dbproc data type len) 81 (let ((syb-type (foreign-enum-keyword '%syb-value-type type))) 82 (case syb-type 83 ;; we accept emtpy string (len is 0) 84 ((:syb-char :syb-varchar :syb-text :syb-msxml) 85 (foreign-string-to-lisp data :count len)) 86 87 (otherwise 88 ;; other types must have a non-zero len now, or we just return nil. 89 (if (> len 0) 90 (case syb-type 91 ((:syb-bit :syb-bitn) (mem-ref data :int)) 92 (:syb-int1 (unsigned-to-signed (mem-ref data :unsigned-int) 1)) 93 (:syb-int2 (unsigned-to-signed (mem-ref data :unsigned-int) 2)) 94 (:syb-int4 (unsigned-to-signed (mem-ref data :unsigned-int) 4)) 95 (:syb-int8 (mem-ref data :int8)) 96 (:syb-real (mem-ref data :float)) 97 (:syb-flt8 (mem-ref data :double)) 98 ((:syb-datetime 99 :syb-datetime4 100 :syb-msdate 101 :syb-mstime 102 :syb-msdatetime2) 103 (with-foreign-pointer (%buf +numeric-buf-sz+) 104 (let ((count 105 (%dbconvert %dbproc 106 type 107 data 108 -1 109 :syb-char 110 %buf 111 +numeric-buf-sz+))) 112 (foreign-string-to-lisp %buf :count count)))) 113 ((:syb-money :syb-money4 :syb-decimal :syb-numeric) 114 (with-foreign-pointer (%buf +numeric-buf-sz+) 115 (let ((count 116 (%dbconvert %dbproc 117 type 118 data 119 -1 120 :syb-char 121 %buf 122 +numeric-buf-sz+))) 123 (parse-number:parse-number 124 (foreign-string-to-lisp %buf :count count ))))) 125 ((:syb-image :syb-binary :syb-varbinary :syb-blob) 126 (let ((vector (make-array len :element-type '(unsigned-byte 8)))) 127 (dotimes (i len) 128 (setf (aref vector i) (mem-ref data :uchar i))) 129 vector)) 130 (otherwise (error "not supported type ~A" 131 (foreign-enum-keyword '%syb-value-type type))))))))) 132 133;; (defconstant +dbbuffer+ 14) 134 135;; (define-sybdb-function ("dbsetopt" %dbsetopt) %RETCODE 136;; (dbproc %DBPROCESS) 137;; (option :int) 138;; (char-param :pointer) 139;; (int-param :int)) 140 141(defun map-query-results (query &key row-fn (connection *database*)) 142 "Map the query results through the map-fn function." 143 (let ((%dbproc (slot-value connection 'dbproc)) 144 (cffi:*default-foreign-encoding* (slot-value connection 'external-format))) 145 (with-foreign-string (%query query) 146 (%dbcmd %dbproc %query)) 147 (%dbsqlexec %dbproc) 148 (unwind-protect 149 (unless (= +no-more-results+ (%dbresults %dbproc)) 150 (loop :for rtc := (%dbnextrow %dbproc) 151 :until (= rtc +no-more-rows+) 152 :do (let ((row (make-array (%dbnumcols %dbproc)))) 153 (loop :for i :from 1 :to (%dbnumcols %dbproc) 154 :for value 155 := (restart-case 156 (sysdb-data-to-lisp %dbproc 157 (%dbdata %dbproc i) 158 (%dbcoltype %dbproc i) 159 (%dbdatlen %dbproc i)) 160 (use-nil () 161 :report "skip this column's value and use nil instead." 162 nil) 163 (use-empty-string () 164 :report "skip this column's value and use empty-string instead." 165 "") 166 (use-value (value) value)) 167 :do (setf (aref row (- i 1)) value)) 168 169 (funcall row-fn row)))) 170 (%dbcancel %dbproc)))) 171