guile-pg 0.45-0ubuntu1 / usr / share / guile / site / database / postgres-qcons

(define-module(database postgres-qcons)#:export(qcons-declare! sql-pre sql-pre? sql-unpre sql-quote-auto-E? sql-quote string-xrep idquote make-comma-separated-tree make-WHERE-tree make-GROUP-BY-tree make-HAVING-tree make-ORDER-BY-tree make-SELECT/COLS-tree make-FROM-tree make-SELECT/FROM/COLS-tree parse+make-SELECT/tail-tree parse+make-SELECT-tree sql<-trees sql-command<-trees)#:use-module((srfi srfi-13)#:select(string-index string-prefix? string-concatenate-reverse substring/shared))#:use-module((srfi srfi-14)#:select(char-set:full ucs-range->char-set char-set-filter char-set-size char-set-union char-set-for-each ucs-range->char-set)))
(define-macro(define-hash name size pair? init) `(begin(define  ,name(make-hash-table  ,size))(for-each(lambda(x)(hashq-set!  ,name ,(if pair? '(car x) 'x) ,(if pair? '(cdr x)#t))) ,init)))
(define *conditional-operations* '(= < <= > >= <> != all any in like not-like ilike not-ilike ~~ !~~ ~~* !~~* similar not-similar ~ ~* !~ !~*))
(define *infix-operations*(append! '(|| ||/ |/ / !! % ^ * - + @ & | << >> && &< &> <-> <^ >^ ?- ?-| @-@ ?| ?|| @@ ~= <<= >>=)(map string->symbol '("#" "##" "?#"))*conditional-operations*))
(define-hash ==infix-operations 67 #f *infix-operations*)
(define *postfix-display-aliases* '((null? . "IS NULL") (not-null? . "IS NOT NULL") (true? . "IS TRUE") (not-true? . "IS NOT TRUE") (false? . "IS FALSE") (not-false? . "IS NOT FALSE") (unknown? . "IS UNKNOWN") (not-unknown? . "IS NOT UNKNOWN")))
(define *display-aliases*(append *postfix-display-aliases* '((not-like . "NOT LIKE") (not-ilike . "NOT ILIKE") (similar . "SIMILAR TO") (not-similar . "NOT SIMILAR TO"))))
(define-hash ==display-aliases 17 #t *display-aliases*)
(define *postfix-operations*(append '(!)(map car *postfix-display-aliases*)))
(define-hash ==postfix-operations 11 #f *postfix-operations*)
(define-hash ==kw-over-commas 7 #f(append '(convert overlay position substring trim) '(extract)))
(define (qcons-declare! category x . extra)(or(symbol? x)(error "not a symbol:" x))(case category((#:infix)(hashq-set! ==infix-operations x #t))((#:postfix)(hashq-set! ==postfix-operations x #t))((#:display-alias)(hashq-set! ==display-aliases x(car extra)))((#:keyword-args-ok)(hashq-set! ==kw-over-commas x #t))(else(error "bad category:" category))))
(define --preformatted(make-object-property))
(define(sql-pre string)(or(string? string)(error "not a string:" string))(set!(--preformatted string)#t)string)
(define(sql-pre? string)(--preformatted string))
(define(sql-unpre string)(or(string? string)(error "not a string:" string))(set!(--preformatted string)#f)string)
(define sql-quote-auto-E?(make-fluid))
(define(sql-quote string)(or(string? string)(error "not a string:" string))(let*((s(let loop((acc '())(start 0))(cond((string-index string #\\ start)=>(lambda(idx)(loop(cons* "\\134"(substring/shared string start idx)acc)(#{1+}# idx))))((null? acc)string)(else(string-concatenate-reverse acc(substring/shared string start))))))(olen(string-length s))(E?(and(fluid-ref sql-quote-auto-E?)(string-index s #\\)))(left-pos(if E? 1 0))(len(+ left-pos 2 olen))(cuts(let loop((stop olen)(acc(list olen)))(define(with x)(acons x(car acc)(cdr acc)))(cond((string-rindex s #\' 0 stop)=>(lambda(hit)(set! len(#{1+}# len))(loop hit(cons hit(with hit)))))(else(with 0)))))(rv(make-string len)))(and E?(string-set! rv 0 #\E))(string-set! rv left-pos #\')(string-set! rv(#{1-}# len)#\')(let loop((put(#{1+}# left-pos))(ls cuts))(if(null? ls)(sql-pre rv)(let*((pair(car ls))(one(car pair))(two(cdr pair))(end(+ put(- two one)))(tail(cdr ls)))(substring-move! s one two rv put)(or(null? tail)(string-set! rv end #\'))(loop(#{1+}# end)tail))))))
(define (fs s . args)(apply simple-format #f s args))
(define string-xrep(or(let((dq(string #\"))(ugh(char-set-filter(lambda(ch)(string-prefix? "\"\\x"(object->string(string ch))))(if(< 256(char-set-size char-set:full))(ucs-range->char-set 0 256)char-set:full))))(and(positive?(char-set-size ugh))(let((v(make-vector 256)))(define(escape ch)(vector-ref v(char->integer ch)))(set! ugh(ucs-range->char-set 127 256 #t(char-set-union(char-set #\\ #\")ugh)))(char-set-for-each(lambda(ch)(vector-set! v(char->integer ch)(case ch((#\\)"\\\\")((#\")"\\\"")(else(string ch)))))ugh)(lambda(s)(let loop((acc(list dq))(start 0))(cond((string-index s ugh start)=>(lambda(idx)(loop(cons*(escape(string-ref s idx))(substring/shared s start idx)acc)(#{1+}# idx))))((zero? start)(object->string s))(else(string-concatenate-reverse(cons(substring/shared s start)acc)dq))))))))object->string))
(define(idquote id)(sql-pre(let*((s(if(symbol? id)(symbol->string id)id))(ra(string-index s #\[))(dot(string-index s #\.)))(define(from beg)(substring/shared s beg))(define(xsub beg end)(string-xrep(substring/shared s beg end)))(cond((not(or ra dot))(string-xrep s))((and dot(not ra))(string-append(xsub 0 dot)"."(let((after(#{1+}# dot)))((if(and(=(#{1-}#(string-length s))after)(char=? #\*(string-ref s after)))identity string-xrep)(from after)))))((and ra(not dot))(string-append(xsub 0 ra)(from ra)))(#t(string-append(xsub 0 dot)"."(xsub(#{1+}# dot)ra)(from ra)))))))
(define(maybe-dq sym)(if(eq?  '* sym)sym(idquote sym)))
(define(list-sep-proc sep)(lambda (proc ls . more-ls)(if(null? ls)ls(let*((ls(if(null? more-ls)(map proc ls)(apply map proc ls more-ls)))(rv(list(car ls))))(let loop((tail(cdr ls))(tp rv))(cond((null? tail)rv)(else(set-cdr! tp(list sep(car tail)))(loop(cdr tail)(cddr tp)))))))))
(define andsep(list-sep-proc #:AND))
(define orsep(list-sep-proc #:OR))
(define commasep(list-sep-proc #:%COMMA))
(define(as one two)(list one #:AS two))
(define (paren . x) `(#:%LPAREN  ,@x #:%RPAREN))
(define (make-comma-separated-tree proc ls . opts)((if(and(not(null? opts))(car opts))paren identity)(if(and(not(null? opts))(not(null?(cdr opts))))(apply commasep proc ls(cdr opts))(commasep proc ls))))
(define any/all-rx(make-regexp "^a(ny)|(ll)--"))
(define(expr tree)(define(add-noise! op rest)(define(when-then-else branch)(let((val(car branch))(res(cadr branch)))(if(eq?  'else val)(list #:ELSE(expr res))(list #:WHEN(expr val)#:THEN(expr res)))))(case op((and)(paren(andsep expr rest)))((or)(paren(orsep expr rest)))((case)(list #:CASE(expr(car rest))(map when-then-else(cdr rest))#:END))((cond)(list #:CASE(map when-then-else rest)#:END))((if)(list #:CASE(expr(car rest))(map when-then-else `((#t ,(cadr rest))(#f ,(caddr rest))))#:END))((::)(list #:CAST(paren(as(expr(cadr rest))(car rest)))))((in/set)(list(expr(car rest))#:IN(paren(commasep expr(cdr rest)))))((between)(paren(expr(car rest))#:BETWEEN(expr(cadr rest))#:AND(expr(caddr rest))))(else(cond((hashq-ref ==infix-operations op)(paren((list-sep-proc op)expr rest)))((hashq-ref ==postfix-operations op)(paren(expr(car rest))op))((and(hashq-ref ==kw-over-commas op)(or-map keyword? rest))(list op(paren(map(lambda(x)(if(keyword? x)x(expr x)))rest))))((regexp-exec any/all-rx(symbol->string op))=>(lambda(m)(let((s(vector-ref m 0)))(paren(expr(car rest))(sql-pre(substring s 5))(if(char=? #\n(string-ref s 1))#:ANY #:ALL)(paren(cadr rest))))))(else(list op(paren(commasep expr rest))))))))(cond((eq? #t tree)(sql-pre "'t'"))((eq? #f tree)(sql-pre "'f'"))((string? tree)(if(--preformatted tree)tree(sql-quote tree)))((symbol? tree)(maybe-dq tree))((pair? tree)(add-noise!(car tree)(cdr tree)))(else tree)))
(define(make-WHERE-tree condition)(list #:WHERE(expr condition)))
(define(make-GROUP-BY-tree expressions)(list #:GROUP-BY(commasep expr expressions)))
(define(make-HAVING-tree conditions)(list #:HAVING(commasep expr conditions)))
(define(make-ORDER-BY-tree orderings)(list #:ORDER-BY(commasep(lambda(ord)(or(pair? ord)(error "bad ordering:" ord))(list(let((by(cadr ord)))(cond((integer? by)by)((symbol? by)(maybe-dq by))(else(expr by))))(case(car ord)((< #:ASC #:asc)#:ASC)((> #:DESC #:desc)#:DESC)(else(list #:USING(car ord))))))orderings)))
(define(make-SELECT/COLS-tree cols)(commasep(lambda(x)(cond((number? x)x)((symbol? x)(maybe-dq x))((and(pair? x)(string?(car x)))(as(expr(cdr x))(sql-pre(string-xrep(car x)))))((pair? x)(expr x))(else(error "bad col spec:" x))))cols))
(define(make-FROM-tree items)(define(one x)(cond((symbol? x)(maybe-dq x))((and(pair? x)(keyword?(car x)))(hairy x))((and(pair? x)(symbol?(cdr x)))(as(maybe-dq(cdr x))(maybe-dq(car x))))(else(error "bad from spec:" x))))(define(hairy x)(let((rest(cdr x)))(define(parse+make-join-tree type)(define(bad!)(error "bad join spec:" rest))(or(pair? rest)(bad!))(let((nat #f)(jcond(car rest)))(cond((not jcond))((and(keyword? jcond)(eq? #:natural jcond))(set! nat #:NATURAL)(set! jcond #f))((pair? jcond)(or(pair?(cdr jcond))(bad!))(set! jcond(case(car jcond)((#:using)(cons #:USING(paren(commasep one(cdr jcond)))))((#:on)(list #:ON(expr(cadr jcond))))(else(bad!)))))(else(bad!)))(set! rest(cdr rest))(paren(one(car rest))(or nat '())type #:JOIN(one(cadr rest))(or jcond '()))))(case(car x)((#:join)(set! rest(cons #f rest))(parse+make-join-tree '()))((#:left-join)(parse+make-join-tree #:LEFT))((#:right-join)(parse+make-join-tree #:RIGHT))((#:full-join)(parse+make-join-tree #:FULL))(else(error "unrecognized:"(car x))))))(list #:FROM(commasep one items)))
(define(make-SELECT/FROM/COLS-tree froms cols)(list #:SELECT(make-SELECT/COLS-tree cols)(if froms(make-FROM-tree froms) '())))
(define(parse+make-SELECT/tail-tree plist)(let((acc(list '())))(let loop((ls plist)(tp acc))(if(null? ls)(cdr acc)(let*((kw(car ls))(mk(case kw((#:from)make-FROM-tree)((#:where)make-WHERE-tree)((#:group-by)make-GROUP-BY-tree)((#:having)make-HAVING-tree)((#:order-by)make-ORDER-BY-tree)((#:limit)(lambda(n)(list #:LIMIT n)))((#:offset)(lambda(n)(list #:OFFSET n)))(else(error "bad keyword:" kw)))))(and(null?(cdr ls))(error "lonely keyword:" kw))(loop(cddr ls)(cond((cadr ls)=>(lambda(x)(set-cdr! tp(list(mk x)))(cdr tp)))(else tp))))))))
(define (parse+make-SELECT-tree composition cols/subs . tail)(define (compose . type)((if(null? tail)identity paren)((list-sep-proc type)(lambda(x)(paren(apply parse+make-SELECT-tree x)))cols/subs)))(list(case composition((#t)(list #:SELECT(make-SELECT/COLS-tree cols/subs)))((#:union)(compose #:UNION))((#:union-all)(compose #:UNION #:ALL))((#:intersect)(compose #:INTERSECT))((#:intersect-all)(compose #:INTERSECT #:ALL))((#:except)(compose #:EXCEPT))((#:except-all)(compose #:EXCEPT #:ALL))(else(error "bad composition:" composition)))(parse+make-SELECT/tail-tree tail)))
(define (sql<-trees . trees)(define(out x)(cond((keyword? x)(display(case x((#:%LPAREN)"(")((#:%RPAREN)")")((#:%COMMA)",")((#:%SEMIC)";")((#:ORDER-BY)"\nORDER BY")((#:GROUP-BY)"\nGROUP BY")((#:FROM #:WHERE)(fs "\n~A"(keyword->symbol x)))(else(keyword->symbol x)))))((symbol? x)(display(hashq-ref ==display-aliases x x)))((or(string? x)(number? x))(display x))((pair? x)(out(car x))(or(null?(cdr x))(eq? #:%LPAREN(car x))(memq(cadr x) '(#:%RPAREN #:%COMMA #:%SEMIC))(display " "))(out(cdr x)))((null? x))(else(error "bad tree component:" x))))(sql-pre(with-output-to-string(lambda()(out trees)))))
(define (sql-command<-trees . trees)(apply sql<-trees trees(list #:%SEMIC)))