ssql: port to chicken 4 and remove prometheud dependency
git-svn-id: https://code.call-cc.org/svn/chicken-eggs/release/4/ssql/trunk@22895 fca3e652-9b03-0410-8d7b-ac86a6ce46c4master
syn
14 years ago
commit
1c67cd0c36
@ -0,0 +1,56 @@
|
||||
(module foops
|
||||
|
||||
(make-object derive-object)
|
||||
|
||||
(import chicken scheme)
|
||||
(use matchable)
|
||||
(import-for-syntax chicken)
|
||||
(begin-for-syntax
|
||||
(use srfi-1))
|
||||
|
||||
(define-for-syntax args-without-self
|
||||
'(if (and (pair? args) (procedure? (car args)))
|
||||
(cdr args)
|
||||
args))
|
||||
|
||||
(define-syntax derive-object
|
||||
(ir-macro-transformer
|
||||
(lambda (x i c)
|
||||
(let-optionals (second x)
|
||||
((ancestor #f)
|
||||
(self #f)
|
||||
(super #f))
|
||||
|
||||
`(let ((ancestor ,ancestor))
|
||||
(letrec ((self (lambda args
|
||||
(if (null? args)
|
||||
ancestor
|
||||
(let* ((self* (if (and (pair? args) (procedure? (car args)))
|
||||
(car args)
|
||||
self))
|
||||
,@(if self `((,self self*)) '())
|
||||
,@(if super
|
||||
`((,super
|
||||
(lambda args
|
||||
(apply ancestor self* args))))
|
||||
'())
|
||||
(args ,args-without-self))
|
||||
|
||||
(match args
|
||||
,@(map (lambda (m)
|
||||
`(((quote ,(strip-syntax (caar m))) . ,(cdar m))
|
||||
. ,(cdr m)))
|
||||
(cddr x))
|
||||
(_ (apply ancestor self* args))))))))
|
||||
self))))))
|
||||
|
||||
(define-syntax make-object
|
||||
(ir-macro-transformer
|
||||
(lambda (x i r)
|
||||
`(derive-object
|
||||
((lambda args
|
||||
(error "message not understood" ,args-without-self))
|
||||
. ,(cadr x))
|
||||
. ,(cddr x)))))
|
||||
|
||||
)
|
||||
@ -0,0 +1,5 @@
|
||||
((synopsis "SQL as S-expressions")
|
||||
(category databases)
|
||||
(needs matchable postgresql)
|
||||
(license "BSD")
|
||||
(author "Peter Bex, Moritz Heidkamp"))
|
||||
@ -0,0 +1,235 @@
|
||||
(module ssql
|
||||
|
||||
(ssql->sql ssql-connection scope-table find-tables
|
||||
register-sql-engine! define-operators *ansi-translator*)
|
||||
|
||||
(import chicken scheme)
|
||||
(use matchable data-structures extras srfi-1 srfi-13 foops)
|
||||
(import-for-syntax chicken)
|
||||
(begin-for-syntax
|
||||
(use srfi-1 srfi-13))
|
||||
|
||||
(define-syntax define-operators
|
||||
(ir-macro-transformer
|
||||
(lambda (x i c)
|
||||
(let ((engine (second x)))
|
||||
`(set! ,engine
|
||||
(derive-object (,engine self)
|
||||
,@(map (lambda (op)
|
||||
(let ((ssql-op (first op))
|
||||
(type (second op)))
|
||||
(let-optionals (cddr op)
|
||||
((sql-op (string-upcase (->string (strip-syntax ssql-op)))))
|
||||
`((,(strip-syntax ssql-op) operands)
|
||||
(self 'operator->sql ',type ,sql-op operands)))))
|
||||
(cddr x))))))))
|
||||
|
||||
(define *ansi-translator*
|
||||
(make-object (self)
|
||||
((type->sql-converters)
|
||||
`((,null? . null->sql)
|
||||
(,pair? . pair->sql)
|
||||
(,symbol? . source->sql)
|
||||
(,string? . string->sql)
|
||||
(,number? . number->sql)))
|
||||
|
||||
((escape-string string)
|
||||
(string-translate* string '(("'" . "''"))))
|
||||
|
||||
((null->sql null) "")
|
||||
|
||||
((pair->sql pair)
|
||||
(self (car pair) (cdr pair)))
|
||||
|
||||
((string->sql string)
|
||||
(string-append "'" (self 'escape-string string) "'"))
|
||||
|
||||
((number->sql number)
|
||||
(->string number))
|
||||
|
||||
((source->sql source)
|
||||
(symbol->string source))
|
||||
|
||||
((columns ssql)
|
||||
(string-intersperse (map (lambda (s)
|
||||
(self 'ssql->sql s))
|
||||
ssql)
|
||||
", "))
|
||||
|
||||
((col ssql)
|
||||
(string-intersperse (map (lambda (colname)
|
||||
(self 'ssql->sql (string->symbol (sprintf "~A.~A" (car ssql) colname))))
|
||||
(cdr ssql))
|
||||
", "))
|
||||
|
||||
((join ssql)
|
||||
(match ssql
|
||||
((type first rest ...) (sprintf "(~A ~A JOIN ~A)"
|
||||
(self 'ssql->sql first)
|
||||
(string-upcase (symbol->string type))
|
||||
(string-join (map (lambda (x) (self 'ssql->sql x)) rest))))))
|
||||
|
||||
((operator->sql type operator operands)
|
||||
(case type
|
||||
((infix)
|
||||
(sprintf "(~A)" (string-intersperse
|
||||
(map (lambda (operand)
|
||||
(self 'ssql->sql operand))
|
||||
operands)
|
||||
(string-append " " operator " "))))
|
||||
((function)
|
||||
(sprintf "~A(~A)"
|
||||
operator
|
||||
(string-intersperse
|
||||
(map (lambda (operand)
|
||||
(self 'ssql->sql operand))
|
||||
operands)
|
||||
", ")))
|
||||
((suffix prefix)
|
||||
(let ((operator (if (eq? type 'prefix)
|
||||
(string-append operator " ")
|
||||
(string-append " " operator))))
|
||||
(sprintf "(~A)"
|
||||
(string-join
|
||||
(list
|
||||
(string-intersperse
|
||||
(map (lambda (operand)
|
||||
(self 'ssql->sql operand))
|
||||
operands)))
|
||||
operator
|
||||
type))))
|
||||
(else (error "unknown operator syntax type" type))))
|
||||
|
||||
((ssql->sql ssql)
|
||||
(let ((handler (alist-ref (list ssql) (self 'type->sql-converters) apply)))
|
||||
(if handler
|
||||
(self handler ssql)
|
||||
(error "unknown datatype" ssql))))))
|
||||
|
||||
(define-operators *ansi-translator*
|
||||
(select prefix)
|
||||
(from prefix)
|
||||
(where prefix)
|
||||
(having prefix)
|
||||
(union infix)
|
||||
(as infix)
|
||||
(asc suffix)
|
||||
(desc suffix)
|
||||
(on prefix)
|
||||
|
||||
(and infix)
|
||||
(or infix)
|
||||
(not prefix)
|
||||
|
||||
(min function)
|
||||
(max function)
|
||||
(avg function)
|
||||
(sum function)
|
||||
(count function)
|
||||
|
||||
(distinct prefix)
|
||||
(all prefix)
|
||||
|
||||
(values function)
|
||||
|
||||
(upper function)
|
||||
(lower function)
|
||||
(string-append infix "||")
|
||||
(= infix)
|
||||
(like infix)
|
||||
(escape infix)
|
||||
(< infix)
|
||||
(> infix)
|
||||
(<= infix)
|
||||
(>= infix)
|
||||
(<> infix)
|
||||
(!= infix "<>")
|
||||
(null? suffix "IS NULL"))
|
||||
|
||||
(define *sql-engines* `((,(lambda (obj) (eq? obj #f)) . ,*ansi-translator*)))
|
||||
|
||||
(define ssql-connection (make-parameter #f))
|
||||
|
||||
(define (register-sql-engine! predicate translator)
|
||||
(set! *sql-engines* (alist-cons predicate translator *sql-engines*)))
|
||||
|
||||
(define (get-sql-engine connection)
|
||||
(alist-ref (list connection) *sql-engines* apply))
|
||||
|
||||
(define (ssql->sql connection ssql)
|
||||
(let ((engine (get-sql-engine connection)))
|
||||
(if engine
|
||||
(parameterize ((ssql-connection connection))
|
||||
(engine 'ssql->sql ssql))
|
||||
(error (sprintf "No engine found for connection object ~A" connection)))))
|
||||
|
||||
(define (escape connection string)
|
||||
((get-sql-engine connection) 'escape string))
|
||||
|
||||
(define (colref? x)
|
||||
(and (symbol? x) (string-any #\. (symbol->string x))))
|
||||
|
||||
(define (rewrite-tables ssql renamed)
|
||||
(let loop ((ssql ssql))
|
||||
(match ssql
|
||||
(('col alias cols ...) `(col ,(alist-ref alias renamed eq? alias) ,@cols))
|
||||
(('as table alias) `(as ,table ,(alist-ref alias renamed eq? alias)))
|
||||
((? colref? col)
|
||||
(let* ((refs (string-split (symbol->string col) "."))
|
||||
(col (string->symbol (car refs))))
|
||||
(string->symbol (string-join (cons
|
||||
(symbol->string (alist-ref col renamed eq? col))
|
||||
(cdr refs))
|
||||
"."))))
|
||||
((operator operands ...)
|
||||
`(,operator ,@(map (cut loop <>) operands)))
|
||||
(other other))))
|
||||
|
||||
(define (scope-table table scope ssql)
|
||||
(let loop ((ssql ssql))
|
||||
(match ssql
|
||||
((not (? pair?)) ssql)
|
||||
((select ('columns tables ...)
|
||||
('from from-specs ...)
|
||||
('where conditions ...)
|
||||
more ...)
|
||||
(let ((aliases (filter (lambda (x) (eq? (car x) table)) (find-tables (cons 'from from-specs)))))
|
||||
`(select (columns ,@(map loop tables))
|
||||
(from ,@(map loop from-specs))
|
||||
(where (and ,@(map (lambda (alias) (rewrite-tables scope `((,table . ,(cdr alias))))) aliases)
|
||||
,(map loop conditions)))
|
||||
,@(map loop more))))
|
||||
((select ('columns tables ...)
|
||||
('from from-specs ...)
|
||||
more ...)
|
||||
(=> fail)
|
||||
(let ((aliases (filter (lambda (x) (eq? (car x) table)) (find-tables (cons 'from from-specs)))))
|
||||
(if (null? aliases)
|
||||
(fail) ; Don't inject an empty WHERE
|
||||
`(select (columns ,@(map loop tables))
|
||||
(from ,@(map loop from-specs))
|
||||
(where (and ,@(map (lambda (alias) (rewrite-tables scope `((,table . ,(cdr alias))))) aliases)))
|
||||
,@(map loop more)))))
|
||||
(other (map loop other)))))
|
||||
|
||||
;; Find all tables used in a query. Returns an list of conses: ((table . alias) ...)
|
||||
;; A table may occur more than once!
|
||||
(define (find-tables ssql)
|
||||
(let loop ((expect-table? #f)
|
||||
(tables '())
|
||||
(ssql ssql))
|
||||
(match ssql
|
||||
((? symbol?)
|
||||
(if expect-table?
|
||||
(cons (cons ssql ssql) tables)
|
||||
tables))
|
||||
(('as (? symbol? table) alias)
|
||||
(cons (cons table alias) tables))
|
||||
((or ('from rest ...)
|
||||
('join _ rest ...))
|
||||
(append (apply append (map (lambda (tbl) (loop #t '() tbl)) rest)) tables))
|
||||
((head tail ...)
|
||||
(append (loop #f tables head) (loop #f tables tail)))
|
||||
(_ tables))))
|
||||
|
||||
)
|
||||
@ -0,0 +1,3 @@
|
||||
(standard-extension 'foops #f)
|
||||
(standard-extension 'ssql #f)
|
||||
(standard-extension 'ssql-pgsql #f)
|
||||
@ -0,0 +1,24 @@
|
||||
(use test)
|
||||
(import ssql)
|
||||
|
||||
(test-begin "selects")
|
||||
(test "Simple query"
|
||||
"(SELECT actors.firstname, actors.lastname (FROM actors))"
|
||||
(ssql->sql #f `(select (columns actors.firstname actors.lastname)
|
||||
(from actors))))
|
||||
(test "Many columns"
|
||||
"(SELECT actors.id, actors.firstname, actors.lastname, roles.character, roles.movie_id (FROM actors roles))"
|
||||
(ssql->sql #f `(select (columns (col actors id firstname lastname) (col roles character movie_id))
|
||||
(from actors roles))))
|
||||
(test "Joined query"
|
||||
(string-append
|
||||
"(SELECT actors.firstname, actors.lastname, roles.character, movies.title "
|
||||
"(FROM ((actors LEFT JOIN roles (ON (roles.actor_id = actors.id))) "
|
||||
"LEFT JOIN movies (ON (movies.id = roles.movie_id)))))")
|
||||
(ssql->sql #f `(select (columns actors.firstname actors.lastname roles.character movies.title)
|
||||
(from (join left
|
||||
(join left actors roles
|
||||
(on (= roles.actor_id actors.id)))
|
||||
movies
|
||||
(on (= movies.id roles.movie_id)))))))
|
||||
(test-end "selects")
|
||||
@ -0,0 +1,49 @@
|
||||
(load-relative "../foops")
|
||||
|
||||
(import foops)
|
||||
(use test)
|
||||
|
||||
(test-group "basic functionality"
|
||||
(define foo (make-object () ((bar) 'baz)))
|
||||
(test 'baz (foo 'bar))
|
||||
|
||||
(define widget
|
||||
(make-object (self)
|
||||
((frob) 'foo)
|
||||
((echo s) s)
|
||||
((send m) (self m))))
|
||||
|
||||
(test 'foo (widget 'frob))
|
||||
(test "here" (widget 'echo "here"))
|
||||
(test 'foo (widget 'send 'frob))
|
||||
(test-error (widget 'err)))
|
||||
|
||||
(test-group "inheritance"
|
||||
(define dinosaur
|
||||
(make-object (self)
|
||||
((sound) 'rawr)
|
||||
((talk) (self 'sound))))
|
||||
|
||||
(define t-rex
|
||||
(derive-object (dinosaur self super)
|
||||
((sound) 'hah)
|
||||
((talk-original) (super 'sound))))
|
||||
|
||||
(test 'rawr (dinosaur 'talk))
|
||||
(test 'hah (t-rex 'talk))
|
||||
(test 'rawr (t-rex 'talk-original)))
|
||||
|
||||
|
||||
(test-group "pattern matching"
|
||||
(define vehicle
|
||||
(make-object (self)
|
||||
((drive) 'wroom)
|
||||
((drive distance)
|
||||
(map (lambda (i) (self 'drive))
|
||||
(iota distance)))
|
||||
((drive distance speed)
|
||||
(cons speed (self 'drive distance)))))
|
||||
|
||||
(test 'wroom (vehicle 'drive))
|
||||
(test '(wroom wroom) (vehicle 'drive 2))
|
||||
(test '(fast wroom wroom wroom) (vehicle 'drive 3 'fast)))
|
||||
@ -0,0 +1,18 @@
|
||||
(load-relative "../ssql-pgsql")
|
||||
(import ssql)
|
||||
(import ssql-pgsql)
|
||||
(use test postgresql foops)
|
||||
|
||||
(define *test-pgsql-translator*
|
||||
(derive-object (*pgsql-translator* self super)
|
||||
((escape-string string)
|
||||
(super (ssql-connection) string))))
|
||||
|
||||
(register-sql-engine! (lambda (x) (eq? x #t)) *test-pgsql-translator*)
|
||||
|
||||
(test-begin "selects")
|
||||
(test "Simple query"
|
||||
"(SELECT actors.firstname, actors.lastname (FROM actors))"
|
||||
(ssql->sql #t `(select (columns actors.firstname actors.lastname)
|
||||
(from actors))))
|
||||
(test-end "selects")
|
||||
@ -0,0 +1,6 @@
|
||||
(load-relative "foops-test")
|
||||
(load-relative "../ssql")
|
||||
(load-relative "transformations-test")
|
||||
(load-relative "ansi-test")
|
||||
;; (load "mysql-test")
|
||||
(load-relative "pgsql-test")
|
||||
@ -0,0 +1,42 @@
|
||||
(use test)
|
||||
(import ssql)
|
||||
|
||||
(test-begin "inspection")
|
||||
(test "find-tables"
|
||||
`((actors . actors) (roles . roles) (movies . m2) (movies . movies))
|
||||
(find-tables
|
||||
`(select (columns actors.firstname actors.lastname roles.character movies.title)
|
||||
(from (join left
|
||||
(join left actors
|
||||
(join inner roles (as movies m2)
|
||||
(on (and (= m2.id roles.movie_id)
|
||||
(> m2.year 2000))))
|
||||
(on (= roles.actor_id actors.id)))
|
||||
movies
|
||||
(on (= movies.id roles.movie_id)))))))
|
||||
(test-end "inspection")
|
||||
|
||||
(test-begin "scoping")
|
||||
(test "scope-table"
|
||||
`(select (columns actors.firstname actors.lastname roles.character movies.title)
|
||||
(from (join left
|
||||
(join left actors
|
||||
(join inner roles (as movies m2)
|
||||
(on (and (= m2.id roles.movie_id)
|
||||
(> m2.year 2000))))
|
||||
(on (= roles.actor_id actors.id)))
|
||||
movies
|
||||
(on (= movies.id roles.movie_id))))
|
||||
(where (and (< (col m2 year) 2005)
|
||||
(< (col movies year) 2005))))
|
||||
(scope-table 'movies `(< (col movies year) 2005)
|
||||
`(select (columns actors.firstname actors.lastname roles.character movies.title)
|
||||
(from (join left
|
||||
(join left actors
|
||||
(join inner roles (as movies m2)
|
||||
(on (and (= m2.id roles.movie_id)
|
||||
(> m2.year 2000))))
|
||||
(on (= roles.actor_id actors.id)))
|
||||
movies
|
||||
(on (= movies.id roles.movie_id)))))))
|
||||
(test-end "scoping")
|
||||
Loading…
Reference in New Issue