dbquery

Query RDBMS and return S-expression
git clone https://logand.com/git/dbquery.git/
Log | Files | Refs | README

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