dbquery.lisp (6894B)
1 ;;; Copyright (C) 2013 Tomas Hlavaty <tom@logand.com> 2 ;;; 3 ;;; Permission is hereby granted, free of charge, to any person 4 ;;; obtaining a copy of this software and associated documentation 5 ;;; files (the "Software"), to deal in the Software without 6 ;;; restriction, including without limitation the rights to use, copy, 7 ;;; modify, merge, publish, distribute, sublicense, and/or sell copies 8 ;;; of the Software, and to permit persons to whom the Software is 9 ;;; furnished to do so, subject to the following conditions: 10 ;;; 11 ;;; The above copyright notice and this permission notice shall be 12 ;;; included in all copies or substantial portions of the Software. 13 ;;; 14 ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 17 ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 18 ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 19 ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 21 ;;; DEALINGS IN THE SOFTWARE. 22 23 (defpackage :dbquery 24 (:use :cl) 25 (:export :query 26 :prepare 27 :execute 28 :deallocate 29 :finish 30 :make-pg-server 31 :make-mysql-server 32 :make-sqlite-server)) 33 34 (in-package :dbquery) 35 36 (defun query (server q &rest args) 37 (funcall server `(:query ,q ,@args))) 38 39 (defun prepare (server stm q &rest args) 40 (funcall server `(:prepare ,stm ,q ,@args))) 41 42 (defun execute (server stm &rest args) 43 (funcall server `(:execute ,stm ,@args))) 44 45 (defun deallocate (server stm) 46 (funcall server `(:deallocate ,stm))) 47 48 (defun finish (server) 49 (funcall server nil)) 50 51 (defun rnum () 52 (do (done y (z 0)) 53 (done z) 54 (let ((c (read-char))) 55 (cond 56 ((char<= #\0 c #\9) 57 (setq y t 58 z (+ (* 10 z) (char-code c) #.(- (char-code #\0))))) 59 ((and (char= #\newline c) y) (setq done t)) 60 (t (error "expected number ~d ~s" z c)))))) 61 62 (defun rstr () 63 (ecase (read-char) 64 (#\? 65 (assert (char= #\newline (read-char))) 66 :null) 67 (#\" 68 (with-output-to-string (*standard-output*) 69 (do (done) 70 (done) 71 (let ((c (read-char))) 72 (case c 73 (#\\ (write-char (read-char))) 74 (#\" (assert (char= #\newline (read-char))) 75 (setq done t)) 76 (t (write-char c))))))))) 77 78 (defun dbquery-pg-writer (value *standard-output*) 79 (destructuring-bind (cmd &rest rest) value 80 (flet ((%query (q &rest args) 81 (format t "1~%~d~%~s~%" (length args) q) 82 (dolist (a args) 83 (etypecase a 84 (integer (format t "~s~%\"~s\"~%" 23 a)) 85 (string (format t "~s~%~s~%" 705 a)))))) 86 (ecase cmd 87 (:query (apply #'%query rest)) 88 (:prepare 89 (destructuring-bind (stm q &rest args) rest 90 (format t "2~%~d~%~s~%~s~%" (length args) stm q) 91 (dolist (a args) 92 (etypecase a 93 (integer (format t "~s~%" 23)) 94 (string (format t "~s~%" 705)))))) 95 (:execute 96 (destructuring-bind (stm &rest args) rest 97 (format t "3~%~d~%~s~%" (length args) stm) 98 (dolist (a args) 99 (etypecase a 100 (null (format t "-~%")) 101 (integer (format t "\"~s\"~%" a)) 102 (string (format t "~s~%" a)))))) 103 (:deallocate 104 (destructuring-bind (stm) rest 105 (%query (format nil "DEALLOCATE ~s" stm))))))) 106 (finish-output)) 107 108 ;;http://doxygen.postgresql.org/interfaces_2ecpg_2ecpglib_2pg__type_8h.html 109 (defun parse-pg-value (value type) 110 (if (eq :null value) 111 :null 112 (ecase type 113 (16 (cond 114 ((equal "t" value) :true) 115 ((equal "f" value) :false) 116 (t (error "unexpected boolean value ~s" value)))) 117 ((#+nil 25 1700) (parse-integer value)) 118 (1043 value) 119 (1184 ;; TODO parse "2010-06-21 18:54:11+02" 120 value)))) 121 122 ;;(DBQUERY::PARSE-PG-VALUE "VAF0co3Ymo/mWob7qH1p/zCdSyhgp4+5n+Wp/cuoVy75v9BRKIVlSQtb8Jq4p3AexYExdbmEZO2wKcpkymsqAbfN8F5dB+atrBsIAAAA" 25) 123 124 (defun dbquery-pg-reader (*standard-input*) 125 (ecase (rnum) 126 (0 (error "Database error ~s ~s" (rstr) (rstr))) 127 ((1 3) 128 (let ((n (rnum)) 129 (m (rnum))) 130 (when (and (plusp n) (plusp m)) 131 (let ((cols (loop for i from 0 below m collect (cons (rnum) (rstr))))) 132 (progn ;;cons cols 133 (loop 134 for i from 0 below n 135 collect (loop 136 for j from 0 below m 137 for (type . name) in cols 138 collect (parse-pg-value (rstr) type)))))))) 139 (2))) 140 141 (defun make-pg-server (command connection-info) 142 (rw.concurrency:make-program-server 143 command (list connection-info) 'dbquery-pg-writer 'dbquery-pg-reader)) 144 145 (defun make-sqlite-server (command db) 146 (rw.concurrency:make-program-server 147 command (list db) 'dbquery-writer 'dbquery-reader)) 148 149 (defun make-mysql-server (command host user password db) 150 (rw.concurrency:make-program-server 151 command (list host user password db) 'dbquery-writer 'dbquery-reader)) 152 153 ;; (setq c (make-pg-server "cat" "-")) 154 ;; (funcall c "123") 155 ;; (funcall c nil) 156 157 ;; (setq c (make-sqlite-server "./dbquery-sqlite" "sqlite.db")) 158 ;; (time (funcall c "select 1, 2+3")) 159 ;; (time (funcall c "select 4, 'hello'")) 160 ;; (funcall c nil) 161 162 ;; (setq c (make-pg-server "./dbquery-pg" "dbname='pokus' user='tomas'")) 163 ;; (time (funcall c "select 1, 2+3")) 164 ;; (time (funcall c "select 4, 'hello'")) 165 ;; (funcall c nil) 166 167 ;; (setq c (make-mysql-server "./dbquery-mysql" "localhost" "tomas" "Ri3OoL3h" "pokus")) 168 ;; (time (funcall c "select 1, 2+3")) 169 ;; (time (funcall c "select 4, 'hello'")) 170 ;; (funcall c nil) 171 172 ;;; (() ...) first car param types, then query, then params 173 174 ;; in: nargs query [[type param]...] 175 ;; out: ncol nrow [[[ctyp cname]...] [row...]] 176 177 ;; 0 "select 1, 2+3" => 2 1 91 91 "1" "2+3" "1" "5" 178 ;; 2 "select 1, 2+3, $1, $2" 0 "hi" 0 "123" => 4 1 91 91 92 93 "1" "2+3" "$1" "$2" "1" "5" "hi" "123" 179 180 ;;(dbquery-pg-writer '(:query "select $1, 1, 2+3" 123) *standard-output*) 181 ;;(dbquery-pg-writer '(:prepare "stm1" "select $1, 1, 2+3" 1234567890) *standard-output*) 182 ;;(dbquery-pg-writer '(:execute "stm1" 1234567890) *standard-output*) 183 ;;(dbquery-pg-writer '(:deallocate "stm1") *standard-output*) 184 185 ;;(defparameter c (make-pg-server "/home/tomas/git/dbquery/dbquery-pg" "dbname='pokus' user='tomas'")) 186 ;;(query c "select 1, 2+3") 187 ;;(query c "select 1, 2+3 from hi") 188 ;;(query c "select $1, 1, 2+3" 1234567890) 189 ;;(query c "select $1, 1, 2+3" 1234567890123456789) 190 ;;(prepare c "stm1" "select $1, 1, 2+3" 1234567890) 191 ;;(execute c "stm1" 890) 192 ;;(deallocate c "stm1") <<<< TODO crashes