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

(define-module(database postgres-gxrepl)#:export(gxrepl)#:use-module((ice-9 rdelim)#:select(read-line write-line))#:use-module((database postgres)#:select(pg-connection? pg-finish pg-get-db pg-exec pg-result? pg-result-status pg-error-message pg-result-error-message pg-connectdb pg-make-print-options pg-print))#:use-module((database postgres-qcons)#:select(parse+make-SELECT-tree sql-command<-trees))#:autoload(ice-9 pretty-print)(pretty-print))
(define *comma-commands* '())
(define-macro (defcc formals . body) `(set! *comma-commands*(assq-set! *comma-commands* ' ,(car formals)(lambda ,(cdr formals) ,@body))))
(define (fs s . args)(apply simple-format #f s args))
(define --for-display(make-object-property))
(define(for-display s)(set!(--for-display s)#t)s)
(defcc (help . command) "Display a list of commands, or full help for COMMAND if specified."(define(get-doc proc yes)(cond((procedure-documentation proc)=> yes)(else "(no docs)")))(for-display(cond((null? command)(apply string-append(map(lambda(ent)(fs "~A~A-- ~A~A"(car ent)#\tab(get-doc(cdr ent)(lambda(doc)(cond((string-index doc #\newline)=>(lambda(cut)(substring doc 0 cut)))(else doc))))#\newline))(reverse *comma-commands*))))((assq-ref *comma-commands*(car command))=>(lambda(proc)(get-doc proc identity)))(else "no such command"))))
(define (sqlsel cols . rest)(sql-command<-trees(apply parse+make-SELECT-tree #t cols rest)))
(defcc (obvious . something) "Life, the universe, and everything!\nOptional arg CC names a comma-command to make obvious (pretty-print its\nsource).  Note that display of `(A . (B C))' shows up as `(A B C)'; that\nis normal."(cond((and(not(null? something))(assq-ref *comma-commands*(car something)))=>(lambda(proc)(for-display(with-output-to-string(lambda()(pretty-print(let((all(procedure-source proc)))(cons*(car all)(cadr all)(cdddr all)))))))))(else(sqlsel `(( ,(if(null? something)"obvious"(fs "~A"(car something)))+ 6(* 6 6)))))))
(defcc (dt . which) "Describe columns in table TABLE-NAME.\nOutput includes the name, type, length, mod (?), and other information\nextracted from system tables `pg_class', `pg_attribute' and `pg_type'."(if(null? which)(sqlsel '(("schema" . n.nspname) ("name" . c.relname)("type" case c.relkind("r" "table")("v" "view")("i" "index")("S" "sequence")("s" "special")(else "huh?"))("owner" . u.usename))#:from '((#:left-join(#:on(= n.oid c.relnamespace))(#:left-join(#:on(= u.usesysid c.relowner))(c . pg_catalog.pg_class) (u . pg_catalog.pg_user))(n . pg_catalog.pg_namespace)))#:where '(and(not(= n.nspname "pg_catalog"))(not(= n.nspname "pg_toast")))#:order-by '((< 1)(< 2)))(sqlsel '(("name" . a.attname) ("type" . t.typname)(" bytes" if(< 0 a.attlen)(to_char a.attlen "99999")"varies")("mod" to_char a.atttypmod "999")("etc" ||(if a.attnotnull "NOT NULL" "NULL ok")", "(if a.atthasdef "has defs" "no defs")))#:from '((c . pg_class) (a . pg_attribute) (t . pg_type))#:where `(and(= c.relname ,(symbol->string(car which)))(> a.attnum 0)(= a.attrelid c.oid)(= a.atttypid t.oid))#:order-by '((< a.attnum)))))
(defcc(gxrepl conn)"Run a recursive repl, talking to database CONN.\nExiting from the recursive repl returns to this one."(gxrepl(symbol->string conn))(for-display "\nExiting recursive repl."))
(define(gxrepl conn)(define(conn-get prop)(object-property conn prop))(define(conn-put prop value)(set-object-property! conn prop value))(define(make-prompt style)(case style((#:ellipse)"... ")((#:conn)(fs "(~A) "(pg-get-db conn)))))(defcc (conn . db-name) "Connect to DB-NAME, or reconnect if not specified."(set! db-name(if(null? db-name)(pg-get-db conn)(car db-name)))(for-display(fs "~Aonnecting to: ~A ... ~A."(if(equal? db-name(pg-get-db conn))"Rec" "C")db-name(cond((pg-connectdb(string-append "dbname=" db-name))=>(lambda(good)(set! conn good)"OK"))(else "FAILED")))))(defcc (echo . setting) "Toggle echoing of SQL command prior to sending to `pg-exec'.\nOptional arg SETTING turns on echoing if a positive number."(let((new(cond((null? setting)(not(conn-get #:gxrepl-echo)))((number?(car setting))(positive?(car setting)))(else #f))))(conn-put #:gxrepl-echo new)(for-display(fs "SQL command echoing now ~A."(if new "ON" "OFF")))))(defcc (fix part . set) "Fix query PART to be SET..., or clear that part if SET is 0 (zero).\nWhen a part is fixed, it is used (unless overridden) in the \",fsel\"\ncomma-command.  PART is a keyword, one of #:cols, #:from, #:where,\n#:where/combiner, #:group-by, #:having, #:order-by, #:limit or #:offset.\nSET is a space-separated list of elements.\n\nIf PART is #:cols, each element of SET is either a column name, possibly\nqualified by the table name with a dot, e.g., `t.oid'; a prefix-style\nSQL expression, e.g., `(to_char 42 \"999\")'; or pair with the car a\nstring and the cdr one of the previous options, e.g., `(\"id\" . t.oid)'.\n\nIf PART is #:from, each element of SET is either the name of a table,\nor a pair in the form (ALIAS . TABLE-NAME), e.g., `(t . pg_type)'.  The\nalias can be used in `outs' and `where' sets.\n\nIf PART is #:where, each element of SET is prefix-style SQL expression,\n.e.g, `(= t.oid 42)', and there is an implicit \"and\" clause surrounding\nSET.  For \"or\" behavior, fix #:where/combiner to be `or'.\n\nIf PART is #:group-by or #:having, each element of SET is a\nprefix-style SQL expression.\n\nIf PART is #:order-by, each element of SET is a list (ORDFUNC EXPR),\nwhere ORDFUNC is either `<', '>' or the name of an SQL function that\ntakes two args and returns their ordering; and EXPR is a prefix-style\nSQL expression.\n\nIf PART is #:limit or #:offset, the first element of SET specifies an integer.\n\nIf PART is `?' display all the parts and their related expressions.\nIf SET is omitted display the current value for PART."(define(new-val! check)(conn-put part(cond((null? set)(conn-get part))((equal? 0(car set))#f)((check))(else(conn-get part)))))(case part((#:where/combiner)(new-val!(lambda()(and(memq(car set) '(and or))(car set)))))((#:limit #:offset)(new-val!(lambda()(and(integer?(car set))(car set)))))((#:cols #:from #:where #:group-by #:having #:order-by)(new-val!(lambda()set)))((?)(for-display(let*((all(list #:cols #:from #:where #:where/combiner #:group-by #:having #:order-by #:limit #:offset))(set(map(lambda(part)(cond((conn-get part)=>(lambda(v)(set! all(delq! part all))(list part(make-string(- 16(string-length(symbol->string(keyword->symbol part))))#\space)(map(lambda(x)(fs " ~S" x))(if(pair? v)v(list v)))"\n")))(else '())))all)))(list set(cons(if(null? all)"(no unset parts)" "unset:")(map(lambda(part)(list " " part))all))))))(else(for-display "No such part, try \",help fix\""))))(defcc (fsel . etc) "Do a \"select\", merging fixed elements and those from ETC.\nETC is a series of zero or more column expressions, optionally followed\nby a series of keywords and related expressions.  These override those\nspecified by \",fix\".  Keywords without related expressions are ignored."(define(collect-keys ls)(let loop((ls ls)(acc(list)))(if(null? ls)(reverse! acc)(let((kw(car ls)))(let collect-one((ls(cdr ls))(partial(list)))(if(or(null? ls)(keyword?(car ls)))(loop ls(if(null? partial)acc(acons kw(reverse! partial)acc)))(collect-one(cdr ls)(cons(car ls)partial))))))))(let((fixed(map(lambda(part)(cons part(conn-get part))) '(#:limit #:offset #:cols #:from #:where #:group-by #:having #:order-by)))(oride(collect-keys(cons #:cols etc))))(define(o/f part)(or(assq-ref oride part)(assq-ref fixed part)))(cond((o/f #:cols)=>(lambda(cols)(define (decide part . massage)(list part(and=>(o/f part)(if(null? massage)identity(car massage)))))(apply sqlsel cols `( ,@(decide #:from) ,@(decide #:where(lambda(v)(cons(or(conn-get #:where/combiner) 'and)v))) ,@(decide #:group-by) ,@(decide #:having) ,@(decide #:order-by) ,@(decide #:limit) ,@(decide #:offset)))))(else(for-display "No columns selected")))))(cond((pg-connection? conn))((and(string? conn)(not(string-index conn #\=)))(set! conn(pg-connectdb(fs "dbname=~A" conn))))((string? conn)(set! conn(pg-connectdb conn)))(else(set! conn #f)))(cond((and conn(pg-connection? conn)))(else(display(pg-error-message conn))(newline)(error "connection failed")))(conn-put #:gxrepl-echo #f)(conn-put #:cols '(*))(call-with-current-continuation(lambda(return)(define (-read . ignored-args)(false-if-exception(let loop((so-far "")(prompt(make-prompt #:conn)))(display prompt)(force-output)(let*((input(let((in(read-line)))(if(eof-object? in)(return #t)in)))(line(string-append so-far input))(len(string-length line)))(cond((and(zero? len)(string-null? so-far))(loop so-far prompt))((zero? len)(loop line(make-prompt #:ellipse)))((char=? #\,(string-ref line 0))(let((cmd(with-input-from-string(fs "(~A)"(substring line 1))read)))(cond((assq-ref *comma-commands*(car cmd))=>(lambda(proc)(apply proc(cdr cmd))))(else(display(fs "~A (try ~S)\n" "unrecognized comma command" ",help"))(loop "" psql-repl-prompt)))))((string=?(substring line(#{1-}# len)len)";")line)(else(loop(string-append line " ")(make-prompt #:ellipse))))))))(define(-eval source)(cond((eof-object? source)(return #t))((and(string? source)(not(--for-display source)))(and(conn-get #:gxrepl-echo)(write-line source))(pg-exec conn source))(else source)))(define(-print res)(cond((pg-result? res)(let((status(pg-result-status res)))(if(eq?  'PGRES_TUPLES_OK status)(pg-print res(pg-make-print-options '((field-sep . " | "))))(let((msg(pg-result-error-message res)))(display status)(newline)(or(string-null? msg)(begin(display msg)(newline)))))))((--for-display res)(letrec((out(lambda(x)(if(list? x)(for-each out x)(display x)))))(out res))(newline))(else(write res)(newline))))(repl -read -eval -print)))(pg-finish conn)(set! conn #f)(gc)(if #f #f))