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

(define-module(database postgres-table)#:export(pgtable-manager pgtable-worker compile-outspec)#:use-module((ice-9 common-list)#:select(find-if pick-mappings remove-if))#:use-module((database postgres)#:select(pg-connection? pg-connectdb pg-finish pg-exec pg-ntuples pg-nfields pg-fname pg-getvalue))#:use-module((database postgres-types)#:select(dbcoltype-lookup dbcoltype:stringifier dbcoltype:default dbcoltype:objectifier))#:use-module((database postgres-col-defs)#:select(column-name type-name type-options validate-def objectifiers)#:renamer(symbol-prefix-proc  'def:))#:use-module((database postgres-qcons)#:select(sql-pre sql-pre? sql-quote string-xrep (make-comma-separated-tree . cseptree) make-WHERE-tree make-SELECT/FROM/COLS-tree parse+make-SELECT/tail-tree sql<-trees sql-command<-trees))#:use-module((database postgres-resx)#:select(result->object-alist result->object-alists result->object-rows))#:re-export(sql-pre))
(define compiled-outspec?(make-object-property))
(define ohints(make-object-property))
(define(compile-outspec spec defs)(define(bad-select-part s)(error "bad select part:" s))(let((objectifiers '()))(define(push! type)(set! objectifiers(cons(dbcoltype:objectifier(or(dbcoltype-lookup type)(bad-select-part type)))objectifiers)))(define(munge x)(cond((symbol? x)(or(and=>(assq x defs)(lambda(def)(push!(def:type-name def))))(bad-select-part x))x)((and(list? x)(= 3(length x)))(apply-to-args x(lambda(type title expr)(and(string? expr)(bad-select-part expr))(push!(cond((symbol? type)type)((eq? #f type) 'text)((and(eq? #t type)(or(assq expr defs)(bad-select-part expr)))=> def:type-name)((and(pair? type)(eq? #t(car type))(symbol?(cdr type))(or(assq(cdr type)defs)(bad-select-part(cdr type))))=> def:type-name)(else(bad-select-part type))))(if title(cons title expr)expr))))(else(bad-select-part x))))(let*((s(map munge(cond((eq? #t spec)(map def:column-name defs))((pair? spec)spec)(else(list spec)))))(rv(cons(reverse! objectifiers)s)))(set!(compiled-outspec? rv)#t)rv)))
(define(compiled-outspec?-extract obj)(and(compiled-outspec? obj)obj))
(define(pgtable-manager db-spec table-name defs)(define (fmt . args)(apply simple-format #f args))(define(symbol->qstring symbol)(string-xrep(symbol->string symbol)))(or(and(pair? defs)(not(null? defs)))(error "malformed defs:" defs))(for-each(lambda(def)(def:validate-def def dbcoltype-lookup))defs)(let*((conn(cond((pg-connection? db-spec)db-spec)((string? db-spec)(pg-connectdb(fmt(if(or(string-null? db-spec)(string-index db-spec #\=))"~A" "dbname=~A")db-spec)))(else(error "bad db-spec:" db-spec))))(trace-exec #f)(qstring-colnames(map(lambda(name)(cons name(symbol->qstring name)))(map def:column-name defs)))(objectifiers(def:objectifiers defs))(dq-table-name(string-xrep table-name))(ncols(length defs))(typenames(map def:type-name defs))(insert/pre(delay(sql<-trees #:INSERT #:INTO dq-table-name)))(delete-rows/pre(delay(sql<-trees #:DELETE #:FROM dq-table-name)))(update-col/pre(delay(sql<-trees #:UPDATE dq-table-name #:SET)))(froms(list(string->symbol table-name))))(define(col-defs defs cols)(map(lambda(col)(or(find-if(lambda(def)(eq?(def:column-name def)col))defs)(error "invalid field name:" col)))cols))(define (xt . args)(let((s(apply sql-command<-trees args)))(cond(trace-exec(display s trace-exec)(newline trace-exec)))(pg-exec conn s)))(define(res->foo-proc proc)(lambda(res)(proc res(or(ohints res)objectifiers))))(define(check-col-count who exp got)(or(= exp got)(error(fmt "column count mismatch for ~A ~A: expected ~A, got ~A" who dq-table-name exp got))))(define(->db-insert-string db-col-type x)(or(and(sql-pre? x)x)(and(keyword? x)x)(let*((def(dbcoltype-lookup db-col-type))(s(or(false-if-exception((dbcoltype:stringifier def)x))(dbcoltype:default def))))(or(string? s)(error "not a string:" s))(sql-pre(sql-quote s)))))(define(do-insert cols data)(xt(force insert/pre)(if cols(cseptree symbol->qstring cols #t) '())#:VALUES(cseptree ->db-insert-string(if cols(map def:type-name(col-defs defs cols))typenames)#t data)))(define(drop)(map(lambda(x)(xt #:DROP x)) `((#:TABLE  ,dq-table-name) ,@(pick-mappings(lambda(def)(and(eq?  'serial(def:type-name def)) `(#:SEQUENCE ,(fmt "~A_~A_seq" table-name(def:column-name def)))))defs))))(define(create)(xt #:CREATE #:TABLE dq-table-name(cseptree(lambda(def)(list(symbol->qstring(def:column-name def))(symbol->string(def:type-name def))(def:type-options def)))defs #t)))(define (insert-values . data)(check-col-count #:insert-values ncols(length data))(do-insert #f data))(define (insert-col-values cols . data)(check-col-count #:insert-col-values(length cols)(length data))(do-insert cols data))(define(insert-alist alist)(do-insert(map car alist)(map cdr alist)))(define(delete-rows where-condition)(xt(force delete-rows/pre)(make-WHERE-tree where-condition)))(define(update-col cols data where-condition)(xt(force update-col/pre)(cseptree(lambda(def val)(list(assq-ref qstring-colnames(def:column-name def))#:=(->db-insert-string(def:type-name def)val)))(col-defs defs cols)#f data)(make-WHERE-tree where-condition)))(define (select outspec . rest-clauses)(let*((hint+cols(or(compiled-outspec?-extract outspec)(compiled-outspec?-extract(compile-outspec outspec defs))))(res(xt(make-SELECT/FROM/COLS-tree froms(cdr hint+cols))(cond((null? rest-clauses) '())(else(parse+make-SELECT/tail-tree rest-clauses))))))(set!(ohints res)(car hint+cols))res))(let((tuples-result->object-alist(res->foo-proc result->object-alist))(tuples-result->alists(res->foo-proc result->object-alists))(tuples-result->rows(res->foo-proc result->object-rows)))(define(update-col-alist alist where-condition)(update-col(map car alist)(map cdr alist)where-condition))(define(die!)(set! tuples-result->rows #f)(set! tuples-result->alists #f)(set! tuples-result->object-alist #f)(set! trace-exec #f)(pg-finish conn)(set! conn #f))(lambda(choice)(or conn(error "dead connection"))(case(if(symbol? choice)(symbol->keyword choice)choice)((#:k)(lambda(var)(case var((#:connection)conn)((#:table-name)table-name)((#:col-defs)defs)(else(error "bad var:" var)))))((#:drop)drop)((#:create)create)((#:insert-values)insert-values)((#:insert-col-values)insert-col-values)((#:insert-alist)insert-alist)((#:delete-rows)delete-rows)((#:update-col)update-col)((#:update-col-alist)update-col-alist)((#:select)select)((#:tuples-result->object-alist)tuples-result->object-alist)((#:tuples-result->alists)tuples-result->alists)((#:tuples-result->rows)tuples-result->rows)((#:trace-exec)(lambda(op)(or(not op)(output-port? op)(error "not an output port:" op))(set! trace-exec op)))((#:finish)die!)(else(error "bad choice:" choice)))))))
(define(pgtable-worker db-spec table-name defs)(let((M(pgtable-manager db-spec table-name defs)))(lambda (command . args)(let((proc(M command)))(if(procedure? proc)(apply proc args)(error "command does not yield a procedure:" command))))))