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