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

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

added changelog in mysql.scm

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