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

Last change on this file since 8192 was 8192, checked in by Kon Lovett, 12 years ago

Save.

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