source: project/release/3/mysql/trunk/mysql.scm @ 15015

Last change on this file since 15015 was 15015, checked in by daishi, 12 years ago

mysql: added new procedure mysql-is-closed? and check the connection in most mysql procedures

File size: 103.5 KB
Line 
1; vim:ts=2:sw=2:et:
2
3;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4;; MySQL Egg for the Chicken Scheme system.
5;;
6;; mysql.scm,v 1.4 2005/08/04 10:09:26 tbutzon Exp
7;;
8;; Author: Toby Butzon (toby@butzon.com)
9;; Revisions:
10;;       2005.08.04 Initial release.
11;;       2007.01.20 Added -lz for Mac OS X compilation.
12;;                                                              (Thanks to Daniel Sadilek.)
13;;                                                      Changed #include <mysql/mysql.h> to #include <mysql.h>
14;;                                                              (Thanks to Kon Lovett and Daniel Sadilek.)
15;;                                                      Removed some misc. compilation warnings.
16;;                                                              (Thanks to Kon Lovett.)
17;;                                                      Added (error ...) calls instead of silently failing in
18;;                                                              mysql-connect.
19;;                                                              (Thanks to Daniel Sadilek.)
20;;       2008.01.24 Use of SRFI-12 conditions instead of 'error'.
21;;                                                      MYSQL_FIELD support.
22;;                                                      MY_CHARSET_INFO support.
23;;                                                      More row mapping functions.
24;;                                                      Options support
25;;                                                      SSL support
26;;                                                      Removed deprecated procedures:
27;;                                                              mysql-create-db
28;;                                                              mysql-drop-db
29;;                                                              mysql-eof
30;;                                                              mysql-reload
31;;                                                      (Kon Lovett)
32;;
33;; This egg provides the MySQL C API via Chicken's foreign function
34;; interface. The function names in the MySQL C API are uniformly
35;; exported with "foreign-" prefixed to the name, and underscores are
36;; mapped to the more Scheme-ish dash; e.g., the MySQL C API's
37;; mysql_query is provided by this egg as foreign-mysql-query. Although
38;; these functions are exported, they are not verbosely documented in
39;; the egg documentation simply because the MySQL C API is already
40;; documented in full on MySQL's website:
41;;
42;;              http://dev.mysql.com/doc/mysql/en/c.html
43;;
44;; Further, this egg provides a layer on top of the foreign API to
45;; provide a simpler API that is appropriate to Scheme. These functions
46;; are _not_ prefixed with "foreign-" -- instead they are named according
47;; to the closest MySQL C API analog, if one exists. For example, the
48;; provided mysql-connect is briefer, yet provides the same functionality
49;; as, the C API sequence mysql_init, mysql_real_connect, and returns a
50;; Scheme-friendly record instead of a FFI C pointer.
51;;
52;; Please report bugs to <toby@butzon.com>.
53;;
54;; Copyright (c) 2005 Toby Butzon.
55;;
56;; Permission is hereby granted, free of charge, to any person obtaining a
57;; copy of this software and associated documentation files (the "Software"),
58;; to deal in the Software without restriction, including without limitation
59;; the rights to use, copy, modify, merge, publish, distribute, sublicense,
60;; and/or sell copies of the Software, and to permit persons to whom the
61;; Software is furnished to do so, subject to the following conditions:
62;;
63;; The above copyright notice and this permission notice shall be included
64;; in all copies or substantial portions of the Software.
65;;
66;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
67;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
68;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
69;; THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR
70;; OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE,
71;; ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
72;; OTHER DEALINGS IN THE SOFTWARE.
73;;
74;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
75
76#>#include <mysql.h><#
77
78(require-extension srfi-1 srfi-4 srfi-12)
79(require-extension lolevel)
80
81(require-for-syntax 'srfi-13)
82
83(declare
84        (usual-integrations)
85        (generic)
86        (no-procedure-checks-for-usual-bindings)
87        (no-bound-checks)
88        (inline)
89        (unused
90                my-charset-info-name-set!
91                my-charset-info-csname-set!
92                my-charset-info-comment-set!
93                my-charset-info-dir-set!
94                my-charset-info-mbminlen-set!
95                my-charset-info-mbmaxlen-set!
96                mysql-field-db-set!
97                mysql-field-type-set!
98                mysql-field-charsetnr-set!
99                mysql-field-catalog-set!
100                mysql-field-org-name-set!
101                mysql-field-name-set!
102                mysql-field-def-set!
103                mysql-field-org-table-set!
104                mysql-field-table-set!
105                mysql-field-flags-set!
106                mysql-field-org-table
107                mysql-field-decimals-set!
108                mysql-field-def-length-set!
109                mysql-field-catalog-length-set!
110                mysql-field-db-length-set!
111                mysql-field-org-table-length-set!
112                mysql-field-table-length-set!
113                mysql-field-org-name-length-set!
114                mysql-field-name-length-set!
115                mysql-field-max-length-set!
116                mysql-field-length-set! )
117        (bound-to-procedure
118                mysql-error
119                mysql-errno
120                #;
121                mysql-stmt-close )
122        (export
123                ;; direct api
124                foreign-mysql-affected-rows
125                foreign-mysql-change-user
126                foreign-mysql-character-set-name
127                foreign-mysql-close
128                foreign-mysql-data-seek
129                foreign-mysql-debug
130                foreign-mysql-dump-debug-info
131                foreign-mysql-errno
132                foreign-mysql-error
133                foreign-mysql-escape-string
134                foreign-mysql-fetch-field
135                foreign-mysql-fetch-fields
136                foreign-mysql-fetch-field-direct
137                foreign-mysql-fetch-lengths
138                foreign-mysql-fetch-row
139                foreign-mysql-field-count
140                foreign-mysql-field-seek
141                foreign-mysql-field-tell
142                foreign-mysql-free-result
143                foreign-mysql-get-character-set-info
144                foreign-mysql-get-client-info
145                foreign-mysql-get-client-version
146                foreign-mysql-get-host-info
147                foreign-mysql-get-proto-info
148                foreign-mysql-get-server-info
149                foreign-mysql-get-server-version
150                foreign-mysql-hex-string
151                foreign-mysql-info
152                foreign-mysql-init
153                foreign-mysql-insert-id
154                foreign-mysql-kill
155                foreign-mysql-library-init
156                foreign-mysql-library-end
157                foreign-mysql-list-dbs
158                foreign-mysql-list-fields
159                foreign-mysql-list-processes
160                foreign-mysql-list-tables
161                foreign-mysql-num-fields
162                foreign-mysql-num-rows
163                foreign-mysql-options
164                foreign-mysql-ping
165                foreign-mysql-query
166                foreign-mysql-real-connect
167                foreign-mysql-real-escape-string
168                foreign-mysql-real-query
169                foreign-mysql-row-seek
170                foreign-mysql-row-tell
171                foreign-mysql-select-db
172                foreign-mysql-set-character-set
173                foreign-mysql-set-server-option
174                foreign-mysql-shutdown
175                foreign-mysql-sqlstate
176                foreign-mysql-ssl-set
177                foreign-mysql-stat
178                foreign-mysql-store-result
179                foreign-mysql-thread-id
180                foreign-mysql-use-result
181                foreign-mysql-warning-count
182                foreign-mysql-commit
183                foreign-mysql-rollback
184                foreign-mysql-autocommit
185                foreign-mysql-more-results
186                foreign-mysql-next-result
187
188                ;; scheme api
189                mysql-connection?
190                mysql-affected-rows
191                mysql-change-user
192                mysql-character-set-name
193                mysql-close ; customized
194                mysql-connect ; customized
195                #;mysql-data-seek ; omitted (low level)
196                mysql-debug
197                mysql-dump-debug-info
198                mysql-errno
199                mysql-error ; customized
200                mysql-escape-string ; customized
201                mysql-fetch-field
202                mysql-fetch-fields
203                mysql-fetch-field-direct
204                mysql-fetch-lengths ; customized
205                mysql-fetch-row ; customized
206                mysql-field-count
207                #;mysql-field-seek ; omitted (low level)
208                #;mysql-field-tell ; omitted (low level)
209                mysql-free-result
210                mysql-get-character-set-info
211                mysql-get-client-info
212                mysql-get-client-version
213                mysql-get-host-info
214                mysql-get-proto-info
215                mysql-get-server-info
216                mysql-get-server-version
217                #;mysql-hex-string ; omitted (too new)
218                mysql-info
219                #;mysql-init ; omitted (low level)
220                mysql-insert-id
221                mysql-kill
222                #;mysql-library-init ; omitted (too new)
223                #;mysql-library-end ; omitted (too new)
224                mysql-list-dbs
225                mysql-list-fields ; (nearly deprecated)
226                mysql-list-processes
227                mysql-list-tables
228                mysql-num-fields
229                mysql-num-rows
230                mysql-ping
231                mysql-query
232                #;mysql-real-connect ; omitted (use mysql-connect)
233                #;mysql-real-escape-string ; omitted (use mysql-escape-string)
234                #;mysql-real-query ; omitted (use mysql-query)
235                #;mysql-row-seek ; omitted (low level)
236                #;mysql-row-tell ; omitted (low level)
237                mysql-select-db
238                mysql-set-character-set
239                #;mysql-set-server-option ; omitted (too new)
240                #;mysql-shutdown ; omitted (too new)
241                #;mysql-sqlstate ; omitted (too new)
242                mysql-stat
243                mysql-store-result
244                mysql-thread-id
245                #;mysql-use-result ; omitted (doesn't fit with Scheme layer; see mysql-query)
246                #;mysql-warning-count ; omitted (too new)
247                #;mysql-commit ; omitted (too new)
248                #;mysql-rollback ; omitted (too new)
249                #;mysql-autocommit ; omitted (too new)
250                #;mysql-more-results ; omitted (too new)
251                #;mysql-next-result ; omitted (too new)
252
253                ;;
254                make-mysql-options
255
256                ;; ssl parameters api
257                make-mysql-ssl
258                mysql-ssl?
259                mysql-ssl-key-pathname
260                mysql-ssl-certificate-pathname
261                mysql-ssl-certificate-authority-pathname
262                mysql-ssl-trusted-certificates-pathname
263                mysql-ssl-ciphers
264
265                ;; "extended" api
266                mysql-rewind
267
268                ;; "map" api
269                mysql-row-fold
270                mysql-row-for-each
271                mysql-row-map
272                mysql-query-fold
273                mysql-query-for-each
274                mysql-query-map
275                ; synonyms
276                mysql-foreach-row
277                mysql-query-foreach
278
279                ;; MY_CHARSET_INFO api
280                ; slot getters
281                my-charset-info-name
282                my-charset-info-csname
283                my-charset-info-comment
284                my-charset-info-dir
285                my-charset-info-mbminlen
286                my-charset-info-mbmaxlen
287
288                ;; MYSQL_FIELD api
289                ; predicates
290                mysql-field-flags-on?
291                mysql-field-flags-off?
292                mysql-field-primary-key?
293                mysql-field-not-null?
294                mysql-field-numeric?
295                mysql-field-type-any?
296                mysql-field-type=?
297                mysql-field-type-clock?
298                mysql-field-type-number?
299                mysql-field-type-string?
300                mysql-field-type-blob?
301                mysql-field-type-magnitude?
302                mysql-field-type-binary?
303                mysql-field-type-text?
304                ;
305                mysql-fetch-field-specific
306                ; multi-field getters
307                mysql-field-slots
308                mysql-fetch-field-slots-direct
309                mysql-fetch-field-slots
310                mysql-fetch-field-slot-direct
311                mysql-fetch-field-slot
312                ; slot getters
313                mysql-field-name
314                mysql-field-org-name
315                mysql-field-table
316                mysql-field-org-table
317                mysql-field-db
318                mysql-field-catalog
319                mysql-field-def
320                mysql-field-length
321                mysql-field-max-length
322                mysql-field-name-length
323                mysql-field-org-name-length
324                mysql-field-table-length
325                mysql-field-org-table-length
326                mysql-field-db-length
327                mysql-field-catalog-length
328                mysql-field-def-length
329                mysql-field-flags
330                mysql-field-decimals
331                mysql-field-charsetnr
332                mysql-field-type
333               
334                ; check if connection is closed
335                mysql-is-closed?
336
337                ;; connection client flags
338                ; values
339                client-long-password
340                client-long-flag
341                client-connect-with-db
342                client-protocol-41
343                client-secure-connection
344                client-transactions
345                client-compress
346                client-found-rows
347                client-ignore-sigpipe
348                client-ignore-space
349                client-interactive
350                client-local-files
351                client-multi-results
352                client-multi-statements
353                client-no-schema
354                client-odbc
355                client-ssl
356                ; converters
357                mysql-client-flags-value
358                mysql-client-flags-symbol
359
360                ;; enum enum_mysql_set_option
361                ; values
362                mysql-option-multi-statements-on
363                mysql-option-multi-statements-off
364                ; converters
365                mysql-server-option-value
366                mysql-server-option-symbol
367
368                ;; enum mysql_option
369                ; values
370                mysql-opt-connect-timeout
371                mysql-opt-compress
372                mysql-opt-named-pipe
373                mysql-init-command
374                mysql-read-default-file
375                mysql-read-default-group
376                mysql-set-charset-dir
377                mysql-set-charset-name
378                mysql-opt-local-infile
379                mysql-opt-protocol
380                mysql-shared-memory-base-name
381                mysql-opt-read-timeout
382                mysql-opt-write-timeout
383                mysql-opt-use-result
384                mysql-opt-use-remote-connection
385                mysql-opt-use-embedded-connection
386                mysql-opt-guess-connection
387                mysql-set-client-ip
388                mysql-secure-auth
389                mysql-report-data-truncation
390                ; converters
391                mysql-option-value
392                mysql-option-symbol
393
394                ;; enum enum_field_types
395                ; values
396                mysql-type-decimal
397                mysql-type-tiny
398                mysql-type-short
399                mysql-type-long
400                mysql-type-int24
401                mysql-type-float
402                mysql-type-double
403                mysql-type-null
404                mysql-type-timestamp
405                mysql-type-longlong
406                mysql-type-date
407                mysql-type-time
408                mysql-type-datetime
409                mysql-type-year
410                mysql-type-newdate
411                mysql-type-varchar
412                mysql-type-bit
413                mysql-type-newdecimal
414                mysql-type-enum
415                mysql-type-set
416                mysql-type-tiny-blob
417                mysql-type-medium-blob
418                mysql-type-long-blob
419                mysql-type-blob
420                mysql-type-var-string
421                mysql-type-string
422                mysql-type-geometry
423                ; converters
424                mysql-type-value
425                mysql-type-symbol
426
427                ;; field flags
428                ; values
429                not-null-flag
430                pri-key-flag
431                unique-key-flag
432                multiple-key-flag
433                unsigned-flag
434                zerofill-flag
435                binary-flag
436                auto-increment-flag
437                no-default-value-flag
438                ; deprecated
439                enum-flag
440                set-flag
441                blob-flag
442                timestamp-flag
443                ; converters
444                mysql-field-flags-value
445                mysql-field-flags-symbol ) )
446
447;;;
448
449(define-for-syntax (c-name->scheme-name str)
450        (string-downcase (string-translate str "_" "-")) )
451
452;;;
453
454;=======================================================================
455; Interface to C API
456;
457; The entire C API is mapped using Chicken's foreign function interface.
458;
459
460;-----------------------------------------------------------------------
461; Foreign type definitions.
462;
463
464(define-foreign-type mysql-ptr (c-pointer "MYSQL"))
465(define-foreign-type mysql-res-ptr (c-pointer "MYSQL_RES"))
466(define-foreign-type mysql-rows-ptr (c-pointer "MYSQL_ROWS"))
467(define-foreign-type mysql-field-ptr (c-pointer "MYSQL_FIELD"))
468
469;; MYSQL_ROW (we just pass it around, not def-ref'ed)
470
471(define-foreign-type mysql-row (c-pointer (c-pointer char)))
472
473;; my_ulonglong
474
475(define-foreign-type my-ulonglong number)
476
477;; my_bool
478
479;(define-foreign-type my-bool "my_bool" (lambda (x) (if x 1 0)) (lambda (x) (not (fx= 0 x))))
480;the above raises an error in csc, and the below is a workaround.
481(define-foreign-type my-bool char (lambda (x) (if x 1 0)) (lambda (x) (not (fx= 0 x))))
482
483;; MYSQL_FIELD_OFFSET
484
485(define-foreign-type mysql-field-offset unsigned-int)
486
487;-----------------------------------------------------------------------
488; Enumeration & flag value constants
489;
490
491;;
492
493(define-macro (gen-public-enum ?typ . ?syms)
494        ` ; Begin Result
495        (begin
496                ,@(map (lambda (sym)
497             (if (pair? sym)
498                 `(define ,(car sym) ,(cadr sym))
499                 `(define ,(string->symbol (c-name->scheme-name (symbol->string sym))) ,sym)))
500                             ?syms)
501    (define (,(string->symbol (string-append (symbol->string ?typ) "-value")) . syms)
502      (,(string->symbol (string-append (symbol->string ?typ) "->number")) syms))
503    (define (,(string->symbol (string-append (symbol->string ?typ) "-symbol")) val)
504      (,(string->symbol (string-append "number->" (symbol->string ?typ))) val))) )
505
506(define-macro ($define-foreign-enum ?tspec . ?rest)
507  (let ([1st-item (lambda (x) (if (pair? x) (car x) x))])
508    (let-values ([(?flags ?especs)
509                  (if (null? ?rest)
510                      (syntax-error '$define-foreign-enum "missing enumeration specification")
511                      (if (boolean? (car ?rest))
512                          (values (list (car ?rest)) (cdr ?rest))
513                          (values '() ?rest) ) ) ] )
514      (let ([?typ (1st-item ?tspec)]
515            [?enams (map 1st-item ?especs) ] )
516        ` ; Begin Result
517        (begin
518          (define-foreign-enum ,?tspec ,@?flags ,@?especs)
519          (gen-public-enum ,?typ ,@?enams) ) ) ) ) )
520
521;;
522
523($define-foreign-enum (mysql-server-option (enum "enum_mysql_set_option"))
524        #f      ; No aliases!
525        MYSQL_OPTION_MULTI_STATEMENTS_ON
526        MYSQL_OPTION_MULTI_STATEMENTS_OFF )
527
528($define-foreign-enum (mysql-option (enum "mysql_option"))
529        #f      ; No aliases!
530        MYSQL_OPT_CONNECT_TIMEOUT
531        MYSQL_OPT_COMPRESS
532        MYSQL_OPT_NAMED_PIPE
533        MYSQL_INIT_COMMAND
534        MYSQL_READ_DEFAULT_FILE
535        MYSQL_READ_DEFAULT_GROUP
536        MYSQL_SET_CHARSET_DIR
537        MYSQL_SET_CHARSET_NAME
538        MYSQL_OPT_LOCAL_INFILE
539        MYSQL_OPT_PROTOCOL
540        MYSQL_SHARED_MEMORY_BASE_NAME
541        MYSQL_OPT_READ_TIMEOUT
542        MYSQL_OPT_WRITE_TIMEOUT
543        MYSQL_OPT_USE_RESULT
544        MYSQL_OPT_USE_REMOTE_CONNECTION
545        MYSQL_OPT_USE_EMBEDDED_CONNECTION
546        MYSQL_OPT_GUESS_CONNECTION
547        MYSQL_SET_CLIENT_IP
548        MYSQL_SECURE_AUTH
549        MYSQL_REPORT_DATA_TRUNCATION )
550
551($define-foreign-enum (mysql-type (enum "enum_field_types"))
552        #f      ; No aliases!
553        MYSQL_TYPE_DECIMAL
554        MYSQL_TYPE_TINY
555        MYSQL_TYPE_SHORT
556        MYSQL_TYPE_LONG
557        MYSQL_TYPE_INT24
558        MYSQL_TYPE_FLOAT
559        MYSQL_TYPE_DOUBLE
560        MYSQL_TYPE_NULL
561        MYSQL_TYPE_TIMESTAMP
562        MYSQL_TYPE_LONGLONG
563        MYSQL_TYPE_DATE
564        MYSQL_TYPE_TIME
565        MYSQL_TYPE_DATETIME
566        MYSQL_TYPE_YEAR
567        MYSQL_TYPE_NEWDATE
568        MYSQL_TYPE_VARCHAR
569        MYSQL_TYPE_BIT
570        MYSQL_TYPE_NEWDECIMAL
571        MYSQL_TYPE_ENUM
572        MYSQL_TYPE_SET
573        MYSQL_TYPE_TINY_BLOB
574        MYSQL_TYPE_MEDIUM_BLOB
575        MYSQL_TYPE_LONG_BLOB
576        MYSQL_TYPE_BLOB
577        MYSQL_TYPE_VAR_STRING
578        MYSQL_TYPE_STRING
579        MYSQL_TYPE_GEOMETRY )
580
581($define-foreign-enum (mysql-field-flags unsigned-int)
582        #f      ; No aliases!
583        NOT_NULL_FLAG                                                                   ; field can't be NULL
584        PRI_KEY_FLAG                                                                    ; field is part of a primary key
585        UNIQUE_KEY_FLAG                                                         ; field is part of a unique key
586        MULTIPLE_KEY_FLAG                                                       ; field is part of a key
587        UNSIGNED_FLAG                                                                   ; field is unsigned
588        ZEROFILL_FLAG                                                                   ; field is zerofill
589        BINARY_FLAG                                                                             ; field is binary
590        AUTO_INCREMENT_FLAG                                             ; field is a autoincrement field
591        NO_DEFAULT_VALUE_FLAG                                   ; field doesn't have default value
592        NUM_FLAG                                                                                        ; field is num (for clients)
593        ; deprecated
594        ENUM_FLAG                                                                                       ; field is an enum
595        SET_FLAG                                                                                        ; field is a set
596        BLOB_FLAG                                                                                       ; field is a blob
597        TIMESTAMP_FLAG  )                                                       ; field is a timestamp
598
599($define-foreign-enum (mysql-client-flags unsigned-int)
600        #f      ; No aliases!
601        CLIENT_LONG_PASSWORD                                    ; new more secure passwords
602        CLIENT_LONG_FLAG                                                        ; Get all column flags
603        CLIENT_CONNECT_WITH_DB                          ; One can specify db on connect
604        CLIENT_PROTOCOL_41                                              ; New 4.1 protocol
605        CLIENT_SECURE_CONNECTION                        ; New 4.1 authentication
606        CLIENT_TRANSACTIONS                                             ; Client knows about transactions
607        CLIENT_COMPRESS                                                         ; Can use compression protocol
608        ; Return the number of found (matched) rows, not the number of affected rows.
609        CLIENT_FOUND_ROWS
610        ; Prevents the client library from installing a SIGPIPE signal handler. This
611        ; can be used to avoid conflicts with a handler that the application has
612        ; already installed.
613        CLIENT_IGNORE_SIGPIPE
614        ; Allow spaces after function names. Makes all functions names reserved
615        ; words.
616        CLIENT_IGNORE_SPACE
617        ; Allow interactive_timeout seconds (instead of wait_timeout seconds) of
618        ; inactivity before closing the connection. The client's session wait_timeout
619        ; variable is set to the value of the session interactive_timeout variable.
620        CLIENT_INTERACTIVE
621        ; Enable LOAD DATA LOCAL handling.
622        CLIENT_LOCAL_FILES
623        ; Tell the server that the client can handle multiple result sets from
624        ; multiple-statement executions or stored procedures. This is automatically set
625        ; if CLIENT_MULTI_STATEMENTS is set. See the note following this table for more
626        ; information about this flag.
627        CLIENT_MULTI_RESULTS
628        ; Tell the server that the client may send multiple statements in a single
629        ; string (separated by Ò;Ó). If this flag is not set, multiple-statement
630        ; execution is disabled. See the note following this table for more information
631        ; about this flag.
632        CLIENT_MULTI_STATEMENTS
633        ; Don't allow the db_name.tbl_name.col_name syntax. This is for ODBC. It
634        ; causes the parser to generate an error if you use that syntax, which is
635        ; useful for trapping bugs in some ODBC programs.
636        CLIENT_NO_SCHEMA
637        ; Unused.
638        CLIENT_ODBC
639        ; Use SSL (encrypted protocol). This option should not be set by application
640        ; programs; it is set internally in the client library. Instead, use
641        ; mysql_ssl_set() before calling mysql_real_connect().
642        CLIENT_SSL )
643
644;-----------------------------------------------------------------------
645; C Structures
646;
647
648;; not "mysql-field-ptr", named so getters have nice name.
649
650(define-foreign-record (mysql-field "MYSQL_FIELD")
651        (rename: c-name->scheme-name)
652        ; No ctor or dtor
653        (c-string name)                                                                                         ; Name of column
654        (c-string org_name)                                                                             ; Original column name, if an alias
655        (c-string table)                                                                                        ; Table of column if column was a field
656        (c-string org_table)                                                                    ; Org table name, if table was an alias
657        (c-string db)                                                                                                   ; Database for table
658        (c-string catalog)                                                                              ; Catalog for table
659        (c-string def)                                                                                          ; Default value (set by mysql_list_fields)
660        (unsigned-long length)                                                          ; Width of column (create length)
661        (unsigned-long max_length)                                              ; Max width for selected set
662        (unsigned-integer name_length)
663        (unsigned-integer org_name_length)
664        (unsigned-integer table_length)
665        (unsigned-integer org_table_length)
666        (unsigned-integer db_length)
667        (unsigned-integer catalog_length)
668        (unsigned-integer def_length)
669        (unsigned-integer flags)                                                        ; Div flags
670        (unsigned-integer decimals)                                             ; Number of decimals in field
671        (unsigned-integer charsetnr)                                    ; Character set
672        (mysql-type type) )                                                                             ; Type of field. See mysql_com.h for types
673
674;; not "my-charset-info-ptr", named so getters have nice name.
675
676(define-foreign-record (my-charset-info "MY_CHARSET_INFO")
677        (rename: c-name->scheme-name)
678        (constructor: allocate-my-charset-info)
679        (destructor: free-my-charset-info)
680        (c-string name)                                                         ; character set name
681        (c-string csname)                                                       ; collation name
682        (c-string comment)                                              ; comment
683        (c-string dir)                                                          ; directory
684        (unsigned-integer mbminlen)             ; multi byte character min. length
685        (unsigned-integer mbmaxlen) ) ; multi byte character max. length
686
687;-----------------------------------------------------------------------
688; Foreign function definitions for the MySQL C API using the
689; MySQL "my_ulonglong" type.
690;
691
692; 24.2.3.1. mysql_affected_rows()
693; my_ulonglong mysql_affected_rows(MYSQL *mysql)
694(define foreign-mysql-affected-rows
695        (foreign-lambda* my-ulonglong ((mysql-ptr mysql))
696         "return( mysql_affected_rows( mysql ) );"))
697
698; 24.2.3.34. mysql_insert_id()
699; my_ulonglong mysql_insert_id(MYSQL *mysql)
700(define foreign-mysql-insert-id
701        (foreign-lambda* my-ulonglong ((mysql-ptr mysql))
702         "return( mysql_insert_id( mysql ) );"))
703
704; 24.2.3.43. mysql_num_rows()
705; my_ulonglong mysql_num_rows(MYSQL_RES *result)
706(define foreign-mysql-num-rows
707        (foreign-lambda* my-ulonglong ((mysql-res-ptr result))
708         "return( mysql_num_rows( result ) );"))
709
710; 24.2.3.7. mysql_data_seek()
711; void mysql_data_seek(MYSQL_RES *result, my_ulonglong offset)
712(define foreign-mysql-data-seek
713        (foreign-lambda* void ((mysql-res-ptr result) (my-ulonglong offset))
714         "mysql_data_seek( result, offset );"))
715
716;-----------------------------------------------------------------------
717; Foreign function definitions for mysql_options from MySQL C API.
718;
719
720;;
721
722(define foreign-mysqlaux-options-none
723        (foreign-lambda* int ((mysql-ptr mysql) (mysql-option opt))
724   "return( mysql_options( mysql, opt, NULL ) );"))
725
726;;
727
728(define foreign-mysqlaux-options-string
729        (foreign-lambda* int ((mysql-ptr mysql) (mysql-option opt) (c-string value))
730   "return( mysql_options( mysql, opt, value ) );"))
731
732;;
733
734(define foreign-mysqlaux-options-ulong
735        (foreign-lambda* int ((mysql-ptr mysql) (mysql-option opt) (unsigned-long value))
736   "return( mysql_options( mysql, opt, &value ) );"))
737
738;-----------------------------------------------------------------------
739; Foreign function definitions for mysqlaux functions.
740;
741
742;;
743
744(define foreign-mysqlaux-field-index
745        (foreign-lambda* int ((mysql-res-ptr result) (nonnull-c-string name)
746                              (unsigned-integer num_fields))
747#<<EOS
748        MYSQL_FIELD *fields = mysql_fetch_fields( result );
749        unsigned int i;
750
751        for (i = 0; i < num_fields; i++) {
752                if (0 == strcasecmp( name, fields[ i ].name )) {
753                        return( i );
754                }
755        }
756
757        return( -1 );
758EOS
759  ) )
760
761;;
762
763(define foreign-mysqlaux-is-binary-field
764        (foreign-lambda* bool ((mysql-res-ptr result) (unsigned-integer fldidx))
765#<<EOS
766        MYSQL_FIELD *fields = mysql_fetch_fields( result );
767
768        switch (fields[fldidx].type) {
769                case MYSQL_TYPE_VARCHAR:
770                case MYSQL_TYPE_TINY_BLOB:
771                case MYSQL_TYPE_MEDIUM_BLOB:
772                case MYSQL_TYPE_LONG_BLOB:
773                case MYSQL_TYPE_BLOB:
774                case MYSQL_TYPE_VAR_STRING:
775                case MYSQL_TYPE_STRING:
776                        return( 63 == fields[ fldidx ].charsetnr );
777                default:
778                  break;
779        }
780
781        return( 0 );
782EOS
783  ) )
784
785;;
786
787(define foreign-mysqlaux-fetch-column-string-direct
788        (foreign-lambda* c-string ((mysql-row row) (unsigned-integer fldidx))
789         "return( row[ fldidx ] );" ) )
790
791;;
792
793(define foreign-mysqlaux-fetch-column-data-direct
794        (foreign-lambda* c-pointer ((mysql-row row) (unsigned-integer fldidx))
795         "return( row[ fldidx ] );" ) )
796
797;-----------------------------------------------------------------------
798; Foreign function definitions from MySQL C API.
799;
800; I've copied the listing of MySQL C API functions straight from the
801; MySQL manual. They are in alphabetical order, exactly as they appear
802; in the manual. Further, the C function signature is copied below the
803; manual entry. Finally, the Scheme foreign lambda mapping follows the
804; C function signature.
805;
806
807; 24.2.3.2. mysql_change_user()
808; my_bool mysql_change_user(MYSQL *mysql, const char *user,
809;               const char *password, const char *db)
810(define foreign-mysql-change-user
811        (foreign-lambda my-bool "mysql_change_user" mysql-ptr c-string c-string
812                                                                        c-string))
813
814; 24.2.3.3. mysql_character_set_name()
815; const char *mysql_character_set_name(MYSQL *mysql)
816(define foreign-mysql-character-set-name
817        (foreign-lambda c-string "mysql_character_set_name" mysql-ptr))
818
819; 24.2.3.4. mysql_close()
820; void mysql_close(MYSQL *mysql)
821(define foreign-mysql-close
822        (foreign-lambda void "mysql_close" mysql-ptr))
823
824; 24.2.3.8. mysql_debug()
825; void mysql_debug(const char *debug)
826(define foreign-mysql-debug
827        (foreign-lambda void "mysql_debug" c-string))
828
829; 24.2.3.10. mysql_dump_debug_info()
830; int mysql_dump_debug_info(MYSQL *mysql)
831(define foreign-mysql-dump-debug-info
832        (foreign-lambda integer "mysql_dump_debug_info" mysql-ptr))
833
834; 24.2.3.12. mysql_errno()
835; unsigned int mysql_errno(MYSQL *mysql)
836(define foreign-mysql-errno
837        (foreign-lambda unsigned-integer "mysql_errno" mysql-ptr))
838
839; 24.2.3.13. mysql_error()
840; const char *mysql_error(MYSQL *mysql)
841(define foreign-mysql-error
842        (foreign-lambda c-string "mysql_error" mysql-ptr))
843
844; 24.2.3.14. mysql_escape_string()
845; unsigned long mysql_escape_string(char *to, const char *from,
846;               unsigned long length)
847(define foreign-mysql-escape-string
848        (foreign-lambda unsigned-long "mysql_escape_string" c-string c-string
849                                                                        unsigned-long))
850
851; 24.2.3.15. mysql_fetch_field()
852; MYSQL_FIELD *mysql_fetch_field(MYSQL_RES *result)
853(define foreign-mysql-fetch-field
854        (foreign-lambda mysql-field-ptr "mysql_fetch_field" mysql-res-ptr))
855
856; 24.2.3.16. mysql_fetch_fields()
857; MYSQL_FIELD *mysql_fetch_fields(MYSQL_RES *result)
858(define foreign-mysql-fetch-fields
859        (foreign-lambda mysql-field-ptr "mysql_fetch_fields" mysql-res-ptr))
860
861; 24.2.3.17. mysql_fetch_field_direct()
862; MYSQL_FIELD *mysql_fetch_field_direct(MYSQL_RES *result, unsigned int fieldnr)
863(define foreign-mysql-fetch-field-direct
864        (foreign-lambda mysql-field-ptr "mysql_fetch_field_direct" mysql-res-ptr
865                                                                        unsigned-integer))
866
867; 24.2.3.18. mysql_fetch_lengths()
868; unsigned long *mysql_fetch_lengths(MYSQL_RES *result)
869(define foreign-mysql-fetch-lengths
870        (foreign-lambda (c-pointer unsigned-long) "mysql_fetch_lengths" mysql-res-ptr))
871
872; 24.2.3.19. mysql_fetch_row()
873; MYSQL_ROW mysql_fetch_row(MYSQL_RES *result)
874(define foreign-mysql-fetch-row
875        (foreign-lambda mysql-row "mysql_fetch_row" mysql-res-ptr))
876
877; 24.2.3.20. mysql_field_count()
878; unsigned int mysql_field_count(MYSQL *mysql)
879(define foreign-mysql-field-count
880        (foreign-lambda unsigned-integer "mysql_field_count" mysql-ptr))
881
882; 24.2.3.21. mysql_field_seek()
883; MYSQL_FIELD_OFFSET mysql_field_seek(MYSQL_RES *result,
884;               MYSQL_FIELD_OFFSET offset)
885(define foreign-mysql-field-seek
886        (foreign-lambda mysql-field-offset "mysql_field_seek" mysql-res-ptr
887                                                                        mysql-field-offset))
888
889; 24.2.3.22. mysql_field_tell()
890; MYSQL_FIELD_OFFSET mysql_field_tell(MYSQL_RES *result)
891(define foreign-mysql-field-tell
892        (foreign-lambda mysql-field-offset "mysql_field_tell" mysql-res-ptr))
893
894; 24.2.3.23. mysql_free_result()
895; void mysql_free_result(MYSQL_RES *result)
896(define foreign-mysql-free-result
897        (foreign-lambda void "mysql_free_result" mysql-res-ptr))
898
899; 24.2.3.26.Êmysql_get_character_set_info()
900; void mysql_get_character_set_info(MYSQL *mysql, MY_CHARSET_INFO *cs)
901(define foreign-mysql-get-character-set-info
902        (foreign-lambda void "mysql_get_character_set_info" mysql-ptr my-charset-info))
903
904; 24.2.3.25. mysql_get_client_info()
905; char *mysql_get_client_info(void)
906(define foreign-mysql-get-client-info
907        (foreign-lambda c-string "mysql_get_client_info"))
908
909; 24.2.3.26. mysql_get_client_version()
910; unsigned long mysql_get_client_version(void)
911(define foreign-mysql-get-client-version
912        (foreign-lambda unsigned-long "mysql_get_client_version"))
913
914; 24.2.3.27. mysql_get_host_info()
915; char *mysql_get_host_info(MYSQL *mysql)
916(define foreign-mysql-get-host-info
917        (foreign-lambda c-string "mysql_get_host_info" mysql-ptr))
918
919; 24.2.3.28. mysql_get_proto_info()
920; unsigned int mysql_get_proto_info(MYSQL *mysql)
921(define foreign-mysql-get-proto-info
922        (foreign-lambda unsigned-integer "mysql_get_proto_info" mysql-ptr))
923
924; 24.2.3.29. mysql_get_server_info()
925; char *mysql_get_server_info(MYSQL *mysql)
926(define foreign-mysql-get-server-info
927        (foreign-lambda c-string "mysql_get_server_info" mysql-ptr))
928
929; 24.2.3.30. mysql_get_server_version()
930; unsigned long mysql_get_server_version(MYSQL *mysql)
931(define foreign-mysql-get-server-version
932        (foreign-lambda unsigned-long "mysql_get_server_version" mysql-ptr))
933
934; 24.2.3.31. mysql_hex_string()
935; unsigned long mysql_hex_string(char *to, const char *from,
936;               unsigned long length)
937(define foreign-mysql-hex-string
938        (foreign-lambda unsigned-long "mysql_hex_string" c-string c-string
939                                                                        unsigned-long))
940
941; 24.2.3.32. mysql_info()
942; char *mysql_info(MYSQL *mysql)
943(define foreign-mysql-info
944        (foreign-lambda c-string "mysql_info" mysql-ptr))
945
946; 24.2.3.33. mysql_init()
947; MYSQL *mysql_init(MYSQL *mysql)
948(define foreign-mysql-init
949        (foreign-lambda mysql-ptr "mysql_init" mysql-ptr))
950
951; 24.2.3.35. mysql_kill()
952; int mysql_kill(MYSQL *mysql, unsigned long pid)
953(define foreign-mysql-kill
954        (foreign-lambda integer "mysql_kill" mysql-ptr unsigned-long))
955
956; 24.2.3.36. mysql_library_init()
957; int mysql_library_init(int argc, char **argv, char **groups)
958(define foreign-mysql-library-init
959        (foreign-lambda integer "mysql_library_init" integer c-pointer c-pointer))
960
961; 24.2.3.37. mysql_library_end()
962; void mysql_library_end(void)
963(define foreign-mysql-library-end
964        (foreign-lambda void "mysql_library_end"))
965
966; 24.2.3.38. mysql_list_dbs()
967; MYSQL_RES *mysql_list_dbs(MYSQL *mysql, const char *wild)
968(define foreign-mysql-list-dbs
969        (foreign-lambda mysql-res-ptr "mysql_list_dbs" mysql-ptr c-string))
970
971; 24.2.3.39. mysql_list_fields()
972; MYSQL_RES *mysql_list_fields(MYSQL *mysql, const char *table,
973;               const char *wild)
974(define foreign-mysql-list-fields
975        (foreign-lambda mysql-res-ptr "mysql_list_fields" mysql-ptr c-string
976                                                                        c-string))
977
978; 24.2.3.40. mysql_list_processes()
979; MYSQL_RES *mysql_list_processes(MYSQL *mysql)
980(define foreign-mysql-list-processes
981        (foreign-lambda mysql-res-ptr "mysql_list_processes" mysql-ptr))
982
983; 24.2.3.41. mysql_list_tables()
984; MYSQL_RES *mysql_list_tables(MYSQL *mysql, const char *wild)
985(define foreign-mysql-list-tables
986        (foreign-lambda mysql-res-ptr "mysql_list_tables" mysql-ptr c-string))
987
988; 24.2.3.42. mysql_num_fields()
989; unsigned int mysql_num_fields(MYSQL_RES *result)
990(define foreign-mysql-num-fields
991        (foreign-lambda unsigned-integer "mysql_num_fields" mysql-res-ptr))
992
993; 24.2.3.44. mysql_options()
994; int mysql_options(MYSQL *mysql, enum mysql_option option, const char *arg)
995(define foreign-mysql-options
996        (foreign-lambda integer "mysql_options" mysql-ptr mysql-option c-pointer))
997
998; 24.2.3.45. mysql_ping()
999; int mysql_ping(MYSQL *mysql)
1000(define foreign-mysql-ping
1001        (foreign-lambda integer "mysql_ping" mysql-ptr))
1002
1003; 24.2.3.46. mysql_query()
1004; int mysql_query(MYSQL *mysql, const char *stmt_str)
1005;
1006; NOTE: use "mysql_real_query" instead
1007(define foreign-mysql-query
1008        (foreign-lambda integer "mysql_query" mysql-ptr c-string))
1009
1010; 24.2.3.47. mysql_real_connect()
1011; MYSQL *mysql_real_connect(MYSQL *mysql, const char *host, const char *user,
1012;               const char *passwd, const char *db, unsigned int port,
1013;               const char *unix_socket, unsigned long client_flag)
1014(define foreign-mysql-real-connect
1015        (foreign-lambda mysql-ptr "mysql_real_connect"
1016                                                                        mysql-ptr c-string c-string
1017                                                                        c-string c-string unsigned-integer
1018                                                                        c-string unsigned-long))
1019
1020; 24.2.3.48. mysql_real_escape_string()
1021; unsigned long mysql_real_escape_string(MYSQL *mysql, char *to,
1022;               const char *from, unsigned long length)
1023(define foreign-mysql-real-escape-string
1024        (foreign-lambda unsigned-long "mysql_real_escape_string" mysql-ptr
1025                                                                        c-string c-string unsigned-long))
1026
1027; 24.2.3.49. mysql_real_query()
1028; int mysql_real_query(MYSQL *mysql, const char *query, unsigned long length)
1029(define foreign-mysql-real-query
1030        (foreign-lambda unsigned-integer "mysql_real_query" mysql-ptr c-string
1031                                                                        unsigned-long))
1032
1033; 24.2.3.51. mysql_row_seek()
1034; MYSQL_ROW_OFFSET mysql_row_seek(MYSQL_RES *result, MYSQL_ROW_OFFSET offset)
1035(define foreign-mysql-row-seek
1036        (foreign-lambda mysql-rows-ptr "mysql_row_seek" mysql-res-ptr mysql-rows-ptr))
1037
1038; 24.2.3.52. mysql_row_tell()
1039; MYSQL_ROW_OFFSET mysql_row_tell(MYSQL_RES *result)
1040(define foreign-mysql-row-tell
1041        (foreign-lambda mysql-rows-ptr "mysql_row_tell" mysql-res-ptr))
1042
1043; 24.2.3.53. mysql_select_db()
1044; int mysql_select_db(MYSQL *mysql, const char *db)
1045(define foreign-mysql-select-db
1046        (foreign-lambda integer "mysql_select_db" mysql-ptr c-string))
1047
1048; 24.2.3.54. mysql_set_character_set()
1049; int mysql_set_character_set(MYSQL *mysql, char *csname)
1050(define foreign-mysql-set-character-set
1051        (foreign-lambda integer "mysql_set_character_set" mysql-ptr c-string))
1052
1053; 24.2.3.55. mysql_set_server_option()
1054; int mysql_set_server_option(MYSQL *mysql, enum enum_mysql_set_option option)
1055(define foreign-mysql-set-server-option
1056        (foreign-lambda integer "mysql_set_server_option" mysql-ptr mysql-server-option))
1057
1058; 24.2.3.56. mysql_shutdown()
1059; int mysql_shutdown(MYSQL *mysql, enum enum_shutdown_level shutdown_level)
1060(define foreign-mysql-shutdown
1061        (foreign-lambda integer "mysql_shutdown" mysql-ptr integer))
1062
1063; 24.2.3.57. mysql_sqlstate()
1064; const char *mysql_sqlstate(MYSQL *mysql)
1065(define foreign-mysql-sqlstate
1066        (foreign-lambda c-string "mysql_sqlstate" mysql-ptr))
1067
1068; 24.2.3.58. mysql_ssl_set()
1069; int mysql_ssl_set(MYSQL *mysql, const char *key, const char *cert,
1070;               const char *ca, const char *capath, const char *cipher)
1071(define foreign-mysql-ssl-set
1072        (foreign-lambda integer "mysql_ssl_set" mysql-ptr c-string c-string
1073                                                                        c-string c-string c-string))
1074
1075; 24.2.3.59. mysql_stat()
1076; char *mysql_stat(MYSQL *mysql)
1077(define foreign-mysql-stat
1078        (foreign-lambda c-string "mysql_stat" mysql-ptr))
1079
1080; 24.2.3.60. mysql_store_result()
1081; MYSQL_RES *mysql_store_result(MYSQL *mysql)
1082(define foreign-mysql-store-result
1083        (foreign-lambda mysql-res-ptr "mysql_store_result" mysql-ptr))
1084
1085; 24.2.3.61. mysql_thread_id()
1086; unsigned long mysql_thread_id(MYSQL *mysql)
1087(define foreign-mysql-thread-id
1088        (foreign-lambda unsigned-long "mysql_thread_id" mysql-ptr))
1089
1090; 24.2.3.62. mysql_use_result()
1091; MYSQL_RES *mysql_use_result(MYSQL *mysql)
1092(define foreign-mysql-use-result
1093        (foreign-lambda mysql-res-ptr "mysql_use_result" mysql-ptr))
1094
1095; 24.2.3.63. mysql_warning_count()
1096; unsigned int mysql_warning_count(MYSQL *mysql)
1097(define foreign-mysql-warning-count
1098        (foreign-lambda unsigned-integer "mysql_warning_count" mysql-ptr))
1099
1100; 24.2.3.64. mysql_commit()
1101; my_bool mysql_commit(MYSQL *mysql)
1102(define foreign-mysql-commit
1103        (foreign-lambda my-bool "mysql_commit" mysql-ptr))
1104
1105; 24.2.3.65. mysql_rollback()
1106; my_bool mysql_rollback(MYSQL *mysql)
1107(define foreign-mysql-rollback
1108        (foreign-lambda my-bool "mysql_rollback" mysql-ptr))
1109
1110; 24.2.3.66. mysql_autocommit()
1111; my_bool mysql_autocommit(MYSQL *mysql, my_bool mode)
1112(define foreign-mysql-autocommit
1113        (foreign-lambda my-bool "mysql_autocommit" mysql-ptr my-bool))
1114
1115; 24.2.3.67. mysql_more_results()
1116; my_bool mysql_more_results(MYSQL *mysql)
1117(define foreign-mysql-more-results
1118        (foreign-lambda my-bool "mysql_more_results" mysql-ptr))
1119
1120; 24.2.3.68. mysql_next_result()
1121; int mysql_next_result(MYSQL *mysql)
1122(define foreign-mysql-next-result
1123        (foreign-lambda integer "mysql_next_result" mysql-ptr))
1124
1125;-----------------------------------------------------------------------
1126; MySQL helpers
1127;
1128
1129;; record printer helper
1130
1131(define (optional-value->string val lbl #!optional (tst val))
1132        (if tst
1133                        (conc #\space lbl #\: #\space #\" val #\")
1134                        "") )
1135
1136;;
1137
1138(define (unsigned-long-array->u32vector ulptr cnt)
1139        (let* ([siz (fx* cnt (foreign-value "sizeof( unsigned long )" int))]
1140                                 [store (make-blob siz)])
1141                (move-memory! ulptr store siz)
1142                (blob->u32vector/shared store) ) )
1143
1144;;
1145
1146#; ; UNUSED
1147(define char-pointer->string
1148        (foreign-lambda* c-string ((c-pointer chrptr))
1149                "return( (char *) chrptr );") )
1150
1151;;
1152
1153(define (binary-char-pointer->string chrptr size)
1154        (let ([blob (make-blob size)])
1155                (move-memory! chrptr blob size)
1156                (blob->string blob) ) )
1157
1158;; Returns index for field identifier
1159;; field  : a field index or a field name (converted to a string)
1160;; resptr : result or #f
1161;; fldcnt : total number of fields (for check)
1162
1163(define (mysql-get-field-index resptr field fldcnt)
1164        (and-let* ([fldidx
1165                    (cond [(number? field)
1166                      field]
1167                    [resptr
1168                      (foreign-mysqlaux-field-index resptr (->string field) fldcnt)]
1169                    [else
1170                      #f])])
1171                (and (<= 0 fldidx) (< fldidx fldcnt)
1172                                 fldidx ) ) )
1173
1174;-----------------------------------------------------------------------
1175; MySQL exceptions
1176;
1177
1178;; Returns a Chicken "exn" exception object
1179
1180(define (make-exn-condition loc msg . args)
1181        (make-property-condition 'exn 'location loc 'message msg 'arguments args) )
1182
1183;; Returns a Chicken "mysql" exception object
1184
1185(define (make-mysql-condition)
1186        (make-property-condition 'mysql) )
1187
1188;; Returns a Chicken "exn mysql" exception object
1189
1190(define (make-exn-mysql-condition loc msg . args)
1191        (make-composite-condition
1192         (apply make-exn-condition loc msg args)
1193         (make-mysql-condition)) )
1194
1195;; Raises a Chicken "exn mysql" exception object
1196
1197(define (signal-mysql-condition loc msg . args)
1198        (signal (apply make-exn-mysql-condition loc msg args)) )
1199
1200;; Raises a Chicken "exn mysql" exception object with a connection error message
1201
1202(define (signal-mysql-error loc conn . args)
1203        (let ([msg (or (mysql-error conn)
1204                                                                 (mysql-errno conn))])
1205                (apply signal-mysql-condition loc msg args) ) )
1206
1207;=======================================================================
1208; Provided Scheme API.
1209;
1210; This is an attempt at a Schemer-friendly API to MySQL. Much of the API
1211; is the same, but the C API has been simplified where possible, and a
1212; few additional features have been layered on.
1213;
1214
1215;-----------------------------------------------------------------------
1216; MySQL "SSL" record type.
1217;
1218; See <http://www.openssl.org/docs/apps/ciphers.html> for a discussion
1219; of the cipher-list format.
1220;
1221
1222;;
1223
1224(define-record-type mysql-ssl
1225        (%make-mysql-ssl key cert ca capath cipher)
1226        mysql-ssl?
1227        (key mysql-ssl-key-pathname)
1228        (cert mysql-ssl-certificate-pathname)
1229        (ca mysql-ssl-certificate-authority-pathname)
1230        (capath mysql-ssl-trusted-certificates-pathname)
1231        (cipher mysql-ssl-ciphers) )
1232
1233;;
1234
1235(define (make-mysql-ssl #!key key certificate certificate-authority
1236                                                                                                                        trusted-certificates ciphers)
1237        (%make-mysql-ssl key certificate certificate-authority trusted-certificates ciphers) )
1238
1239;;
1240
1241(define-record-printer (mysql-ssl ssl out)
1242        (let ([key (mysql-ssl-key-pathname ssl)]
1243                                [cert (mysql-ssl-certificate-pathname ssl)]
1244                                [ca (mysql-ssl-certificate-authority-pathname ssl)]
1245                                [capath (mysql-ssl-trusted-certificates-pathname ssl)]
1246                                [cipher (mysql-ssl-ciphers ssl)])
1247                (display
1248                 (string-append
1249                        "#<mysql-ssl"
1250                        (optional-value->string key     "key")
1251                        (optional-value->string cert    "cert")
1252                        (optional-value->string ca      "ca")
1253                        (optional-value->string capath  "capath")
1254                        (optional-value->string cipher  "cipher")
1255                        ">")
1256                 out) ) )
1257
1258;;
1259
1260(define (mysql-ssl-set! mysql ssl)
1261  (when ssl
1262    (foreign-mysql-ssl-set mysql
1263                           (mysql-ssl-key-pathname ssl)
1264                           (mysql-ssl-certificate-pathname ssl)
1265                           (mysql-ssl-certificate-authority-pathname ssl)
1266                           (mysql-ssl-trusted-certificates-pathname ssl)
1267                           (mysql-ssl-ciphers ssl)) ) )
1268
1269;-----------------------------------------------------------------------
1270; MySQL connection options.
1271;
1272
1273;; Returns a mysql-options object
1274
1275(define (make-mysql-options . opts)
1276        (let loop ([opts opts] [alst '()])
1277                (if (null? opts)
1278                                alst
1279                                (let* ([opt (car opts)]
1280                                                         [nxt (cdr opts)]
1281                                                         [val (if (null? nxt)
1282                                                                                                (error 'make-options "missing value for option" opt)
1283                                                                                                (car nxt))])
1284                                        (unless (number? opt)
1285                                                (error 'make-options "invalid option" opt) )
1286                                        (unless (or (number? val) (string? val) (not val) (null? val))
1287                                                (error 'make-options "invalid option value" val) )
1288                                        (loop (cdr nxt) (alist-cons opt val alst)) ) ) ) )
1289
1290;;
1291
1292(define (mysql-option-set! mysql opt val)
1293        (cond [(null? val)
1294                                        (foreign-mysqlaux-options-none mysql opt)]
1295                                [(string? val)
1296                                        (foreign-mysqlaux-options-string mysql opt val)]
1297                                [(number? val)
1298                                        (foreign-mysqlaux-options-ulong mysql opt val)]
1299                                [else
1300                                        1 ] ) )
1301
1302;;
1303
1304(define (mysql-options-set! mysql options)
1305  (when options
1306    (for-each
1307     (lambda (optitm)
1308       (let ([opt (car optitm)]
1309             [val (cdr optitm)])
1310         (unless (fx= 0 (mysql-option-set! mysql opt val))
1311           (signal-mysql-condition 'mysql-connect "unknown option" opt val))))
1312     options) ) )
1313
1314;-----------------------------------------------------------------------
1315; MySQL "Connection" record type definition.
1316;
1317; I've stuffed the raw FFI pointer into a slot in the mysql-connection
1318; record. The record is here for a few reasons:
1319;
1320;               1) Instead of an ugly #<pointer>, I've defined a pretty printer
1321;                        to demonstrate that we've actually got a MySQL connection.
1322;               2) The C API is somewhat more verbose than what normal usage would
1323;                        need. (For example, usually you don't care whether results are
1324;                        all read into memory as fast as possible, or if they're read from
1325;                        the network one-by-one. Thus, the mysql-query function provided
1326;                        automatically reads the results into memory. For finer granularity,
1327;                        you're always free to write your own version to use the "raw"
1328;                        foreign-* functions. I suppose a contribution to determine this
1329;                        behavior via a (make-parameter ...) parameter may also be
1330;                        accepted. ;)) Slots are provided in the mysql-connection record
1331;                        type to allow for this sort of simplifying behavior.
1332;
1333; All of the "Scheme API" MySQL functions take instances of this record
1334; type, instead of a raw FFI pointer (as the foreign-* functions require).
1335;
1336
1337;;
1338
1339(define-record-type mysql-connection
1340        (%make-mysql-connection host user passwd db port unix-socket
1341                                                                                                client-flag connptr result result-start ssl opts
1342                                                                                                  #;
1343                                                                                                  stmt
1344                                                                                                  #;
1345                                                                                                  prmbnds
1346                                                                                                  #;
1347                                                                                                  resbnds)
1348        mysql-connection?
1349        (host mysql-connection-host)
1350        (user mysql-connection-user)
1351        (passwd mysql-connection-passwd)
1352        (db mysql-connection-db)
1353        (port mysql-connection-port)
1354        (unix-socket mysql-connection-unix-socket)
1355        (client-flag mysql-connection-client-flag)
1356        (connptr mysql-connection-ptr mysql-connection-ptr-set!)
1357        (result mysql-connection-result mysql-connection-result-set!)
1358        (result-start mysql-connection-result-start mysql-connection-result-start-set!)
1359        (ssl mysql-connection-ssl)
1360        (opts mysql-connection-options)
1361        #;
1362        (stmt mysql-connection-statement mysql-connection-statement-set!)
1363        #; ; Toggles btwn param & result
1364        (bnds mysql-connection-bindings mysql-connection-bindings-set!) )
1365
1366;;
1367
1368(define (make-mysql-connection mysql host user passwd db port unix-socket client-flag options ssl)
1369  (mysql-ssl-set! mysql ssl)
1370  (mysql-options-set! mysql options)
1371  (let ([connptr (foreign-mysql-real-connect mysql
1372                                             host user passwd
1373                                             db
1374                                             port unix-socket
1375                                             client-flag)])
1376    (if mysqlptr
1377        (%make-mysql-connection host user passwd db port unix-socket
1378                                client-flag connptr #f #f options ssl
1379                                #;
1380                                #f
1381                                #;
1382                                #f)
1383        (signal-mysql-condition 'mysql-connect
1384         (foreign-mysql-error mysql)
1385         host user passwd db port unix-socket client-flag options ssl options) ) ) )
1386
1387; MySQL Connection verification functions
1388
1389(define (mysql-is-closed? conn)
1390  (not (mysql-connection-ptr conn)))
1391 
1392(define (mysql-check-connection conn)
1393  (if (mysql-is-closed? conn)
1394      (signal-mysql-condition 'mysql-check-connection "connection is closed")))
1395
1396;; Specialized connection record printers
1397
1398 ;DEBUG
1399(define-record-printer (mysql-connection conn out)
1400  (mysql-check-connection conn)
1401        (let ([host (mysql-connection-host conn)]
1402                                [user (mysql-connection-user conn)]
1403                                [passwd (mysql-connection-passwd conn)]
1404                                [db (mysql-connection-db conn)]
1405                                [tcp-port (mysql-connection-port conn)]
1406                                [unix-socket (mysql-connection-unix-socket conn)]
1407                                [client-flag (mysql-connection-client-flag conn)]
1408                                [ssl (mysql-connection-ssl conn)]
1409                                [opts (mysql-connection-options conn)]
1410                                #;
1411                                [stmt (mysql-connection-statement conn)]
1412                                #;
1413                                [bnds (mysql-connection-bindings conn)])
1414                (display
1415                 (string-append
1416                        "#<mysql-connection"
1417                        (if (mysql-connection-ptr conn)
1418                                        (string-append
1419                                                (optional-value->string host                                    "host")
1420                                                (optional-value->string user                                    "user")
1421                                                (optional-value->string passwd                          "passwd")
1422                                                (optional-value->string db                                              "db")
1423                                                (optional-value->string tcp-port                        "tcp-port"              (not (fx= 0 tcp-port)))
1424                                                (optional-value->string unix-socket   "unix-socket")
1425                                                (optional-value->string client-flag   "client-flag" (not (fx= 0 client-flag)))
1426                                                (optional-value->string ssl                                       "ssl")
1427                                                (optional-value->string opts                                    "options")
1428                                                #;
1429                                                (optional-value->string stmt                                    "statement")
1430                                                #;
1431                                                (optional-value->string bnds                  "bindings") )
1432                                        " INVALID")
1433                        ">")
1434                 out) ) )
1435
1436#; ;RELEASE
1437(define-record-printer (mysql-connection conn out)
1438  (mysql-check-connection conn)
1439        (let ([host (mysql-connection-host conn)]
1440                                [user (mysql-connection-user conn)]
1441                                [passwd (mysql-connection-passwd conn)]
1442                                [db (mysql-connection-db conn)]
1443                                [tcp-port (mysql-connection-port conn)]
1444                                [unix-socket (mysql-connection-unix-socket conn)]
1445                                [client-flag (mysql-connection-client-flag conn)]
1446                                [ssl (mysql-connection-ssl conn)]
1447                                [opts (mysql-connection-options conn)])
1448                (display
1449                 (string-append
1450                        "#<mysql-connection"
1451                        (if (mysql-connection-ptr conn)
1452                                        (string-append
1453                                                (optional-value->string host  "host")
1454                                                (optional-value->string user  "user") )
1455                                        " INVALID")
1456                        ">")
1457                 out) ) )
1458
1459;-----------------------------------------------------------------------
1460; The "base" MySQL/Scheme API.
1461;
1462; This part of the API provides a slightly simplified version of the full
1463; MySQL C API.
1464;
1465
1466;;
1467
1468(define (mysql-affected-rows conn)
1469  (mysql-check-connection conn)
1470        (let ([cnt (foreign-mysql-affected-rows (mysql-connection-ptr conn))])
1471                (and (not (= -1 cnt))
1472                                 cnt ) ) )
1473
1474;;
1475
1476(define (mysql-change-user conn #!key (user #f) (passwd #f) (db #f))
1477  (mysql-check-connection conn)
1478        (foreign-mysql-change-user (mysql-connection-ptr conn) user passwd db) )
1479
1480;;
1481
1482(define (mysql-character-set-name conn)
1483  (mysql-check-connection conn)
1484        (foreign-mysql-character-set-name (mysql-connection-ptr conn)))
1485
1486;; Closes a mysql connection and invalidates the mysql connection object.
1487;; Returns (void). You should do this when you're done with the MySQL
1488;; connection; however, if you don't close it manually, it will be closed
1489;; upon termination.
1490
1491(define (mysql-close conn)
1492        #;
1493        (mysql-stmt-close conn)
1494        (mysql-free-result conn)
1495        (foreign-mysql-close (mysql-connection-ptr conn))
1496        (mysql-connection-ptr-set! conn #f) )
1497
1498;; Returns a mysql connection object, or #f on failure.
1499
1500(define (mysql-connect #!key (host #f) (user #f) (passwd #f) (db #f) (port 0)
1501                                                                                         (unix-socket #f) (client-flag 0)
1502                                                                                         (options #f) (ssl #f))
1503        (let ([mysql (foreign-mysql-init #f)])
1504                (if mysql
1505        (make-mysql-connection mysql host user passwd db port unix-socket client-flag options ssl)
1506        (signal-mysql-condition 'mysql-connect "failed to initialize mysql") ) ) )
1507
1508;;
1509
1510(define (mysql-debug debug)
1511        (foreign-mysql-debug debug) )
1512
1513;;
1514
1515(define (mysql-dump-debug-info conn)
1516  (mysql-check-connection conn)
1517        (foreign-mysql-dump-debug-info (mysql-connection-ptr conn)) )
1518
1519;;
1520
1521(define (mysql-errno conn)
1522  (mysql-check-connection conn)
1523        (foreign-mysql-errno (mysql-connection-ptr conn)))
1524
1525;; Returns a string describing the last mysql error, or #f if no error
1526;; has occurred.
1527
1528(define (mysql-error conn)
1529  (mysql-check-connection conn)
1530        (let ([errstr (foreign-mysql-error (mysql-connection-ptr conn))])
1531                (and (not (string=? "" errstr))
1532                                 errstr) ) )
1533
1534;;
1535
1536(define (mysql-escape-string conn str)
1537        (let-location ([escstr c-string*])
1538                ((foreign-lambda* void ((mysql-ptr mysql) (c-pointer to) (c-string from) (unsigned-long length))
1539                        "if ((*((char **) to) = ((char *) C_malloc( (2 * length) + 1 )))) {\n"
1540                        "                (void) mysql_real_escape_string( mysql, *((char **) to), from, length );\n"
1541                        "}")
1542                 #$escstr
1543                 str (string-length str))
1544                escstr ) )
1545
1546;; Returns a mysql-field-ptr or #f when no more fields.
1547;; Returns #f when no result set.
1548
1549(define (mysql-fetch-field conn)
1550        (and-let* ([resptr (mysql-connection-result conn)])
1551                (foreign-mysql-fetch-field resptr) ) )
1552
1553;; Returns a mysql-field-ptr to a vector of MYSQL_FIELD or #f when no fields.
1554;; Returns #f when no result set.
1555
1556(define (mysql-fetch-fields conn)
1557        (and-let* ([resptr (mysql-connection-result conn)])
1558                (foreign-mysql-fetch-fields resptr) ) )
1559
1560;; Returns a mysql-field-ptr or #f when no such field.
1561;; Returns #f when no result set.
1562
1563(define (mysql-fetch-field-direct conn field-number)
1564        (and-let* ([resptr (mysql-connection-result conn)])
1565                (foreign-mysql-fetch-field-direct resptr field-number) ) )
1566
1567;; Returns a u32vector of length num-fields.
1568;; Returns #f when no result set.
1569
1570(define (mysql-fetch-lengths resptr cnt)
1571        (and-let* ([ulptr (foreign-mysql-fetch-lengths resptr)])
1572                (unsigned-long-array->u32vector ulptr cnt) ) )
1573
1574;; Returns a u32vector of length num-fields.
1575;; Returns #f when no result set.
1576
1577(define (mysql-fetch-lengths conn)
1578        (and-let* ([resptr (mysql-connection-result conn)])
1579                (mysql-fetch-lengths resptr (foreign-mysql-num-fields resptr)) ) )
1580
1581;; After a mysql-query that has results, use mysql-fetch-row to retrieve
1582;; results row-by-row. When no more rows are left, returns #f. When returning
1583;; a "row", returns a procedure that takes exactly 1 argument, which may
1584;; be either a number (in which case it is treated as the column index,
1585;; starting at zero) or a symbol or string (which will be treated as the
1586;; column name).
1587
1588(define (mysql-fetch-row conn)
1589        (and-let* ([resptr (mysql-connection-result conn)]
1590                                                 [row (foreign-mysql-fetch-row resptr)])
1591                (let ([fldcnt (foreign-mysql-num-fields resptr)]
1592                                        [fldlens #f])
1593                        (lambda (field)
1594                                (and-let* ([fldidx (mysql-get-field-index resptr field fldcnt)])
1595                                        (if (foreign-mysqlaux-is-binary-field resptr fldidx)
1596                                                        (binary-char-pointer->string
1597                                                         (foreign-mysqlaux-fetch-column-data-direct row fldidx)
1598                                                         (u32vector-ref
1599                                                                (or fldlens
1600                                                                                (begin
1601                                                                                        (set! fldlens (mysql-fetch-lengths resptr fldcnt))
1602                                                                                        fldlens ) )
1603                                                                fldidx))
1604                                                        (foreign-mysqlaux-fetch-column-string-direct row fldidx) ) ) ) ) ) )
1605
1606;;
1607
1608(define (mysql-field-count conn)
1609  (mysql-check-connection conn)
1610        (foreign-mysql-field-count (mysql-connection-ptr conn)) )
1611
1612;;
1613
1614(define (mysql-free-result conn)
1615        (and-let* ([res (mysql-connection-result conn)])
1616                (foreign-mysql-free-result res) )
1617        (mysql-connection-result-set! conn #f)
1618        (mysql-connection-result-start-set! conn #f) )
1619
1620;; Returns a c-pointer to a MY_CHARSET_INFO struct.
1621;; a finalizer is supplied.
1622
1623(define (mysql-get-character-set-info conn)
1624  (mysql-check-connection conn)
1625        (let ([chrsetinfo (allocate-my-charset-info)])
1626                (foreign-mysql-get-character-set-info (mysql-connection-ptr conn) chrsetinfo)
1627                (set-finalizer! chrsetinfo free-my-charset-info)
1628                chrsetinfo ) )
1629
1630;;
1631
1632(define (mysql-get-client-info)
1633        (foreign-mysql-get-client-info) )
1634
1635;;
1636
1637(define (mysql-get-client-version)
1638        (foreign-mysql-get-client-version) )
1639
1640;;
1641
1642(define (mysql-get-host-info conn)
1643  (mysql-check-connection conn)
1644        (foreign-mysql-get-host-info (mysql-connection-ptr conn)) )
1645
1646;;
1647
1648(define (mysql-get-proto-info conn)
1649  (mysql-check-connection conn)
1650        (foreign-mysql-get-proto-info (mysql-connection-ptr conn)) )
1651
1652;;
1653
1654(define (mysql-get-server-info conn)
1655  (mysql-check-connection conn)
1656        (foreign-mysql-get-server-info (mysql-connection-ptr conn)) )
1657
1658;;
1659
1660(define (mysql-get-server-version conn)
1661  (mysql-check-connection conn)
1662        (foreign-mysql-get-server-version (mysql-connection-ptr conn)) )
1663
1664;;
1665
1666(define (mysql-info conn)
1667  (mysql-check-connection conn)
1668        (foreign-mysql-info (mysql-connection-ptr conn)) )
1669
1670;;
1671
1672(define (mysql-insert-id conn)
1673  (mysql-check-connection conn)
1674        (foreign-mysql-insert-id (mysql-connection-ptr conn)) )
1675
1676;;
1677
1678(define (mysql-kill conn pid)
1679  (mysql-check-connection conn)
1680        (foreign-mysql-kill (mysql-connection-ptr conn) pid) )
1681
1682;;
1683
1684(define (mysql-list-dbs conn like)
1685  (mysql-check-connection conn)
1686        (mysql-free-result conn)
1687        (mysql-connection-result-set! conn
1688                (foreign-mysql-list-dbs (mysql-connection-ptr conn) like)) )
1689
1690;;
1691
1692(define (mysql-list-fields conn table wild)
1693  (mysql-check-connection conn)
1694        (mysql-free-result conn)
1695        (mysql-connection-result-set! conn
1696                (foreign-mysql-list-fields (mysql-connection-ptr conn) table wild)) )
1697
1698;;
1699
1700(define (mysql-list-processes conn)
1701  (mysql-check-connection conn)
1702        (mysql-free-result conn)
1703        (mysql-connection-result-set! conn
1704                (foreign-mysql-list-processes (mysql-connection-ptr conn))) )
1705
1706;;
1707
1708(define (mysql-list-tables conn wild)
1709  (mysql-check-connection conn)
1710        (mysql-free-result conn)
1711        (mysql-connection-result-set! conn
1712                (foreign-mysql-list-tables (mysql-connection-ptr conn) wild)) )
1713
1714;;
1715
1716(define (mysql-num-fields conn)
1717        (foreign-mysql-num-fields (mysql-connection-result conn)) )
1718
1719;;
1720
1721(define (mysql-num-rows conn)
1722        (and-let* ([res (mysql-connection-result conn)])
1723                (foreign-mysql-num-rows res)) )
1724
1725;;
1726
1727(define (mysql-ping conn)
1728  (mysql-check-connection conn)
1729        (foreign-mysql-ping (mysql-connection-ptr conn)) )
1730
1731;; Returns #t if the query was successful, signals exception otherwise.
1732
1733(define (mysql-query conn query)
1734  (mysql-check-connection conn)
1735        (let ([mysql-ptr (mysql-connection-ptr conn)])
1736                ; zero indicates success
1737                (if (fx= 0 (foreign-mysql-real-query mysql-ptr query (string-length query)))
1738                                (begin (mysql-store-result conn) #t)
1739                                (signal-mysql-error 'mysql-query conn query) ) ) )
1740
1741;; Returns #t if the select was successful, signals exception otherwise.
1742
1743(define (mysql-select-db conn db)
1744  (mysql-check-connection conn)
1745        (or (fx= 0 (foreign-mysql-select-db (mysql-connection-ptr conn) db))
1746                        (signal-mysql-error 'mysql-select-db conn db) ) )
1747
1748;; Returns #t if the set was successful, signals exception otherwise.
1749
1750(define (mysql-set-character-set conn csname)
1751  (mysql-check-connection conn)
1752        (or (fx= 0 (foreign-mysql-set-character-set (mysql-connection-ptr conn) csname))
1753                        (signal-mysql-condition 'mysql-set-character-set "bad character set name" csname) ) )
1754
1755;;
1756
1757(define (mysql-stat conn)
1758  (mysql-check-connection conn)
1759        (foreign-mysql-stat (mysql-connection-ptr conn)) )
1760
1761;;
1762
1763(define (mysql-store-result conn)
1764  (mysql-check-connection conn)
1765        (mysql-connection-result-set! conn
1766         (foreign-mysql-store-result (mysql-connection-ptr conn)))
1767        (mysql-connection-result-start-set! conn
1768        (and (mysql-connection-result conn)
1769                         (foreign-mysql-row-tell (mysql-connection-result conn))) ) )
1770
1771;;
1772
1773(define (mysql-thread-id conn)
1774  (mysql-check-connection conn)
1775        (foreign-mysql-thread-id (mysql-connection-ptr conn)) )
1776
1777;-----------------------------------------------------------------------
1778; The "extended" MySQL/Scheme API.
1779;
1780; This API provides some additional functionality.
1781;
1782
1783;; Rewinds to the beginning of the result set. has no effect if there is no
1784;; current result set.
1785
1786(define (mysql-rewind conn)
1787        (and-let* ([resptr (mysql-connection-result-start conn)])
1788                (foreign-mysql-row-seek (mysql-connection-result conn) resptr) ) )
1789
1790;-----------------------------------------------------------------------
1791; The "map" MySQL/Scheme API.
1792;
1793; This API provides some additional functionality for traversing results
1794; in a Scheme-ish way.
1795;
1796
1797;; calls proc on every row in the current result set. proc should take 3
1798;; arguments: the row (as described for mysql-fetch-row), the row index
1799;; (which starts with 1 and ends with (mysql-num-rows conn)), and the
1800;; current accumulated value.
1801;;
1802;; Returns the final accumulated value.
1803;;
1804;; note: rewinds the result set before and after iterating over it; thus,
1805;; all rows are included.
1806;;
1807;; you must call mysql-rewind if you later want to iterate over the result set
1808;; using mysql-fetch-row.
1809
1810(define (mysql-row-fold conn proc init)
1811        (mysql-rewind conn)
1812        (let loop ([rownum 1] [acc init])
1813                (let ([row (mysql-fetch-row conn)])
1814                        (if row
1815                                        (loop (fx+ rownum 1) (proc row rownum acc))
1816                                        acc ) ) ) )
1817
1818;; calls proc on every row in the current result set. proc should take 2
1819;; arguments: the row (as described for mysql-fetch-row) and the row index
1820;; (which starts with 1 and ends with (mysql-num-rows conn)).
1821;;
1822;; note: rewinds the result set before and after iterating over it; thus,
1823;; all rows are included.
1824;;
1825;; you must call mysql-rewind if you later want to iterate over the result set
1826;; using mysql-fetch-row.
1827
1828(define (mysql-row-for-each conn proc)
1829        (mysql-row-fold conn
1830                                                                        (lambda (row rownum _) (proc row rownum))
1831                                                                        #t) )
1832
1833;; calls proc on every row in the current result set. proc should take 2
1834;; arguments: the row (as described for mysql-fetch-row) and the row index
1835;; (which starts with 1 and ends with (mysql-num-rows conn)).
1836;;
1837;; Returns a list of the results of each proc invocation.
1838;;
1839;; note: rewinds the result set before and after iterating over it; thus,
1840;; all rows are included.
1841;;
1842;; you must call mysql-rewind if you later want to iterate over the result set
1843;; using mysql-fetch-row.
1844
1845(define (mysql-row-map conn proc)
1846        (reverse!
1847                (mysql-row-fold conn
1848                                                                                (lambda (row rownum lst) (cons (proc row rownum) lst))
1849                                                                                '())) )
1850
1851;; executes query and then mysql-row-for-each with the given proc. The proc
1852;; must meet the contract specified for the proc passed to mysql-row-for-each.
1853
1854(define (mysql-query-fold conn query proc init)
1855        (mysql-query conn query)
1856        (mysql-row-fold conn proc init) )
1857
1858;; executes query and then mysql-row-for-each with the given proc. The proc
1859;; must meet the contract specified for the proc passed to mysql-row-for-each.
1860
1861(define (mysql-query-for-each conn query proc)
1862        (mysql-query conn query)
1863        (mysql-row-for-each conn proc) )
1864
1865;; executes query and then mysql-row-for-each with the given proc. The proc
1866;; must meet the contract specified for the proc passed to mysql-row-for-each.
1867
1868(define (mysql-query-map conn query proc)
1869        (mysql-query conn query)
1870        (mysql-row-map conn proc) )
1871
1872;; Synonyms
1873
1874(define mysql-query-foreach mysql-query-for-each)
1875(define mysql-foreach-row mysql-row-for-each)
1876
1877;-----------------------------------------------------------------------
1878; The MySQL Field structure predicate API.
1879;
1880
1881;;
1882
1883(define (mysql-field-flags-test fldptr mask)
1884        (bitwise-and (mysql-field-flags fldptr) mask) )
1885
1886;;
1887
1888(define (mysql-field-flags-mask flags)
1889        (apply bitwise-ior flags) )
1890
1891;;
1892
1893(define (mysql-field-flags-on? fldptr . flags)
1894        (let ([mask (mysql-field-flags-mask flags)])
1895                (= mask (mysql-field-flags-test fldptr mask)) ) )
1896
1897;;
1898
1899(define (mysql-field-flags-off? fldptr . flags)
1900        (fx= 0 (mysql-field-flags-test fldptr (mysql-field-flags-mask flags))) )
1901
1902;;
1903
1904(define (mysql-field-type-any? fldptr . types)
1905        (memv (mysql-field-type fldptr) types) )
1906
1907;;
1908
1909(define (mysql-field-type=? fldptr type)
1910        (eqv? type (mysql-field-type fldptr)) )
1911
1912;;
1913
1914(define (mysql-field-primary-key? fldptr)
1915        (mysql-field-flags-on? fldptr pri-key-flag) )
1916
1917;;
1918
1919(define (mysql-field-not-null? fldptr)
1920        (mysql-field-flags-on? fldptr not-null-flag) )
1921
1922;;
1923
1924(define (mysql-field-binary? fldptr)
1925        (= 63 (mysql-field-charsetnr fldptr)) )
1926
1927;;
1928
1929(define (mysql-field-numeric? fldptr)
1930        (mysql-field-flags-on? fldptr num-flag) )
1931
1932;;
1933
1934(define mysql-field-type-clock?
1935        (let ([numtypes (list mysql-type-timestamp mysql-type-datetime
1936                                                                                                mysql-type-date mysql-type-time
1937                                                                                                mysql-type-newdate mysql-type-year)])
1938                (lambda (fldptr)
1939                        (apply mysql-field-type-any? fldptr numtypes) ) ) )
1940
1941;; note - not the same as the "IS_NUM" macro.
1942
1943(define mysql-field-type-number?
1944        (let ([numtypes (list mysql-type-decimal mysql-type-tiny mysql-type-short
1945                                                                                                mysql-type-long mysql-type-float mysql-type-double
1946                                                                                                mysql-type-longlong mysql-type-newdecimal
1947                                                                                                mysql-type-bit)])
1948                (lambda (fldptr)
1949                        (apply mysql-field-type-any? fldptr numtypes) ) ) )
1950
1951;;
1952
1953(define mysql-field-type-blob?
1954        (let ([blobtypes (list mysql-type-tiny-blob mysql-type-medium-blob
1955                                                                                                 mysql-type-long-blob mysql-type-blob)])
1956                (lambda (fldptr)
1957                        (apply mysql-field-type-any? fldptr blobtypes) ) ) )
1958
1959;;
1960
1961(define mysql-field-type-string?
1962        (let ([numtypes (list mysql-type-varchar mysql-type-var-string
1963                                                                                                mysql-type-string
1964                                                                                                mysql-type-enum mysql-type-set)])
1965                (lambda (fldptr)
1966                        (apply mysql-field-type-any? fldptr numtypes) ) ) )
1967
1968;;
1969;; note - the same as the "IS_NUM" macro.
1970
1971(define mysql-field-type-magnitude?
1972        (let ([magtypes (list mysql-type-timestamp mysql-type-year mysql-type-null)])
1973                (lambda (fldptr)
1974                        (or (mysql-field-type-number? fldptr)
1975                                        (apply mysql-field-type-any? fldptr magtypes) ) ) ) )
1976
1977;;
1978
1979(define (mysql-field-type-binary? fldptr)
1980        (and (mysql-field-binary? fldptr)
1981                         (or (mysql-field-type-blob? fldptr)
1982                                         (mysql-field-type-string? fldptr) ) ) )
1983
1984;;
1985
1986(define (mysql-field-type-text? fldptr)
1987        (and (not (mysql-field-binary? fldptr))
1988                         (or (mysql-field-type-blob? fldptr)
1989                                         (mysql-field-type-string? fldptr) ) ) )
1990
1991;-----------------------------------------------------------------------
1992; The MySQL Field structure multi-slot API.
1993;
1994
1995;; Returns a list of field items.
1996
1997(define (mysql-field-slots fldptr . getters)
1998        (and fldptr
1999                         (map (cut <> fldptr) getters) ) )
2000
2001;; Returns a list of field items for nth field.
2002
2003(define (mysql-fetch-field-slots-direct conn nth . getters)
2004        (apply mysql-field-slots (mysql-fetch-field-direct conn nth) getters) )
2005
2006;; Returns a field item for nth field.
2007
2008(define (mysql-fetch-field-slot-direct conn nth getter)
2009        (and-let* ([lst (mysql-field-slots (mysql-fetch-field-direct conn nth) getter)])
2010                (car lst) ) )
2011
2012;; Returns a list of field items for the next field.
2013
2014(define (mysql-fetch-field-slots conn . getters)
2015        (apply mysql-field-slots (mysql-fetch-field conn) getters) )
2016
2017;; Returns a field item for the next field.
2018
2019(define (mysql-fetch-field-slot conn getter)
2020        (and-let* ([lst (mysql-field-slots (mysql-fetch-field conn) getter)])
2021                (car lst) ) )
2022
2023;; Returns a field pointer or #f.
2024
2025(define (mysql-fetch-field-specific conn field)
2026        (and-let* ([resptr (mysql-connection-result conn)]
2027                                                 [fldidx (mysql-get-field-index resptr field (foreign-mysql-num-fields resptr))])
2028                (foreign-mysql-fetch-field-direct resptr fldidx) ) )
2029
2030#|
2031;=======================================================================
2032; The MYSQL_TIME API.
2033;
2034
2035(declare
2036        (export
2037                ;; enum enum_mysql_timestamp_type
2038                mysql-timestamp-date
2039                mysql-timestamp-datetime
2040                mysql-timestamp-error
2041                mysql-timestamp-none
2042                mysql-timestamp-time
2043                ;
2044                mysql-timestamp-type-symbol
2045                mysql-timestamp-type-value
2046                ;; MYSQL_TIME
2047                mysql-time-day-set!
2048                mysql-time-hour-set!
2049                mysql-time-minute-set!
2050                mysql-time-month-set!
2051                mysql-time-neg-set!
2052                mysql-time-second-part-set!
2053                mysql-time-second-set!
2054                mysql-time-time-type-set!
2055                mysql-time-year-set!
2056                ;
2057                mysql-time-day
2058                mysql-time-hour
2059                mysql-time-minute
2060                mysql-time-month
2061                mysql-time-neg
2062                mysql-time-second
2063                mysql-time-second-part
2064                mysql-time-time-type
2065                mysql-time-year
2066                ;
2067                make-mysql-time
2068                allocate-mysql-time
2069                free-mysql-time ) )
2070
2071;;
2072
2073(define-foreign-type mysql-time-ptr (c-pointer "MYSQL_TIME"))
2074
2075;;
2076
2077($define-foreign-enum (mysql-timestamp-type (enum "enum_mysql_timestamp_type"))
2078        #f      ; No aliases!
2079        MYSQL_TIMESTAMP_NONE
2080        MYSQL_TIMESTAMP_ERROR
2081        MYSQL_TIMESTAMP_DATE
2082        MYSQL_TIMESTAMP_DATETIME
2083        MYSQL_TIMESTAMP_TIME )
2084
2085;;
2086
2087(define-foreign-record (mysql-time "MYSQL_TIME")
2088        (rename: c-name->scheme-name)
2089        (constructor: allocate-mysql-time)
2090        (destructor: free-mysql-time)
2091        (unsigned-int year)
2092        (unsigned-int month)
2093        (unsigned-int day)
2094        (unsigned-int hour)
2095        (unsigned-int minute)
2096        (unsigned-int second)
2097        (unsigned-long second_part)
2098        (my-bool neg)
2099        (mysql-timestamp-type time_type) )
2100
2101;;
2102
2103(define (make-mysql-time type #!key (year 0) (month 0) (day 0)
2104                                                                                                                                                (hour 0) (minute 0) (second 0)
2105                                                                                                                                                (second-part 0)
2106                                                                                                                                                is-negative)
2107        (let ([timptr (allocate-mysql-time)])
2108                (mysql-time-time-type-set! timptr type)
2109                (mysql-time-year-set! timptr year)
2110                (mysql-time-month-set! timptr month)
2111                (mysql-time-day-set! timptr day)
2112                (mysql-time-hour-set! timptr hour)
2113                (mysql-time-minute-set! timptr minute)
2114                (mysql-time-second-set! timptr second)
2115                (mysql-time-second-part-set! timptr second-part)
2116                (mysql-time-neg-set! timptr is-negative)
2117                (set-finalizer! timptr free-mysql-time)
2118                timptr ) )
2119
2120;; #(seconds minutes hours mday month year wday yday dstflag timezone)
2121
2122(define (mysql-time->time-vector timptr)
2123  (let ([timvec (make-vector 10 #f)])
2124    (cond [(or (eq? mysql-timestamp-datetime (mysql-timestamp-type timptr))
2125               (eq? mysql-timestamp-time (mysql-timestamp-type timptr)))
2126            (vector-set! timvec 0 (mysql-time-second timptr))
2127            (vector-set! timvec 1 (mysql-time-minute timptr))
2128            (vector-set! timvec 2 (mysql-time-hour timptr))]
2129          [else
2130            (vector-set! timvec 0 #f)
2131            (vector-set! timvec 1 #f)
2132            (vector-set! timvec 2 #f)])
2133    (cond [(or (eq? mysql-timestamp-datetime (mysql-timestamp-type timptr))
2134               (eq? mysql-timestamp-date (mysql-timestamp-type timptr)))
2135            (vector-set! timvec 3 (mysql-time-day timptr))
2136            (vector-set! timvec 4 (mysql-time-month timptr))
2137            (vector-set! timvec 5 (mysql-time-year timptr))]
2138          [else
2139            (vector-set! timvec 3 #f)
2140            (vector-set! timvec 4 #f)
2141            (vector-set! timvec 5 #f)])
2142    (vector-set! timvec 6 #f)
2143    (vector-set! timvec 7 #f)
2144    (vector-set! timvec 8 #f)
2145    (vector-set! timvec 9 #f)
2146    timvec ) )
2147
2148;; #(seconds minutes hours mday month year wday yday dstflag timezone)
2149
2150(define (time-vector->mysql-time timvec #!optional (timtyp mysql-timestamp-datetime))
2151  (let ([timptr (make-mysql-time timtyp)])
2152    (mysql-time-second-set! timptr (vector-ref timvec 0))
2153    (mysql-time-minute-set! timptr (vector-ref timvec 1))
2154    (mysql-time-hour-set! timptr (vector-ref timvec 2))
2155    (mysql-time-day-set! timptr (vector-ref timvec 3))
2156    (mysql-time-month-set! timptr (vector-ref timvec 4))
2157    (mysql-time-year-set! timptr (vector-ref timvec 5))
2158    (mysql-timestamp-type-set! timptr timtyp)
2159    timptr ) )
2160
2161;=======================================================================
2162; The MySQL prepared statement API.
2163;
2164
2165(declare
2166        (bound-to-procedure
2167                mysql-stmt-errno
2168                mysql-stmt-error
2169                mysql-stmt-sqlstate )
2170        (export
2171                ;;
2172                stmt-attr-cursor-type
2173                stmt-attr-prefetch-rows
2174                stmt-attr-update-max-length
2175                ;
2176                mysql-stmt-attr-type-symbol
2177                mysql-stmt-attr-type-value
2178                ;;
2179                mysql-stmt-init-done
2180                mysql-stmt-execute-done
2181                mysql-stmt-prepare-done
2182                mysql-stmt-fetch-done
2183                ;
2184                mysql-stmt-state-symbol
2185                mysql-stmt-state-value
2186                ;;
2187                mysql-no-data
2188                mysql-data-truncated
2189                ;
2190                mysql-status-return-code-symbol
2191                mysql-status-return-code-value
2192                ;;
2193                foreign-mysql-stmt-affected-rows
2194                foreign-mysql-stmt-attr-get
2195                foreign-mysql-stmt-attr-set
2196                foreign-mysql-stmt-bind-param
2197                foreign-mysql-stmt-bind-result
2198                foreign-mysql-stmt-close
2199                foreign-mysql-stmt-data-seek
2200                foreign-mysql-stmt-errno
2201                foreign-mysql-stmt-error
2202                foreign-mysql-stmt-execute
2203                foreign-mysql-stmt-fetch
2204                foreign-mysql-stmt-fetch-column
2205                foreign-mysql-stmt-field-count
2206                foreign-mysql-stmt-free-result
2207                foreign-mysql-stmt-init
2208                foreign-mysql-stmt-insert-id
2209                foreign-mysql-stmt-num-rows
2210                foreign-mysql-stmt-param-count
2211                foreign-mysql-stmt-param-metadata
2212                foreign-mysql-stmt-prepare
2213                foreign-mysql-stmt-reset
2214                foreign-mysql-stmt-result-metadata
2215                foreign-mysql-stmt-row-seek
2216                foreign-mysql-stmt-row-tell
2217                foreign-mysql-stmt-send-long-data
2218                foreign-mysql-stmt-sqlstate
2219                foreign-mysql-stmt-store-result
2220                ;; basic
2221                mysql-stmt-errno
2222                mysql-stmt-error
2223                mysql-stmt-sqlstate
2224                mysql-stmt-init ; custom
2225                mysql-stmt-close ; called by custom mysql-stmt-init
2226                mysql-stmt-prepare
2227                mysql-stmt-param-count
2228                mysql-stmt-bind-param
2229                mysql-stmt-execute
2230                mysql-stmt-affected-rows
2231                mysql-stmt-bind-result
2232                mysql-stmt-fetch
2233                mysql-stmt-store-result
2234                mysql-stmt-result-metadata
2235                mysql-stmt-attr-set
2236                mysql-stmt-attr-get
2237                ;; extended
2238                mysql-stmt-rewind
2239                mysql-stmt-row-fetch
2240                mysql-stmt-query
2241                ;; mapping
2242                mysql-stmt-row-fold
2243                mysql-stmt-row-for-each
2244                mysql-stmt-row-map
2245                mysql-stmt-query-fold
2246                mysql-stmt-query-for-each
2247                mysql-stmt-query-map
2248                ;; MYSQL_BIND
2249                allocate-mysql-bind
2250                free-mysql-bind
2251                mysql-bind-ref-ptr
2252                mysql-bind-clear!
2253                mysql-bind-param-init-direct
2254                mysql-bind-result-init-direct
2255                mysql-bind-param-init
2256                mysql-bind-result-init
2257                ;
2258                mysql-bind-buffer-set!
2259                mysql-bind-buffer-length-set!
2260                mysql-bind-buffer-type-set!
2261                mysql-bind-error-set!
2262                mysql-bind-error-value-set!
2263                mysql-bind-is-null-set!
2264                mysql-bind-is-null-value-set!
2265                mysql-bind-is-unsigned-set!
2266                mysql-bind-length-set!
2267                ;
2268                mysql-bind-buffer
2269                mysql-bind-buffer-length
2270                mysql-bind-buffer-type
2271                mysql-bind-error
2272                mysql-bind-error-value
2273                mysql-bind-is-null
2274                mysql-bind-is-null-value
2275                mysql-bind-is-unsigned
2276                mysql-bind-length ) )
2277
2278;;
2279
2280(define-foreign-type mysql-row-offset mysql-rows-ptr)
2281
2282(define-foreign-type mysql-bind-ptr (c-pointer "MYSQL_BIND"))
2283
2284(define-foreign-type mysql-stmt-ptr (c-pointer "MYSQL_STMT"))
2285
2286(define-foreign-type mysql-my-bool-ptr (c-pointer "my_bool"))
2287
2288(define-foreign-type mysql-ulong-ptr (c-pointer "unsigned long"))
2289
2290;;
2291
2292($define-foreign-enum (mysql-stmt-state (enum "enum_mysql_stmt_state"))
2293        #f      ; No aliases!
2294        MYSQL_STMT_INIT_DONE
2295        MYSQL_STMT_PREPARE_DONE
2296        MYSQL_STMT_EXECUTE_DONE
2297        MYSQL_STMT_FETCH_DONE )
2298
2299($define-foreign-enum (mysql-stmt-attr-type (enum "enum_stmt_attr_type"))
2300        #f      ; No aliases!
2301        STMT_ATTR_UPDATE_MAX_LENGTH
2302        STMT_ATTR_CURSOR_TYPE
2303        STMT_ATTR_PREFETCH_ROWS )
2304
2305($define-foreign-enum (mysql-status-return-code unsigned-int)
2306        #f      ; No aliases!
2307        MYSQL_NO_DATA
2308        MYSQL_DATA_TRUNCATED )
2309
2310;;
2311
2312;MYSQL_STMT *mysql_stmt_init(MYSQL *mysql)
2313(define foreign-mysql-stmt-init
2314        (foreign-lambda mysql-stmt-ptr "mysql_stmt_init" mysql-ptr))
2315
2316;my_bool mysql_stmt_close(MYSQL_STMT *mysql)
2317(define foreign-mysql-stmt-close
2318        (foreign-lambda my-bool "mysql_stmt_close" mysql-stmt-ptr))
2319
2320;my_bool mysql_stmt_bind_param(MYSQL_STMT *stmt, MYSQL_BIND *bind)
2321(define foreign-mysql-stmt-bind-param
2322        (foreign-lambda my-bool "mysql_stmt_bind_param" mysql-stmt-ptr mysql-bind-ptr))
2323
2324;my_bool mysql_stmt_bind_result(MYSQL_STMT *stmt, MYSQL_BIND *bind)
2325(define foreign-mysql-stmt-bind-result
2326        (foreign-lambda my-bool "mysql_stmt_bind_result" mysql-stmt-ptr mysql-bind-ptr))
2327
2328;int mysql_stmt_execute(MYSQL_STMT *stmt)
2329(define foreign-mysql-stmt-execute
2330        (foreign-lambda int "mysql_stmt_execute" mysql-stmt-ptr))
2331
2332;int mysql_stmt_fetch(MYSQL_STMT *stmt)
2333(define foreign-mysql-stmt-fetch
2334        (foreign-lambda int "mysql_stmt_fetch" mysql-stmt-ptr))
2335
2336;int mysql_stmt_prepare(MYSQL_STMT *stmt, const char *query, unsigned long length)
2337(define foreign-mysql-stmt-prepare
2338        (foreign-lambda int "mysql_stmt_prepare" mysql-stmt-ptr c-string unsigned-long))
2339
2340;int mysql_stmt_fetch_column(MYSQL_STMT *stmt, MYSQL_BIND *bind_arg, unsigned int column, unsigned long offset)
2341(define foreign-mysql-stmt-fetch-column
2342        (foreign-lambda int "mysql_stmt_fetch_column" mysql-stmt-ptr mysql-bind-ptr unsigned-int unsigned-long))
2343
2344;int mysql_stmt_store_result(MYSQL_STMT *stmt)
2345(define foreign-mysql-stmt-store-result
2346        (foreign-lambda int "mysql_stmt_store_result" mysql-stmt-ptr))
2347
2348;unsigned long mysql_stmt_param_count(MYSQL_STMT * stmt)
2349(define foreign-mysql-stmt-param-count
2350        (foreign-lambda unsigned-long "mysql_stmt_param_count" mysql-stmt-ptr))
2351
2352;my_bool mysql_stmt_attr_set(MYSQL_STMT *stmt, enum enum_stmt_attr_type attr_type, const void *attr)
2353(define foreign-mysql-stmt-attr-set
2354        (foreign-lambda my-bool "mysql_stmt_attr_set" mysql-stmt-ptr mysql-stmt-attr-type c-pointer))
2355
2356;my_bool mysql_stmt_attr_get(MYSQL_STMT *stmt, enum enum_stmt_attr_type attr_type, void *attr)
2357(define foreign-mysql-stmt-attr-get
2358        (foreign-lambda my-bool "mysql_stmt_attr_get" mysql-stmt-ptr mysql-stmt-attr-type c-pointer))
2359
2360(define foreign-mysqlaux-stmt-attr-set-bool
2361        (foreign-lambda* my-bool ((mysql-stmt-ptr stmt) (mysql-stmt-attr-type attrr) (my-bool value))
2362   "return( mysql_stmt_attr_set( stmt, attr, &value ) );"))
2363
2364(define foreign-mysqlaux-stmt-attr-set-ulong
2365        (foreign-lambda* my-bool ((mysql-stmt-ptr stmt) (mysql-stmt-attr-type attrr) (unsigned-long value))
2366   "return( mysql_stmt_attr_set( stmt, attr, &value ) );"))
2367
2368;my_bool mysql_stmt_reset(MYSQL_STMT * stmt)
2369(define foreign-mysql-stmt-reset
2370        (foreign-lambda my-bool "mysql_stmt_reset" mysql-stmt-ptr))
2371
2372;my_bool mysql_stmt_free_result(MYSQL_STMT *stmt)
2373(define foreign-mysql-stmt-free-result
2374        (foreign-lambda my-bool "mysql_stmt_free_result" mysql-stmt-ptr))
2375
2376;my_bool mysql_stmt_send_long_data(MYSQL_STMT *stmt, unsigned-int param_number, const char *data, unsigned long length)
2377(define foreign-mysql-stmt-send-long-data
2378        (foreign-lambda my-bool "mysql_stmt_send_long_data" mysql-stmt-ptr unsigned-int c-pointer unsigned-long))
2379
2380;MYSQL_RES *mysql_stmt_result_metadata(MYSQL_STMT *stmt)
2381(define foreign-mysql-stmt-result-metadata
2382        (foreign-lambda mysql-res-ptr "mysql_stmt_result_metadata" mysql-stmt-ptr))
2383
2384;MYSQL_RES *mysql_stmt_param_metadata(MYSQL_STMT *stmt)
2385(define foreign-mysql-stmt-param-metadata
2386        (foreign-lambda mysql-res-ptr "mysql_stmt_param_metadata" mysql-stmt-ptr))
2387
2388;unsigned int mysql_stmt_errno(MYSQL_STMT * stmt)
2389(define foreign-mysql-stmt-errno
2390        (foreign-lambda unsigned-int "mysql_stmt_errno" mysql-stmt-ptr))
2391
2392;const char *mysql_stmt_error(MYSQL_STMT * stmt)
2393(define foreign-mysql-stmt-error
2394        (foreign-lambda c-string "mysql_stmt_error" mysql-stmt-ptr))
2395
2396;const char *mysql_stmt_sqlstate(MYSQL_STMT * stmt)
2397(define foreign-mysql-stmt-sqlstate
2398        (foreign-lambda c-string "mysql_stmt_sqlstate" mysql-stmt-ptr))
2399
2400;MYSQL_ROW_OFFSET mysql_stmt_row_seek(MYSQL_STMT *stmt, MYSQL_ROW_OFFSET offset)
2401(define foreign-mysql-stmt-row-seek
2402        (foreign-lambda mysql-row-offset "mysql_stmt_row_seek" mysql-stmt-ptr mysql-row-offset))
2403
2404;MYSQL_ROW_OFFSET mysql_stmt_row_tell(MYSQL_STMT *stmt)
2405(define foreign-mysql-stmt-row-tell
2406        (foreign-lambda mysql-row-offset "mysql_stmt_row_tell" mysql-stmt-ptr))
2407
2408;void mysql_stmt_data_seek(MYSQL_STMT *stmt, my_ulonglong offset)
2409(define foreign-mysql-stmt-data-seek
2410        (foreign-lambda* void ((mysql-stmt-ptr stmt) (my-ulonglong offset))
2411   "mysql_stmt_data_seek( stmt, offset );"))
2412
2413;my_ulonglong mysql_stmt_num_rows(MYSQL_STMT *stmt)
2414(define foreign-mysql-stmt-num-rows
2415        (foreign-lambda* my-ulonglong ((mysql-stmt-ptr stmt))
2416   "return( (double) mysql_stmt_num_rows( stmt ) );"))
2417
2418;my_ulonglong mysql_stmt_affected_rows(MYSQL_STMT *stmt)
2419(define foreign-mysql-stmt-affected-rows
2420        (foreign-lambda* my-ulonglong ((mysql-stmt-ptr stmt))
2421   "return( (double) mysql_stmt_affected_rows( stmt ) );"))
2422
2423;my_ulonglong mysql_stmt_insert_id(MYSQL_STMT *stmt)
2424(define foreign-mysql-stmt-insert-id
2425        (foreign-lambda* my-ulonglong ((mysql-stmt-ptr stmt))
2426   "return( (double) mysql_stmt_insert_id( stmt ) );"))
2427
2428;unsigned int mysql_stmt_field_count(MYSQL_STMT *stmt)
2429(define foreign-mysql-stmt-field-count
2430        (foreign-lambda unsigned-int "mysql_stmt_field_count" mysql-stmt-ptr))
2431
2432;; MYSQL_BIND
2433
2434(define-foreign-record (mysql-bind "MYSQL_BIND")
2435        (rename: c-name->scheme-name)
2436        ; special ctor
2437        (destructor: free-mysql-bind)
2438        ((c-pointer "unsigned long") length)            ; output length pointer
2439        ((c-pointer "my_bool") is_null)                                 ; Pointer to null indicator
2440        (c-pointer buffer)                                                                                      ; buffer to get/put data
2441        ((c-pointer "my_bool") error)                                           ; set this if you want to track data truncations happened during fetch
2442        (unsigned-long buffer_length)                                           ; output buffer length, must be set when fetching str/binary
2443        (mysql-type buffer_type)                                                                ; buffer type
2444        (my-bool is_unsigned)                                                                           ; set if integer type is unsigned
2445        ; ???
2446        (my-bool error_value)                                                                           ; used if error is 0
2447        (my-bool is_null_value) )                                                               ; Used if is_null is 0
2448
2449;; Returns a C-vector of MYSQL_BIND
2450;; Count must be at least 1!
2451
2452(define (allocate-mysql-bind #!optional (cnt 1))
2453  (and (fx<= 1 cnt)
2454       (allocate (fx* cnt (foreign-value "sizeof( MYSQL_BIND )" int))) ) )
2455
2456;;
2457
2458(define (make-mysql-bind #!optional (cnt 1))
2459  (and-let* ([binds (allocate-mysql-bind cnt)])
2460    (set-finalizer! binds free-mysql-bind)
2461    binds ) )
2462
2463;; Returns c-pointer to MYSQL_BIND at index in a C-vector of MYSQL_BIND
2464;; No range checks!
2465
2466(define (mysql-bind-ref-ptr bndptr idx)
2467        ((foreign-lambda* mysql-bind-ptr ((mysql-bind-ptr ptr) (unsigned-integer idx))
2468         "return( &(ptr[ idx ]) );")
2469         bndptr idx) )
2470
2471;; Zeros MYSQL_BIND
2472
2473(define (mysql-bind-clear! bndptr #!optional (idx 0) (cnt 1))
2474        ((foreign-lambda* void ((mysql-bind-ptr ptr) (unsigned-integer idx) (unsigned-integer cnt))
2475         "memset( &(ptr[ idx ]), 0, sizeof( MYSQL_BIND ) * cnt );")
2476         bndptr idx cnt) )
2477
2478;; Sets a MYSQL_BIND variable pointers
2479
2480(define (mysql-bind-variables-set! bndptr nulptr errptr lenptr bufptr)
2481  ((foreign-lambda* void ((mysql-bind-ptr pbnd)
2482                          (mysql-my-bool-ptr pnul)
2483                          (mysql-my-bool-ptr perr)
2484                          (mysql-ulong-ptr plen)
2485                          (c-pointer pbuf))
2486#<<EOS
2487  pbnd->buffer_length = *plen; /* Do anyway, even for results */
2488  pbnd->buffer = pbuf
2489  pbnd->is_null = pnul;
2490  pbnd->length = plen;
2491  pbnd->error = perr;
2492EOS
2493   )
2494   bndptr nulptr errptr lenptr bufptr) )
2495
2496;; Returns a C-vector of my_bool
2497;; Count must be at least 1!
2498
2499(define (allocate-mysql-my-bool #!optional (cnt 1))
2500  (and (<= 1 cnt)
2501       (allocate (* cnt (foreign-value "sizeof( my_bool )" int))) ) )
2502
2503;; Returns boolptr at index in a C-vector of my_bool
2504;; No range checks!
2505
2506(define (mysql-my-bool-ref-ptr myboolptr idx)
2507        ((foreign-lambda* mysql-my-bool-ptr ((mysql-my-bool-ptr ptr) (unsigned-integer idx))
2508         "return( &(ptr[ idx ]) );")
2509         myboolptr idx) )
2510
2511;; Returns bool at index in a C-vector of my_bool
2512;; No range checks!
2513
2514(define (mysql-my-bool-ref myboolptr idx)
2515        ((foreign-lambda* my-bool ((mysql-my-bool-ptr ptr) (unsigned-integer idx))
2516         "return( ptr[ idx ] );")
2517         myboolptr idx) )
2518
2519;; Sets bool at index in a C-vector of my_bool
2520;; No range checks!
2521
2522(define (mysql-my-bool-set! myboolptr idx val)
2523        ((foreign-lambda* my-bool ((mysql-my-bool-ptr ptr) (unsigned-integer idx) (my-bool val))
2524         "ptr[ idx ] = val;")
2525         myboolptr idx val) )
2526
2527;; Zeros my-bool
2528
2529(define (mysql-my-bool-clear! myboolptr #!optional (idx 0) (cnt 1))
2530        ((foreign-lambda* void ((mysql-my-bool-ptr ptr) (unsigned-integer idx))
2531         "memset( &(ptr[ idx ]), 0, sizeof( my_bool ) * cnt );")
2532         myboolptr idx) )
2533
2534;; Returns a C-vector of ulong
2535;; Count must be at least 1!
2536
2537(define (allocate-mysql-ulong #!optional (cnt 1))
2538  (and (<= 1 cnt)
2539       (allocate (* cnt (foreign-value "sizeof( unsigned long )" int))) ) )
2540
2541;; Returns boolptr at index in a C-vector of my_bool
2542;; No range checks!
2543
2544(define (mysql-ulong-ref-ptr ulongptr idx)
2545        ((foreign-lambda* mysql-ulong-ptr ((mysql-ulong-ptr ptr) (unsigned-integer idx))
2546         "return( &(ptr[ idx ]) );")
2547         ulongptr idx) )
2548
2549;; Returns ulong at index in a C-vector of ulong
2550;; No range checks!
2551
2552(define (mysql-ulong-ref ulongptr idx)
2553        ((foreign-lambda* unsigned-long ((mysql-ulong-ptr ptr) (unsigned-integer idx))
2554         "return( ptr[ idx ] );")
2555         ulongptr idx) )
2556
2557;; Sets ulong at index in a C-vector of ulong
2558;; No range checks!
2559
2560(define (mysql-ulong-set! ulongptr idx val)
2561        ((foreign-lambda* my-bool ((mysql-ulongptr-ptr ptr) (unsigned-integer idx) (unsigned-long val))
2562         "ptr[ idx ] = val;")
2563         ulongptr idx val) )
2564
2565;; Zeros ulong
2566
2567(define (mysql-ulong-clear! ulongptr #!optional (idx 0) (cnt 1))
2568        ((foreign-lambda* void ((mysql-ulong-ptr ptr) (unsigned-integer idx) (unsigned-integer cnt))
2569         "memset( &(ptr[ idx ]), 0, sizeof( unsigned long ) * cnt );")
2570         ulongptr idx cnt) )
2571
2572;; Returns pointer @ ptr + off
2573
2574(define (mysql-char-ref-ptr ptr off)
2575        ((foreign-lambda* c-pointer ((c-pointer ptr) (unsigned-integer off))
2576         "return( &(((char *) ptr)[ off ]) );")
2577         ptr off) )
2578
2579;;
2580
2581(define-inline (*clear-memory! ptr len)
2582        (when (and ptr (not (fx= 0 len)))
2583          ((foreign-lambda* void ((c-pointer ptr) (unsigned-integer len))
2584     "memset( ptr, 0, len );")
2585     ptr len) ) )
2586
2587;;
2588
2589(define-inline (*allocate len)
2590  (and (not (fx= 0 len))
2591       (allocate len) ) )
2592
2593;;
2594
2595(define-inline (*free ptr)
2596  (when ptr (free ptr) ) )
2597
2598;; Record holds binding storage pointers
2599
2600(define-record-type mysql-binding
2601  (%make-mysql-binding cnt bnds nuls errs lens bufs)
2602  mysql-binding?
2603  (cnt    mysql-binding-count       #;mysql-binding-counts-set!)
2604  (bnds   mysql-binding-binds       #;mysql-binding-binds-set!)
2605  (nuls   mysql-binding-is-nulls    #;mysql-binding-is-nulls-set!)
2606  (errs   mysql-binding-errors      #;mysql-binding-errors-set!)
2607  (lens   mysql-binding-lengths     #;mysql-binding-lengths-set!)
2608  (bufs   mysql-binding-buffers     #;mysql-binding-buffers-set!) )
2609
2610;; Free all variable storage
2611
2612(define (free-mysql-binding-variables bindings)
2613  (when bindings
2614    (*free (mysql-binding-binds bindings))
2615    (*free (mysql-binding-is-nulls bindings))
2616    (*free (mysql-binding-errors bindings))
2617    (*free (mysql-binding-lengths bindings))
2618    (*free (mysql-binding-buffers bindings)) ) )
2619
2620;; Allocates zero'ed storage for binding
2621;; Returns mysql-binding instance or #f
2622;; When fldcnt is 0 no allocation performed
2623;; When buftot is 0 no buffer allocation performed
2624
2625(define (make-mysql-binding-direct fldcnt #!optional (buftot 0))
2626  (and (fx> 0 fldcnt)
2627       ;FIXME should signal out of memory
2628       (let ([bnds (allocate-mysql-bind fldcnt)]
2629             [nuls (allocate-mysql-my-bool fldcnt)]
2630             [errs (allocate-mysql-my-bool fldcnt)]
2631             [lens (allocate-mysql-ulong fldcnt)]
2632             [bufs (*allocate buftot)])
2633         (mysql-bind-clear! bnds 0 fldcnt)
2634         (mysql-my-bool-clear! nuls 0 fldcnt)
2635         (mysql-my-bool-clear! errs 0 fldcnt)
2636         (mysql-ulong-clear! lens 0 fldcnt)
2637         (*clear-memory! bufs buftot)
2638         (let ([bindings (%make-mysql-binding fldcnt bnds nuls errs lens bufs)])
2639           #;(set-finalizer! bindings free-mysql-binding-variables)
2640           bindings ) ) ) )
2641
2642;; Returns the cummulative buffer length upto the supplied index
2643
2644(define (mysql-binding-buffer-offset idx lens)
2645  (do ([i 0 (fx+ i 1)]
2646       [off 0 (fx+ off (mysql-ulong-ref lens i))])
2647      [(fx= i idx) off]) )
2648
2649;; Sets the MYSQL_BIND variable pointers for the binding @ index
2650;; idx  : which binding
2651
2652(define (mysql-binding-direct-set! idx bnds nuls errs lens bufs)
2653  (mysql-bind-variables-set!
2654   (mysql-bind-ref-ptr bnds idx)
2655   (mysql-my-bool-ref-ptr nuls idx)
2656   (mysql-my-bool-ref-ptr errs idx)
2657   (mysql-ulong-ref-ptr lens idx)
2658   (and bufs
2659        (mysql-char-ref-ptr bufs (mysql-binding-buffer-offset idx lens)))) )
2660
2661;; Returns mysql-binding instance with allocated variables
2662;; lendef : list of buffer lengths or field count
2663;; When lendef is a count no buffer allocation is performed
2664
2665(define (make-mysql-binding lendef)
2666  (if (number? lendef)
2667    (make-mysql-binding-direct lendef 0)
2668    (let ([fldcnt (length lendef)]
2669          [buftot (fold + 0 lendef)])
2670      (let ([bindings (make-mysql-binding-direct fldcnt buftot)])
2671        (let ([bnds (mysql-binding-binds bindings)]
2672              [nuls (mysql-binding-is-nulls bindings)]
2673              [errs (mysql-binding-errors bindings)]
2674              [lens (mysql-binding-lengths bindings)]
2675              [bufs (mysql-binding-buffers bindings)])
2676          (do ([idx 0 (fx+ idx 1)]
2677               [lst lendef (cdr lst)])
2678              [(fx= fldcnt idx) bindings]
2679            (mysql-binding-direct-set! idx bnds nuls errs lens bufs)
2680            (mysql-ulong-set! lens idx (car lst))) ) ) ) ) )
2681
2682;;;; TODO
2683;
2684; - MySQL Type
2685;
2686;   - mysql-type-* & optional length
2687;
2688; - Parameters
2689;
2690;   - build 'mysql-binding' for a given set of Scheme objects
2691;   - need 'mysql-type'
2692;     - use asserted 'mysql-type', if any
2693;     - when "metadata" then can deduce 'mysql-type'
2694;     - otherwise deduce 'mysql-type' from Scheme type of Scheme object
2695;   - given 'mysql-type' & Scheme object can create C-type storage requirements
2696;
2697; - Results
2698;
2699;   - build 'mysql-binding' for a given set of 'mysql-type'
2700;   - need 'mysql-type'
2701;     - use asserted 'mysql-type', if any
2702;     - when "metadata" then can deduce 'mysql-type'
2703;     - otherwise deduce 'mysql-type' from Scheme type
2704;   - given 'mysql-type' & Scheme type can create C-type storage requirements
2705
2706;;
2707
2708>#
2709typedef union {
2710  MYSQL_TIME              t;
2711  char                    sc;
2712  unsigned char           uc;
2713  short int               ssi;
2714  unsigned short int      usi;
2715  int                     si;
2716  unsigned int            ui;
2717  long long int           slli;
2718  unsigned long long int  ulli;
2719  float                   f;
2720  double                  d;
2721  char                    cv[1];
2722} MYSQLAUX_BIND_VARIABLE_BUFFER;
2723
2724/* Setter */
2725
2726static void
2727set_bind_variable_t( MYSQLAUX_BIND_VARIABLE *var, MYSQL_TIME *val )
2728{
2729  var->buffer.t = val;
2730}
2731
2732static void
2733set_bind_variable_sc( MYSQLAUX_BIND_VARIABLE *var, int val )
2734{
2735  var->buffer.sc = val;
2736}
2737
2738static void
2739set_bind_variable_uc( MYSQLAUX_BIND_VARIABLE *var, unsigned int val )
2740{
2741  var->buffer.uc = val;
2742}
2743
2744static void
2745set_bind_variable_si( MYSQLAUX_BIND_VARIABLE *var, int val )
2746{
2747  var->buffer.ssi = val;
2748}
2749
2750static void
2751set_bind_variable_usi( MYSQLAUX_BIND_VARIABLE *var, unsigned int val )
2752{
2753  var->buffer.usi = val;
2754}
2755
2756static void
2757set_bind_variable_i( MYSQLAUX_BIND_VARIABLE *var, int val )
2758{
2759  var->buffer.si = val;
2760}
2761
2762static void
2763set_bind_variable_ui( MYSQLAUX_BIND_VARIABLE *var, unsigned int val )
2764{
2765  var->buffer.ui = val;
2766}
2767
2768static void
2769set_bind_variable_lli( MYSQLAUX_BIND_VARIABLE *var,  val )
2770{
2771  var->buffer.lli = val;
2772}
2773
2774static void
2775set_bind_variable_ulli( MYSQLAUX_BIND_VARIABLE *var, double val )
2776{
2777  var->buffer.ulli = val;
2778}
2779
2780static void
2781set_bind_variable_f( MYSQLAUX_BIND_VARIABLE *var, double val )
2782{
2783  var->buffer.f = val;
2784}
2785
2786static void
2787set_bind_variable_d( MYSQLAUX_BIND_VARIABLE *var, double val )
2788{
2789  var->buffer.d = val;
2790}
2791
2792static void
2793set_bind_variable_cv( MYSQLAUX_BIND_VARIABLE *var, char *cv )
2794{
2795  memcpy( var->buffer.cv, cv, var->length );
2796}
2797
2798/* Getter */
2799
2800static MYSQL_TIME *
2801get_bind_variable_t( MYSQLAUX_BIND_VARIABLE *var )
2802{
2803  return &(var->buffer.t);
2804}
2805
2806static int
2807get_bind_variable_sc( MYSQLAUX_BIND_VARIABLE *var )
2808{
2809  return var->buffer.sc;
2810}
2811
2812static unsigned int
2813get_bind_variable_uc( MYSQLAUX_BIND_VARIABLE *var )
2814{
2815  return var->buffer.uc;
2816}
2817
2818static int
2819get_bind_variable_ssi( MYSQLAUX_BIND_VARIABLE *var )
2820{
2821  return (int) var->buffer.ssi;
2822}
2823
2824static unsigned int
2825get_bind_variable_usi( MYSQLAUX_BIND_VARIABLE *var )
2826{
2827  return var->buffer.usi;
2828}
2829
2830static int
2831get_bind_variable_si( MYSQLAUX_BIND_VARIABLE *var )
2832{
2833  return (int) var->buffer.si;
2834}
2835
2836static unsigned int
2837get_bind_variable_ui( MYSQLAUX_BIND_VARIABLE *var )
2838{
2839  return var->buffer.ui;
2840}
2841
2842/*
2843  long long conversion does not preserve precision
2844  need to use Chicken Scheme bigint
2845*/
2846
2847static double
2848get_bind_variable_slli( MYSQLAUX_BIND_VARIABLE *var )
2849{
2850  return (int) var->buffer.slli;
2851}
2852
2853static double
2854get_bind_variable_ulli( MYSQLAUX_BIND_VARIABLE *var )
2855{
2856  return var->buffer.ulli;
2857}
2858
2859static double
2860get_bind_variable_f( MYSQLAUX_BIND_VARIABLE *var )
2861{
2862  return var->buffer.f;
2863}
2864
2865static double
2866get_bind_variable_d( MYSQLAUX_BIND_VARIABLE *var )
2867{
2868  return var->buffer.d;
2869}
2870
2871static char *
2872get_bind_variable_cv_ptr( MYSQLAUX_BIND_VARIABLE *var )
2873{
2874  return var->buffer.cv;
2875}
2876
2877static void
2878get_bind_variable_cv( MYSQLAUX_BIND_VARIABLE *var, char *buf )
2879{
2880  memcpy( buf, var->cv, var->length );
2881}
2882<#
2883
2884;;
2885
2886(define (mysqlaux-type-fixed-size typ)
2887  (select typ
2888                [(mysql-type-tiny)                              (foreign-value "sizeof( MYSQLAUX_BIND_VARIABLE_BUFFER.sc )" unsigned-int)]
2889                [(mysql-type-short)                             (foreign-value "sizeof( MYSQLAUX_BIND_VARIABLE_BUFFER.si )" unsigned-int)]
2890                [(mysql-type-long)                              (foreign-value "sizeof( MYSQLAUX_BIND_VARIABLE_BUFFER.i )" unsigned-int)]
2891                [(mysql-type-int24)                             (foreign-value "sizeof( MYSQLAUX_BIND_VARIABLE_BUFFER.i )" unsigned-int)]
2892                [(mysql-type-float)                             (foreign-value "sizeof( MYSQLAUX_BIND_VARIABLE_BUFFER.f )" unsigned-int)]
2893                [(mysql-type-double)              (foreign-value "sizeof( MYSQLAUX_BIND_VARIABLE_BUFFER.d )" unsigned-int)]
2894                [(mysql-type-null)                              0]
2895                [(mysql-type-timestamp)         (foreign-value "sizeof( MYSQLAUX_BIND_VARIABLE_BUFFER.t )" unsigned-int)]
2896                [(mysql-type-longlong)          (foreign-value "sizeof( MYSQLAUX_BIND_VARIABLE_BUFFER.lli )" unsigned-int)]
2897                [(mysql-type-date)                              (foreign-value "sizeof( MYSQLAUX_BIND_VARIABLE_BUFFER.t )" unsigned-int)]
2898                [(mysql-type-time)                              (foreign-value "sizeof( MYSQLAUX_BIND_VARIABLE_BUFFER.t )" unsigned-int)]
2899                [(mysql-type-datetime)          (foreign-value "sizeof( MYSQLAUX_BIND_VARIABLE_BUFFER.t )" unsigned-int)]
2900                [(mysql-type-newdate)                   (foreign-value "sizeof( MYSQLAUX_BIND_VARIABLE_BUFFER.t )" unsigned-int)]
2901                [(mysql-type-year)                              (foreign-value "sizeof( MYSQLAUX_BIND_VARIABLE_BUFFER.si )" unsigned-int)]
2902                [(mysql-type-bit)                                 (foreign-value "sizeof( MYSQLAUX_BIND_VARIABLE_BUFFER.cv )" unsigned-int)]
2903                [(mysql-type-decimal)             (foreign-value "sizeof( MYSQLAUX_BIND_VARIABLE_BUFFER.cv )" unsigned-int)]
2904                [(mysql-type-newdecimal)  (foreign-value "sizeof( MYSQLAUX_BIND_VARIABLE_BUFFER.cv )" unsigned-int)]
2905                [(mysql-type-enum)                              (foreign-value "sizeof( MYSQLAUX_BIND_VARIABLE_BUFFER.cv )" unsigned-int)]
2906                [(mysql-type-set)                                 (foreign-value "sizeof( MYSQLAUX_BIND_VARIABLE_BUFFER.??? )" unsigned-int)]
2907                [(mysql-type-tiny-blob)         (foreign-value "sizeof( MYSQLAUX_BIND_VARIABLE_BUFFER.cv )" unsigned-int)]
2908                [(mysql-type-medium-blob)       (foreign-value "sizeof( MYSQLAUX_BIND_VARIABLE_BUFFER.cv )" unsigned-int)]
2909                [(mysql-type-long-blob)         (foreign-value "sizeof( MYSQLAUX_BIND_VARIABLE_BUFFER.cv )" unsigned-int)]
2910                [(mysql-type-blob)                              (foreign-value "sizeof( MYSQLAUX_BIND_VARIABLE_BUFFER.cv )" unsigned-int)]
2911                [(mysql-type-varchar)                   (foreign-value "sizeof( MYSQLAUX_BIND_VARIABLE_BUFFER.cv )" unsigned-int)]
2912                [(mysql-type-var-string)        (foreign-value "sizeof( MYSQLAUX_BIND_VARIABLE_BUFFER.cv )" unsigned-int)]
2913                [(mysql-type-string)                    (foreign-value "sizeof( MYSQLAUX_BIND_VARIABLE_BUFFER.cv )" unsigned-int)]
2914                [(mysql-type-geometry)          (foreign-value "sizeof( MYSQLAUX_BIND_VARIABLE_BUFFER.cv )" unsigned-int)]
2915    [else
2916      (error ???)] ) )
2917
2918;; ???
2919
2920(define (mysql-foreign-type-length foreign-type #!optional (obj (void)))
2921 (void) )
2922
2923;; ???
2924
2925(define (mysql-determine-foreign-type type is-unsigned is-null)
2926 (void) )
2927
2928;; ???
2929
2930(define (mysql-determine-type obj is-unsigned is-null)
2931 (void) )
2932
2933;;
2934
2935(define (mysql-bind-param-init-direct conn idx obj #!key type is-unsigned is-null error)
2936  (let ([bndptr (mysql-bind-ref-ptr (mysql-connection-binding conn) idx)])
2937    (mysql-bind-clear! bndptr)
2938    (unless type
2939      (let-values ([(typ uflg nflg) (mysql-determine-type obj is-unsigned is-null)])
2940        (set! type typ)
2941        (set! is-unsigned uflg)
2942        (set! is-null nflg) ) )
2943    (when (and (mysql-null-object? obj) (not (eqv? mysql-type-null type)))
2944      (warning "null object implies null type")
2945      (set! type mysql-type-null) )
2946    (mysql-bind-buffer-type-set! bndptr type)
2947    (unless (eqv? mysql-type-null type)
2948      (mysql-bind-is-unsigned-set! bndptr is-unsigned)
2949      (let* ([foreign-type (mysql-determine-foreign-type type is-unsigned is-null)]
2950             [len (mysql-foreign-type-length foreign-type obj)])
2951        (add-bind-variable conn (mysql-bind-init bndptr len is-null)) ) ) ) )
2952
2953;;
2954
2955(define (mysql-bind-result-init-direct conn idx type #!optional len)
2956  (let ([bndptr (mysql-bind-ref-ptr (mysql-connection-binding conn) idx)])
2957    (mysql-bind-clear! bndptr)
2958    (mysql-bind-buffer-type-set! bndptr type)
2959    (unless (eqv? mysql-type-null type)
2960      (let* ([foreign-type (mysql-determine-foreign-type type #f #f)]
2961             [len (or len
2962                      (mysql-foreign-type-length foreign-type))])
2963        (add-bind-variable conn (mysql-bind-init bndptr len #f)) ) ) ) )
2964
2965;; Convert the result binding to a Scheme object of typedesc
2966;FIXME
2967
2968(define (mysql-bind-result->object bndptr typedesc)
2969        (void) )
2970
2971;;
2972
2973(define (mysql-bindings-reset conn)
2974  (free-mysql-binding-variables (mysql-connection-bindings conn))
2975  (mysql-connection-bindings-set! conn #f) )
2976
2977;; Set the statement attribute
2978
2979(define (%mysql-stmt-attr-set! stmtptr attr val)
2980        (cond [(boolean? val)
2981                                        (foreign-mysqlaux-stmt-attr-set-bool stmtptr attr val)]
2982                                [(number? val)
2983                                        (foreign-mysqlaux-stmt-attr-set-ulong stmtptr attr val)]
2984                                [else
2985                                        #t ] ) )
2986
2987;; Get the statement attribute
2988
2989(define (%mysql-stmt-attr-get stmtptr attr)
2990        (select attr
2991                [(stmt-attr-cursor-type stmt-attr-prefetch-rows)
2992                        (let-location ([val unsigned-long])
2993                                (foreign-mysql-stmt-attr-get stmtptr attr #$val)
2994                                val ) ]
2995                [(stmt-attr-update-max-length)
2996                        (let-location ([val my-bool])
2997                                (foreign-mysql-stmt-attr-get stmtptr attr #$val)
2998                                val ) ]
2999                [else
3000                        (void) ] ) )
3001
3002;; Is the object a NULL object?
3003;FIXME
3004
3005(define (mysql-null-object? obj)
3006        (eq? obj (void)) )
3007
3008;; Raise a statement expection
3009
3010(define (signal-mysql-stmt-error loc conn . args)
3011        (and-let* ([stmtptr (mysql-connection-statement conn)])
3012                (let ([err (or (mysql-stmt-error stmtptr)
3013                                                                         (mysql-stmt-errno stmtptr))]
3014                                        [sta (mysql-stmt-sqlstate conn)])
3015                        (apply signal-mysql-condition loc
3016                                                                                                                                                (string-append err
3017                                                                                                                                                                                                         (if sta
3018                                                                                                                                                                                                                         (string-append " - " sta)
3019                                                                                                                                                                                                                         ""))
3020                                                                                                                                                conn args) ) ) )
3021
3022;-----------------------------------------------------------------------
3023; The prepared statement binding MySQL/Scheme API.
3024;
3025; This API provides binding construction support.
3026;
3027
3028;;
3029;;       ((list obj #:type T #:length L #:unsigned B #:null B) ; param 0
3030;;               ...
3031;;               (list obj #:type T #:length L #:unsigned B #:null B))
3032
3033(define (make-mysql-param-bindings conn . inits)
3034)
3035
3036;;
3037;;              ((list obj #:type T #:length L) ; result 0
3038;;               ...
3039;;               (list obj #:type T #:length L))
3040
3041(define (make-mysql-result-bindings conn . inits)
3042  ; Result metadata available?
3043  ;
3044)
3045
3046;-----------------------------------------------------------------------
3047; The prepared statement MySQL/Scheme API.
3048;
3049; This API provides statement evaluation phase support.
3050;
3051
3052;; Frees statement storage
3053
3054(define (mysql-stmt-close conn)
3055        (and-let* ([stmtptr (mysql-connection-statement conn)])
3056                (mysql-connection-statement-set! conn #f)
3057                (when (foreign-mysql-stmt-close stmtptr)
3058                        (signal-mysql-stmt-error 'mysql-stmt-close conn) ) )
3059  (mysql-bindings-reset conn) )
3060
3061;; Creates statement storage
3062
3063(define (mysql-stmt-init conn)
3064        (mysql-stmt-close conn)
3065        (let ([stmtptr (foreign-mysql-stmt-init (mysql-connection-ptr conn))])
3066                (if stmtptr
3067                                (mysql-connection-statement-set! conn stmtptr)
3068                                (signal-mysql-condition 'mysql-stmt-init "out of memory") ) ) )
3069
3070;;
3071
3072(define (mysql-stmt-errno conn)
3073        (and-let* ([stmtptr (mysql-connection-statement conn)])
3074                (foreign-mysql-stmt-errno stmtptr) ) )
3075
3076;; Returns a string describing the last mysql stmt error, or #f if no error
3077;; has occurred.
3078
3079(define (mysql-stmt-error conn)
3080        (and-let* ([stmtptr (mysql-connection-statement conn)])
3081                (let ([errstr (foreign-mysql-stmt-error stmtptr)])
3082                        (and (not (string=? "" errstr))
3083                                         errstr ) ) ) )
3084
3085;; Returns a string describing the last mysql stmt state error, or #f if no error
3086;; has occurred.
3087
3088(define (mysql-stmt-sqlstate conn)
3089        (and-let* ([stmtptr (mysql-connection-statement conn)])
3090                (let ([errstr (foreign-mysql-stmt-sqlstate stmtptr)])
3091                        (and (not (or (string=? "00000" errstr)
3092                                                                                (string=? "HY000" errstr)))
3093                                         errstr ) ) ) )
3094
3095;;
3096
3097(define (mysql-stmt-prepare conn sql)
3098        (and-let* ([stmtptr (mysql-connection-statement conn)])
3099                (unless (fx= 0 (foreign-mysql-stmt-prepare stmtptr sql (string-length sql)))
3100                        (signal-mysql-stmt-error 'mysql-stmt-prepare conn) ) ) )
3101
3102;;
3103
3104(define (mysql-stmt-param-count conn)
3105        (and-let* ([stmtptr (mysql-connection-statement conn)])
3106                (foreign-mysql-stmt-param-count stmtptr) ) )
3107
3108;; Bind the fully defined parameter binding
3109
3110(define (mysql-stmt-bind-param-direct conn binding)
3111        (and-let* ([stmtptr (mysql-connection-statement conn)])
3112                (when (foreign-mysql-stmt-bind-param stmtptr (mysql-binding-binds binding))
3113      (signal-mysql-stmt-error 'mysql-stmt-bind-param-direct conn) ) ) )
3114
3115;; Bind the fully defined result binding
3116
3117(define (mysql-stmt-bind-result-direct conn binding)
3118        (and-let* ([stmtptr (mysql-connection-statement conn)])
3119                (when (foreign-mysql-stmt-bind-result stmtptr (mysql-binding-binds binding))
3120      (signal-mysql-stmt-error 'mysql-stmt-bind-result-direct conn) ) ) )
3121
3122;; Toggles the connection binding to params
3123
3124(define (mysql-stmt-bind-param conn binding)
3125  (mysql-bindings-reset conn)
3126  (mysql-stmt-bind-param-direct conn binding)
3127        (mysql-connection-bindings-set! conn binding) )
3128
3129;; Toggles the connection binding to results
3130
3131(define (mysql-stmt-bind-result conn binding)
3132  (mysql-bindings-reset conn)
3133  (mysql-stmt-bind-result-direct conn binding)
3134        (mysql-connection-bindings-set! conn binding) )
3135
3136;;
3137
3138(define (mysql-stmt-execute conn)
3139        (and-let* ([stmtptr (mysql-connection-statement conn)])
3140                (unless (fx= 0 (foreign-mysql-stmt-execute stmtptr))
3141                        (signal-mysql-stmt-error 'mysql-stmt-execute conn) ) ) )
3142
3143;;
3144
3145(define (mysql-stmt-affected-rows conn)
3146        (and-let* ([stmtptr (mysql-connection-statement conn)])
3147                (let ([cnt (foreign-mysql-stmt-affected-rows stmtptr)])
3148                        (and (not (= -1 cnt))
3149                                         cnt ) ) ) )
3150
3151;; Returns boolean for success, mysql-data-truncated, or signals
3152;; an exception.
3153
3154(define (mysql-stmt-fetch conn)
3155        (and-let* ([stmtptr (mysql-connection-statement conn)])
3156                (let ([val (foreign-mysql-stmt-fetch stmtptr)])
3157                        (cond [(fx= 0 val)
3158                                                        #t]
3159                                                [(= mysql-no-data val)
3160                                                        #f]
3161                                                [(= mysql-data-truncated val)
3162                                                        mysql-data-truncated]
3163                                                [(= 1 val)
3164                                                        (signal-mysql-stmt-error 'mysql-stmt-fetch conn) ] ) ) ) )
3165
3166;; Causes the result to be buffered. Does not touch the connection
3167;; result!
3168
3169(define (mysql-stmt-store-result conn)
3170        (and-let* ([stmtptr (mysql-connection-statement conn)])
3171                (when (fx= 0 (foreign-mysql-stmt-store-result stmtptr))
3172                        (signal-mysql-stmt-error 'mysql-stmt-store-result conn) ) ) )
3173
3174;; Can only be invoked after a stmt-store-result, stmt-fetch, or
3175;; stmt-prepare (of a result).
3176
3177(define (mysql-stmt-result-metadata conn)
3178        (mysql-free-result conn) ; free any existing results
3179        (and-let* ([stmtptr (mysql-connection-statement conn)])
3180                (let ([resptr (foreign-mysql-stmt-result-metadata stmtptr)])
3181                        (cond [resptr
3182              (mysql-connection-result-set! conn resptr)
3183              (mysql-connection-result-start-set!
3184               conn
3185               (foreign-mysql-stmt-row-tell (mysql-connection-result conn))) ]
3186            [else
3187              (signal-mysql-stmt-error 'mysql-stmt-result-metadata conn) ] ) ) ) )
3188
3189;; Set the connection statement attribute
3190
3191(define (mysql-stmt-attr-set! conn attr val)
3192        (and-let* ([stmtptr (mysql-connection-statement conn)])
3193                (when (%mysql-stmt-attr-set! stmtptr attr val)
3194                        (signal-mysql-condition 'mysql-stmt-attr-set
3195                                                                                                                        "unknown statement attribute" attr val) ) ) )
3196
3197;; Get the connection statement attribute
3198
3199(define (mysql-stmt-attr-get conn attr)
3200        (and-let* ([stmtptr (mysql-connection-statement conn)])
3201                (let ([val (%mysql-stmt-attr-get stmtptr attr)])
3202                        (if (eq? (void) val)
3203                                        (signal-mysql-condition 'mysql-stmt-attr-get
3204                                                                                                                                         "unknown statement attribute" attr)
3205                                        val ) ) ) )
3206
3207;; Rewinds to the beginning of the result set. Has no effect if there is no
3208;; current result set.
3209
3210(define (mysql-stmt-rewind conn)
3211        (and-let* ([stmtptr (mysql-connection-statement conn)]
3212                                                 [resptr (mysql-connection-result-start conn)])
3213                (foreign-mysql-stmt-row-seek stmtptr resptr) ) )
3214
3215;-----------------------------------------------------------------------
3216; The prepared statement "extended" MySQL/Scheme API.
3217;
3218; This API provides statement query support.
3219;
3220
3221;; Returns a procedure, or #f when no connection.
3222;; The procedure takes a field identifier and returns the
3223;; mysql-bind-ptr of the field's mysql-bind record, or #f
3224;; when no more rows to fetch.
3225
3226(define (mysql-stmt-row-fetch conn)
3227        (and-let* ([resptr (mysql-connection-result conn)]      ; metadata, if any
3228                   [bindings (mysql-connection-bindings conn)]  ; better be result
3229                                                 [bndptr (mysql-binding-binds bindings)]
3230                                                 [(mysql-stmt-fetch conn)])
3231                (let ([fldcnt (mysql-num-fields conn)])
3232                        (lambda (field)
3233                                (and-let* ([fldidx (mysql-get-field-index resptr field fldcnt)])
3234                                        (mysql-bind-ref-ptr bndptr fldidx) ) ) ) ) )
3235
3236;; Fetch statement result metadata for query?
3237;; Necessary for symbolic field name resolution
3238
3239(define-parameter mysql-stmt-fetch-metadata-for-query
3240  #t
3241  (lambda (x) x) )
3242
3243;; Prep a query
3244;; query    : SQL source string
3245
3246(define (mysql-stmt-query-init conn query)
3247  ; Must have statement storage
3248  (unless (mysql-connection-statement conn) (mysql-stmt-init conn) )
3249  ; Compile SQL
3250        (mysql-stmt-prepare conn query)
3251        ; Using metadata? (sets result-set)
3252        (if (mysql-stmt-fetch-metadata-for-query)
3253            (mysql-stmt-result-metadata conn)
3254            (mysql-free-result conn) ) )
3255
3256;; Perform a query
3257;; query    : SQL source string
3258;; params   : mysql-binding
3259;; results  : mysql-binding
3260
3261(define (mysql-stmt-query conn query #!optional params results)
3262  ; Prep the stmt
3263  (mysql-stmt-query-init conn query)
3264        ; Bind any params
3265        (when params (mysql-stmt-bind-param conn params))
3266        ; Perform
3267        (mysql-stmt-execute conn)
3268  ; Bind any results
3269        (when results (mysql-stmt-bind-result conn results)) )
3270
3271;-----------------------------------------------------------------------
3272; The prepared statement "map" MySQL/Scheme API.
3273;
3274; This API provides some additional functionality for traversing results
3275; in a Scheme-ish way.
3276;
3277
3278;; Calls proc on every row in the current result set. proc should take 3
3279;; arguments: the row (as described for mysql-stmt-row-fetch), the row index
3280;; (which starts with 1 and ends with (mysql-stmt-num-rows conn)), and the
3281;; current accumulated value.
3282;;
3283;; Returns the final accumulated value.
3284;;
3285;; Note: rewinds the result before and after iterating over it; thus,
3286;; all rows are included.
3287;;
3288;; You must call mysql-stmt-rewind if you later want to iterate over the result set
3289;; using mysql-stmt-row-fetch.
3290
3291(define (mysql-stmt-row-fold conn proc init)
3292        (mysql-stmt-rewind conn)
3293        (let loop ([rownum 1] [acc init])
3294                (let ([row (mysql-stmt-row-fetch conn)])
3295                        (if row
3296                                        (loop (fx+ rownum 1) (proc row rownum acc))
3297                                        acc ) ) ) )
3298
3299;; Calls proc on every row in the current result set. proc should take 2
3300;; arguments: the row (as described for mysql-stmt-row-fetch) and the row index
3301;; (which starts with 1 and ends with (mysql-stmt-num-rows conn)).
3302;;
3303;; Note: rewinds the result before and after iterating over it; thus,
3304;; all rows are included.
3305;;
3306;; You must call mysql-stmt-rewind if you later want to iterate over the result set
3307;; using mysql-stmt-row-fetch.
3308
3309(define (mysql-stmt-row-for-each conn proc)
3310        (mysql-stmt-row-fold conn
3311                                                                                         (lambda (row rownum _) (proc row rownum))
3312                                                                                         #t) )
3313
3314;; Calls proc on every row in the current result set. proc should take 2
3315;; arguments: the row (as described for mysql-stmt-row-fetch) and the row index
3316;; (which starts with 1 and ends with (mysql-stmt-num-rows conn)).
3317;;
3318;; Returns a list of the results of each proc invocation.
3319;;
3320;; Note: rewinds the result before and after iterating over it; thus,
3321;; all rows are included.
3322;;
3323;; You must call mysql-stmt-rewind if you later want to iterate over the result set
3324;; using mysql-stmt-row-fetch.
3325
3326(define (mysql-stmt-row-map conn proc)
3327        (reverse!
3328         (mysql-stmt-row-fold conn
3329                                                                                                (lambda (row rownum lst) (cons (proc row rownum) lst))
3330                                                                                                '())) )
3331
3332;; Executes query and then mysql-row-for-each with the given proc. The proc
3333;; must meet the contract specified for the proc passed to mysql-stmt-row-fold.
3334
3335(define (mysql-stmt-query-fold conn query proc init #!optional params results)
3336        (mysql-stmt-query conn query params results)
3337        (mysql-stmt-row-fold conn proc init) )
3338
3339;; Executes query and then mysql-row-for-each with the given proc. The proc
3340;; must meet the contract specified for the proc passed to mysql-stmt-row-for-each.
3341
3342(define (mysql-stmt-query-for-each conn query proc #!optional params results)
3343        (mysql-stmt-query conn query params results)
3344        (mysql-stmt-row-for-each conn proc) )
3345
3346;; Executes query and then mysql-row-for-each with the given proc. The proc
3347;; must meet the contract specified for the proc passed to mysql-stmt-row-map.
3348
3349(define (mysql-stmt-query-map conn query proc #!optional params results)
3350        (mysql-stmt-query conn query params results)
3351        (mysql-stmt-row-map conn proc) )
3352|#
Note: See TracBrowser for help on using the repository browser.