Commits

carl douglas  committed 3cd7207

Refactor, query closure takes a thunk, when provided will call thunk on every row.
Fix optional argument to lambda.

  • Participants
  • Parent commits 000c45f

Comments (0)

Files changed (2)

File mysql-client.scm

 
 (define (make-mysql-connection host user pass database)
   (define mysql-c (make-mysql-c-connection host user pass database))
-  (set-finalizer! mysql-c (lambda(x) (close-mysql-c-connection mysql-c)))
+  (set-finalizer! mysql-c close-mysql-c-connection)
+
   (define (mysql-query query . parameters)
-    (cond ((and (string? query)(equal? parameters '())) (dispatch-query mysql-c query parameters))
-          ((string? query) (dispatch-query mysql-c query (car parameters)))
-          ((procedure? query) (dispatch-proc mysql-c query parameters))
+    (cond ((procedure? query)(mysql-query-with-proc mysql-c query parameters))
+          ((string? query)   (mysql-query-with-string mysql-c query parameters))
           (else (error "unrecognised query object: " query))))
   mysql-query)
 
-(define (dispatch-query conn query parameters)
-  (define result-c 
-    (cond ((equal? '() parameters) (mysql-c-query conn query))
-          (else (mysql-c-query conn (escape-placeholder-params conn query parameters)))))
-  (define (fetch-c)(let ((row (mysql-c-fetch-row result-c)))
-                      (if (and row (> (length row) 0)) 
-                          row 
-                          #f)))
-  (set-finalizer! result-c (lambda(x) (mysql-c-free-result result-c)))
-  (if result-c 
-      fetch-c 
-      (lambda()#f)))
-
-(define (dispatch-proc conn proc . parameters)
-  (proc conn parameters))
-
-(define (escape-placeholder-params conn query parameters)
-  (let ((escaped-parameters 
-          (map (lambda(x)
-                 (cons (symbol->string (car x)) (mysql-c-real-escape-string conn (cdr x))))
-               parameters)))
-       (irregex-replace/all 
-         (flatten (list 'or (map (lambda(x) (car x)) escaped-parameters)))
-         query
-         (lambda (r) 
-           (alist-ref (irregex-match-substring r 0) escaped-parameters string=?)))))
+(define (mysql-query-with-proc mysql-c proc . parameters)
+  (proc mysql-c parameters))
+
+(define (mysql-query-with-string mysql-c query parameters)
+  (cond ((null? parameters) (execute-query mysql-c query))
+        ((pair? parameters) (execute-query mysql-c (escape-parameters mysql-c query (car parameters))))
+        (else (error "unrecognised parameter object: " parameters))))
+
+(define (execute-query mysql-c query)
+  (define result-c (mysql-c-query mysql-c query))
+  (set-finalizer! result-c mysql-c-free-result)
+  (define (fetch . fetch-args)
+    (cond ((null? fetch-args)
+             (let ((row (mysql-c-fetch-row result-c)))
+                  (if (pair? row) row #f)))
+          ((pair? fetch-args)
+             (fetch-loop result-c (car fetch-args)))))
+
+  (if result-c fetch (lambda r #f)))
+
+(define (fetch-loop result-c thunk)
+  (letrec ((process (lambda()
+                      (let ((row (mysql-c-fetch-row result-c)))
+                        (if (pair? row)
+                          (begin
+                            (thunk row)
+                            (process)))))))
+    (process)))
+
+(define (make-irx parameters)
+  (flatten (list 'or (map (lambda(x) (car x)) parameters))))
+
+(define (stringify-keys parameters)
+  (map (lambda(p)
+         (cons (symbol->string(car p)) (cdr p))) parameters))
+
+(define (escape-parameters mysql-c query parameters)
+  (let ((stringified-keys (stringify-keys parameters)))
+    (irregex-replace/all 
+      (make-irx stringified-keys) 
+      query 
+      (lambda(r)
+        (mysql-c-real-escape-string mysql-c 
+          (alist-ref (irregex-match-substring r 0) stringified-keys string=?))))))
 
 (foreign-declare "#include \"mysql.h\"")
 

File tests/run.scm

 (use mysql-client lolevel)
 
-(define mysql 
+(define mysql
   (make-mysql-connection "localhost" "root" #f "information_schema"))
-(define fetch (mysql "select * from schemata"))
-(define (fetch-loop)
-  (let ((row (fetch)))
-    (if row
-      (begin
-        (printf "~A~%" row)
-        (fetch-loop)))))
-(fetch-loop)
 
 (if (not (pointer? (mysql (lambda(c . a) c))))
   (error "closure did not dispatch connection object"))
 
-(define fetch2 
-  (mysql "select * from tables where table_name = '$1' or table_name = '$foo'"
- '(($1 . "reads")($foo . "'unknown'"))))
-(printf "~A~%" (fetch2))
+(define-syntax exec-sql
+  (syntax-rules ()
+      ((_ sql ...) (begin 
+                     ((mysql sql ...) (lambda r (printf "~A~%" r)))))))
+
+(exec-sql "CREATE DATABASE IF NOT EXISTS chicken_scheme_mysql_client_test")
+(exec-sql "USE chicken_scheme_mysql_client_test")
+(exec-sql
+#<#SQL
+  CREATE TABLE IF NOT EXISTS `scheme_test` (
+    `created_at`   TIMESTAMP,
+    `name`         VARCHAR(32)
+  )
+SQL
+)
+(exec-sql "INSERT INTO scheme_test (created_at, name) VALUES (NOW(), '$name')" 
+          '(($name . "hell'o1")))
+(exec-sql "INSERT INTO scheme_test (created_at, name) VALUES (NOW(), '$name')" 
+          '(($name . "hello%2")))
+(exec-sql "SELECT * FROM scheme_test")
+(exec-sql "DROP DATABASE chicken_scheme_mysql_client_test")
+(exec-sql "USE information_schema")