From 1c67cd0c36348037a0d6866247bb7f0746e9bafe Mon Sep 17 00:00:00 2001 From: syn Date: Fri, 25 Feb 2011 22:14:40 +0000 Subject: [PATCH] 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-ac86a6ce46c4 --- foops.scm | 56 ++++++++ ssql.meta | 5 + ssql.scm | 235 +++++++++++++++++++++++++++++++++ ssql.setup | 3 + tests/ansi-test.scm | 24 ++++ tests/foops-test.scm | 49 +++++++ tests/pgsql-test.scm | 18 +++ tests/run.scm | 6 + tests/transformations-test.scm | 42 ++++++ 9 files changed, 438 insertions(+) create mode 100644 foops.scm create mode 100644 ssql.meta create mode 100644 ssql.scm create mode 100644 ssql.setup create mode 100644 tests/ansi-test.scm create mode 100644 tests/foops-test.scm create mode 100644 tests/pgsql-test.scm create mode 100644 tests/run.scm create mode 100644 tests/transformations-test.scm diff --git a/foops.scm b/foops.scm new file mode 100644 index 0000000..86360bb --- /dev/null +++ b/foops.scm @@ -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))))) + +) \ No newline at end of file diff --git a/ssql.meta b/ssql.meta new file mode 100644 index 0000000..9fd9e20 --- /dev/null +++ b/ssql.meta @@ -0,0 +1,5 @@ +((synopsis "SQL as S-expressions") + (category databases) + (needs matchable postgresql) + (license "BSD") + (author "Peter Bex, Moritz Heidkamp")) diff --git a/ssql.scm b/ssql.scm new file mode 100644 index 0000000..0a7e8b4 --- /dev/null +++ b/ssql.scm @@ -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)))) + +) \ No newline at end of file diff --git a/ssql.setup b/ssql.setup new file mode 100644 index 0000000..441fc9c --- /dev/null +++ b/ssql.setup @@ -0,0 +1,3 @@ +(standard-extension 'foops #f) +(standard-extension 'ssql #f) +(standard-extension 'ssql-pgsql #f) diff --git a/tests/ansi-test.scm b/tests/ansi-test.scm new file mode 100644 index 0000000..3787877 --- /dev/null +++ b/tests/ansi-test.scm @@ -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") \ No newline at end of file diff --git a/tests/foops-test.scm b/tests/foops-test.scm new file mode 100644 index 0000000..8e752e4 --- /dev/null +++ b/tests/foops-test.scm @@ -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))) \ No newline at end of file diff --git a/tests/pgsql-test.scm b/tests/pgsql-test.scm new file mode 100644 index 0000000..ed64498 --- /dev/null +++ b/tests/pgsql-test.scm @@ -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") \ No newline at end of file diff --git a/tests/run.scm b/tests/run.scm new file mode 100644 index 0000000..699c8af --- /dev/null +++ b/tests/run.scm @@ -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") \ No newline at end of file diff --git a/tests/transformations-test.scm b/tests/transformations-test.scm new file mode 100644 index 0000000..f3f9f42 --- /dev/null +++ b/tests/transformations-test.scm @@ -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") \ No newline at end of file