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

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

fixing two bugs in mysql.scm

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