From 7c50113ced99f689712d456b895d93bfa819db01 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Sat, 8 Apr 2017 06:17:26 -0400 Subject: [PATCH] db: move some non-essential code to db-lib pkg Also provide more from private modules to allow impl sharing. --- racket/collects/db/private/generic/common.rkt | 2 +- .../collects/db/private/generic/functions.rkt | 431 ++---------------- racket/collects/db/private/pre.rkt | 21 +- 3 files changed, 54 insertions(+), 400 deletions(-) diff --git a/racket/collects/db/private/generic/common.rkt b/racket/collects/db/private/generic/common.rkt index 1cb337e2f2..8d69f33734 100644 --- a/racket/collects/db/private/generic/common.rkt +++ b/racket/collects/db/private/generic/common.rkt @@ -7,6 +7,7 @@ dbsystem-base% locking% debugging% + disconnect% transactions% statement-cache% isolation-symbol->string @@ -428,7 +429,6 @@ (define statement-cache% (class transactions% - (init-field [cache-statements 'in-transaction]) (inherit call-with-lock get-tx-status check-valid-tx-status diff --git a/racket/collects/db/private/generic/functions.rkt b/racket/collects/db/private/generic/functions.rkt index 47d7d47e53..ef9e7340f6 100644 --- a/racket/collects/db/private/generic/functions.rkt +++ b/racket/collects/db/private/generic/functions.rkt @@ -1,43 +1,11 @@ #lang racket/base (require racket/vector racket/class - racket/promise - "interfaces.rkt" (only-in "prepared.rkt") - (only-in "sql-data.rkt" sql-null sql-null?)) -(provide connected? - disconnect - connection-dbsystem - dbsystem-name - dbsystem-supported-types - prop:statement - statement? - bind-prepared-statement - prepared-statement-parameter-types - prepared-statement-result-types - virtual-statement? - (rename-out [virtual-statement* virtual-statement]) - query-rows - query-list - query-row - query-maybe-row - query-value - query-maybe-value - query-exec - query - in-query - in-query-helper ;; for contracted in-query macro in db/base - prepare - start-transaction - commit-transaction - rollback-transaction - call-with-transaction - in-transaction? - needs-rollback? - list-tables - table-exists? - group-rows - rows->dict) + "interfaces.rkt") +(provide (all-defined-out)) + +;; See also db-lib:db/private/generic/functions2 ;; == Administrative procedures @@ -47,21 +15,7 @@ (define (disconnect x) (send x disconnect)) -(define (connection-dbsystem x) - (send x get-dbsystem)) - -(define (dbsystem-name x) - (send x get-short-name)) - -(define (dbsystem-supported-types x) - ;; FIXME: make version sensitive? - (send x get-known-types +inf.0)) - -;; == Misc procedures - -;; Value of prop:statement should be a function from struct instance to statement. -(define-values (prop:statement prop:statement? prop:statement-ref) - (make-struct-type-property 'prop:statement)) +;; == Statements (define (statement? x) (or (string? x) @@ -69,41 +23,36 @@ (statement-binding? x) (prop:statement? x))) -(define (bind-prepared-statement pst params) - (send pst bind 'bind-prepared-statement params)) - -(define (prepared-statement-parameter-types pst) - (send pst get-param-types)) -(define (prepared-statement-result-types pst) - (send pst get-result-types)) +;; prop:statement : property of (Self Connection -> Statement) +(define-values (prop:statement prop:statement? prop:statement-ref) + (make-struct-type-property 'prop:statement)) ;; A virtual-statement is: ;; - (virtual-statement table gen) ;; where table is a weak-hasheq[connection => prepared-statement] ;; and gen is (dbsystem -> string) -(struct virtual-statement (table gen) - #:property prop:statement - (lambda (stmt c) - (let* ([table (virtual-statement-table stmt)] - [gen (virtual-statement-gen stmt)] - [base-c (send c get-base)]) - (let ([table-pst (and base-c (hash-ref table base-c #f))]) - (or table-pst - (let* ([sql-string (gen (send c get-dbsystem))] - ;; FIXME: virtual-connection:prepare1 handles - ;; fsym = 'virtual-statement case specially - [pst (prepare1 'virtual-statement c sql-string #f)]) - (hash-set! table base-c pst) - pst)))))) +(define-struct virtual-statement (table gen) + #:omit-define-syntaxes + #:property prop:statement + (lambda (stmt c) + (let* ([table (virtual-statement-table stmt)] + [gen (virtual-statement-gen stmt)] + [base-c (send c get-base)]) + (let ([table-pst (and base-c (hash-ref table base-c #f))]) + (or table-pst + (let* ([sql-string (gen (send c get-dbsystem))] + ;; FIXME: virtual-connection:prepare1 handles + ;; fsym = 'virtual-statement case specially + [pst (prepare1 'virtual-statement c sql-string #f)]) + (hash-set! table base-c pst) + pst)))))) -(define virtual-statement* - (let ([virtual-statement - (lambda (gen) - (virtual-statement (make-weak-hasheq) - (if (string? gen) (lambda (_) gen) gen)))]) - virtual-statement)) +(define (virtual-statement gen) + (make-virtual-statement (make-weak-hasheq) + (if (string? gen) (lambda (_) gen) gen))) -;; == Query procedures + +;; == Query helper procedures ;; query1 : connection symbol Statement -> QueryResult (define (query1 c fsym stmt) @@ -144,8 +93,7 @@ (let ([stmt* ((prop:statement-ref stmt) stmt c)]) (compose-statement fsym c stmt* args checktype))] [(or (pair? args) - (prepared-statement? stmt) - (virtual-statement? stmt)) + (prepared-statement? stmt)) (let ([pst (cond [(string? stmt) (prepare1 fsym c stmt #t)] @@ -159,19 +107,12 @@ [else ;; no args, and stmt is either string or statement-binding stmt])) -;; Query API procedures +;; == Query API procedures -;; query-rows : connection Statement arg ... -> (listof (vectorof 'a)) -(define (query-rows c sql - #:group [group-fields-list null] - #:group-mode [group-mode null] - . args) +;; query-rows0 : connection Statement arg ... -> (listof (vectorof 'a)) +(define (query-rows0 c sql . args) (let* ([sql (compose-statement 'query-rows c sql args 'rows)] - [result (query/rows c 'query-rows sql #f)] - [result - (cond [(not (null? group-fields-list)) - (group-rows-result* 'query-rows result group-fields-list group-mode)] - [else result])]) + [result (query/rows c 'query-rows sql #f)]) (rows-result-rows result))) ;; query-list : connection Statement arg ... -> (listof 'a) @@ -224,83 +165,17 @@ (let ([sql (compose-statement 'query c sql args #f)]) (query1 c 'query sql))) -;; ======================================== - -(define (in-query c stmt - #:fetch [fetch-size +inf.0] - #:group [grouping-fields null] - #:group-mode [group-mode null] - . args) - (apply in-query-helper #f c stmt - #:fetch fetch-size - #:group grouping-fields - #:group-mode group-mode - args)) - -(define (in-query-helper vars c stmt - #:fetch [fetch-size +inf.0] - #:group [grouping-fields null] - #:group-mode [group-mode null] - . args) - (when (and (not (null? grouping-fields)) - (< fetch-size +inf.0)) - (error 'in-query "cannot apply grouping to cursor (finite fetch-size)")) - (let* ([check - ;; If grouping, can't check expected arity. - ;; FIXME: should check header includes named fields - (if (null? grouping-fields) vars #f)] - [stmt (compose-statement 'in-query c stmt args (or check 'rows))]) - (cond [(eqv? fetch-size +inf.0) - (in-list/vector->values - (rows-result-rows - (let ([result (query/rows c 'in-query stmt check)]) - (if (null? grouping-fields) - result - (group-rows-result* 'in-query result grouping-fields group-mode)))))] - [else - (let ([cursor (query/cursor c 'in-query stmt check)]) - (in-list-generator/vector->values - (lambda () (send c fetch/cursor 'in-query cursor fetch-size))))]))) - -(define (in-list/vector->values vs) - (make-do-sequence - (lambda () - (values (lambda (p) (vector->values (car p))) - cdr - vs - pair? #f #f)))) - -(define (in-list-generator/vector->values fetch-proc) - ;; fetch-proc : symbol nat -> (U list #f) - ;; state = #f | (cons vector (U state (promise-of state))) - - ;; more-promise : -> (promise-of state) - (define (more-promise) - (delay (let ([more (fetch-proc)]) - ;; note: improper append, list onto promise - (and more (append more (more-promise)))))) - - (make-do-sequence - (lambda () - (values (lambda (p) (vector->values (car p))) - (lambda (p) - (let ([next (cdr p)]) (if (promise? next) (force next) next))) - (force (more-promise)) - pair? #f #f)))) - -;; ======================================== +;; == Prepare (define (prepare c stmt) ;; FIXME: handle non-string statements (prepare1 'prepare c stmt #f)) -;; ---- - (define (prepare1 fsym c stmt close-on-exec?) ;; stmt is string (send c prepare fsym stmt close-on-exec?)) -;; ======================================== +;; == Transactions (define (start-transaction c #:isolation [isolation #f] @@ -333,239 +208,3 @@ (define (needs-rollback? c) (eq? (send c transaction-status 'needs-rollback?) 'invalid)) - -;; ======================================== - -;; list-tables : ... -> (listof string) -;; - lists unqualified table/view/etc names in search path (omit system tables, if possible). -;; Maybe it would be better to just search the current schema only? -;; or maybe mode = 'current | 'search | 'current-or-search (default) -;; - lists unqualified table/view/etc names for given schema (and/or catalog?) -;; - Add option to include system tables? -(define (list-tables c - #:schema [schema 'search-or-current]) - (send c list-tables 'list-tables schema)) - -(define (table-exists? c table-name - #:schema [schema 'search-or-current] - #:case-sensitive? [cs? #f]) - (let ([tables (send c list-tables 'table-exists? schema)]) - (for/or ([table (in-list tables)]) - (if cs? - (string=? table-name table) - (string-ci=? table-name table))))) - -;; list-tables* : ... -> (listof vector) -;; Return full catalog/schema/table/type list. - -;; ======================================== - -;; FIXME: add 'assume-sorted optimization option? - -(define (group-rows result - #:group key-fields-list - #:group-mode [group-mode null]) - (when (null? key-fields-list) - (error 'group-rows "expected at least one grouping field set")) - (group-rows-result* 'group-rows result key-fields-list group-mode)) - -(define (group-rows-result* fsym result key-fields-list group-mode) - (let* ([invert-outer? (not (or (memq 'preserve-null group-mode) - ;; old flag, deprecated: - (memq 'preserve-null-rows group-mode)))] - [as-list? (memq 'list group-mode)] - [headers (rows-result-headers result)] - [total-fields (length headers)] - [name-map (headers->name-map headers)] - [fields-used (make-vector total-fields #f)] - [key-indexes-list - (group-list->indexes fsym name-map total-fields fields-used key-fields-list)] - [residual-length - (for/sum ([x (in-vector fields-used)]) (if x 0 1))]) - (when (= residual-length 0) - (raise-arguments-error fsym "cannot group by all fields" - "grouping field sets" key-fields-list)) - (when (and (> residual-length 1) as-list?) - (raise-arguments-error fsym "expected exactly one residual field when #:group-mode is 'list" - "grouping field sets" key-fields-list - "residual field count" residual-length)) - (let* ([initial-projection - (for/vector #:length total-fields ([i (in-range total-fields)]) i)] - [headers - (group-headers (list->vector headers) - initial-projection - key-indexes-list)] - [rows - (group-rows* fsym - (rows-result-rows result) - initial-projection - key-indexes-list - invert-outer? - as-list?)]) - (rows-result headers rows)))) - -(define (headers->name-map headers) - (for/hash ([header (in-list headers)] - [i (in-naturals)] - #:when (assq 'name header)) - (values (cdr (assq 'name header)) i))) - -(define (group-list->indexes fsym name-map total-fields fields-used key-fields-list) - (let ([key-fields-list (if (list? key-fields-list) key-fields-list (list key-fields-list))]) - (for/list ([key-fields (in-list key-fields-list)]) - (group->indexes fsym name-map total-fields fields-used key-fields)))) - -(define (group->indexes fsym name-map total-fields fields-used key-fields) - (let ([key-fields (if (vector? key-fields) key-fields (vector key-fields))]) - (for/vector ([key-field (in-vector key-fields)]) - (grouping-field->index fsym name-map total-fields fields-used key-field)))) - -(define (grouping-field->index fsym name-map total-fields fields-used key-field) - (let ([key-index - (cond [(string? key-field) - (hash-ref name-map key-field #f)] - [else key-field])]) - (when (string? key-field) - (unless key-index - (raise-arguments-error fsym "bad grouping field" - "given" key-field - "available" (sort (hash-keys name-map) string residual rows with all NULL fields are dropped. - (cond [(null? key-indexes-list) - ;; Apply projection to each row - (cond [as-list? - (unless (= (vector-length projection) 1) - (error/internal - fsym - "list mode requires a single residual column, got ~s" - (vector-length projection))) - (let ([index (vector-ref projection 0)]) - (for/list ([row (in-list rows)]) - (vector-ref row index)))] - [else - (let ([plen (vector-length projection)]) - (for/list ([row (in-list rows)]) - (let ([v (make-vector plen)]) - (for ([i (in-range plen)]) - (vector-set! v i (vector-ref row (vector-ref projection i)))) - v)))])] - [else - (let () - (define key-indexes (car key-indexes-list)) - (define residual-projection - (vector-filter-not (lambda (index) (vector-member index key-indexes)) - projection)) - (define key-row-length (vector-length key-indexes)) - (define (row->key-row row) - (for/vector #:length key-row-length - ([i (in-vector key-indexes)]) - (vector-ref row i))) - (define (residual-all-null? row) - (for/and ([i (in-vector residual-projection)]) - (sql-null? (vector-ref row i)))) - (let* ([key-table (make-hash)] - [r-keys - (for/fold ([r-keys null]) - ([row (in-list rows)]) - (let* ([key-row (row->key-row row)] - [already-seen? (and (hash-ref key-table key-row #f) #t)]) - (unless already-seen? - (hash-set! key-table key-row null)) - (unless (and invert-outer? (residual-all-null? row)) - (hash-set! key-table key-row (cons row (hash-ref key-table key-row)))) - (if already-seen? - r-keys - (cons key-row r-keys))))]) - (for/list ([key (in-list (reverse r-keys))]) - (let ([residuals - (group-rows* fsym - (reverse (hash-ref key-table key)) - residual-projection - (cdr key-indexes-list) - invert-outer? - as-list?)]) - (vector-append key (vector residuals))))))])) - -;; ======================================== - -(define not-given (gensym 'not-given)) - -(define (rows->dict result - #:key key-field/s - #:value value-field/s - #:value-mode [value-mode null]) - (let* ([who 'rows->dict] - [headers (rows-result-headers result)] - [total-fields (length headers)] - [name-map (headers->name-map headers)] - [preserve-null? (memq 'preserve-null value-mode)] - [value-list? (memq 'list value-mode)]) - (define (make-project field/s) - (if (vector? field/s) - (let* ([indexes (group->indexes who name-map total-fields #f field/s)] - [indexes-length (vector-length indexes)]) - (lambda (v) - (for/vector #:length indexes-length ([i (in-vector indexes)]) - (vector-ref v i)))) - (let ([index (grouping-field->index who name-map total-fields #f field/s)]) - (lambda (v) (vector-ref v index))))) - (define get-key (make-project key-field/s)) - (define get-value (make-project value-field/s)) - (define ok-value? - (cond [preserve-null? (lambda (v) #t)] - [(vector? value-field/s) - (lambda (v) (not (for/or ([e (in-vector v)]) (sql-null? e))))] - [else (lambda (v) (not (sql-null? v)))])) - (for/fold ([table '#hash()]) ([row (in-list (if value-list? - (reverse (rows-result-rows result)) - (rows-result-rows result)))]) - (let* ([key (get-key row)] - [value (get-value row)] - [old-value (hash-ref table key (if value-list? '() not-given))]) - (unless (or value-list? - (eq? (hash-ref table key not-given) not-given) - ;; FIXME: okay to coalesce values if equal? - (equal? value old-value)) - (error* who "duplicate value for key" - '("key" value) key - '("values" multi value) (list old-value value))) - (if value-list? - (hash-set table key - (if (ok-value? value) - (cons value old-value) - ;; If all-NULL value, still enter key => '() into dict - old-value)) - (if (ok-value? value) - (hash-set table key value) - table)))))) diff --git a/racket/collects/db/private/pre.rkt b/racket/collects/db/private/pre.rkt index 72eb453788..a22e683d80 100644 --- a/racket/collects/db/private/pre.rkt +++ b/racket/collects/db/private/pre.rkt @@ -1,6 +1,6 @@ #lang racket/base -;; Most of db/base and db/sqlite3, used by core Racket (pre-pkg) +;; Minimal db/base and db/sqlite3, used by core Racket (pre-pkg) (require "generic/interfaces.rkt") (provide (struct-out simple-result) @@ -16,8 +16,23 @@ sql-null?) (require "generic/functions.rkt") -(provide (except-out (all-from-out "generic/functions.rkt") - in-query-helper)) +(provide connected? + disconnect + virtual-statement + (rename-out [query-rows0 query-rows]) + query-list + query-row + query-maybe-row + query-value + query-maybe-value + query-exec + query + start-transaction + commit-transaction + rollback-transaction + call-with-transaction + in-transaction? + needs-rollback?) (require "sqlite3/main.rkt") (provide sqlite3-connect