suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merge branch 'master' of pltgit:plt

Browse Source
This commit is contained in:
Stephen Chang 2011-09-09 02:30:24 -04:00
commit 3a44c34b39
1026 changed files with 18791 additions and 12258 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
collects/2htdp/private/checked-cell.rkt
View File

@ -68,9 +68,14 @@
(tp-error 'check-with "the test function ~a is expected to return a boolean, but it returned ~v" (tp-error 'check-with "the test function ~a is expected to return a boolean, but it returned ~v"
(object-name ok?) b)) (object-name ok?) b))
(unless b (unless b
(define check-with-name
(let ([n (symbol->string (object-name ok?))])
(if (regexp-match "check-with" n)
"handler"
n)))
(tp-error 'check-with "~a ~a ~v, which fails to pass check-with's ~a test" (tp-error 'check-with "~a ~a ~v, which fails to pass check-with's ~a test"
tag (if say-evaluated-to "evaluated to" "returned") tag (if say-evaluated-to "evaluated to" "returned")
nw (object-name ok?))) nw check-with-name))
nw)) nw))
;; Symbol Any -> Void ;; Symbol Any -> Void

5
collects/2htdp/private/clauses-spec-and-process.rkt
View File

@ -86,7 +86,10 @@
[(null? spec) #false] [(null? spec) #false]
[(or (free-identifier=? (caar spec) kw) [(or (free-identifier=? (caar spec) kw)
(free-identifier=? (caar spec) kw-alt)) (free-identifier=? (caar spec) kw-alt))
(syntax->list (cdar spec))] ; (syntax->list (cdar spec))
(for/list ([i (syntax->list (cdar spec))])
(define n (string->symbol (format "~a handler" (syntax-e (caar spec)))))
(syntax-property i 'inferred-name n))]
[else (loop (cdr spec))]))) [else (loop (cdr spec))])))
(if r ((third s) r) (fourth s))) (if r ((third s) r) (fourth s)))
Spec)) Spec))

15
collects/2htdp/tests-failed/key-error.rkt → collects/2htdp/tests/key-error.rkt
View File

@ -18,3 +18,18 @@
(unless (and hdl (cons? (regexp-match "on-tick" (second hdl)))) (unless (and hdl (cons? (regexp-match "on-tick" (second hdl))))
(error 'test "expected: \"on-tick\", actual: ~e" (second hdl)))))) (error 'test "expected: \"on-tick\", actual: ~e" (second hdl))))))
(main)) (main))
(define (my-fun x) "hi")
(with-handlers ((exn:fail?
(lambda (x)
(define msg (exn-message x))
(define hdl (regexp-match "check-with's handler test" msg))
(unless hdl
(error 'test "expected: \"check-with's handler test, error says: ~e" msg)))))
(big-bang 0
[to-draw (lambda (x) (circle 1 'solid 'red))]
[on-tick (lambda (x) (my-fun x))]
[check-with (lambda (x) (number? x))])
(raise `(bad "must fail")))

2
collects/2htdp/xtest
View File

@ -10,6 +10,7 @@ run() {
cd tests cd tests
run key-error.rkt
run bad-draw.rkt run bad-draw.rkt
run error-in-tick.rkt run error-in-tick.rkt
run error-in-draw.rkt run error-in-draw.rkt
@ -34,3 +35,4 @@ run record-stop-when.rkt
run stop-when-crash.rkt run stop-when-crash.rkt
run on-tick-universe-with-limit.rkt run on-tick-universe-with-limit.rkt
run on-tick-with-limit.rkt run on-tick-with-limit.rkt

121
collects/compiler/cm.rkt
View File

@ -675,43 +675,128 @@
(define (make-compile-lock) (define (make-compile-lock)
(define-values (manager-side-chan build-side-chan) (place-channel)) (define-values (manager-side-chan build-side-chan) (place-channel))
(struct pending (response-chan bytes)) (struct pending (response-chan zo-path died-chan-manager-side) #:transparent)
(struct running (zo-path died-chan-manager-side) #:transparent)
(define currently-locked-files (make-hash)) (define currently-locked-files (make-hash))
(define pending-requests '()) (define pending-requests '())
(define running-compiles '())
(thread (thread
(λ () (λ ()
(let loop () (let loop ()
(define req (place-channel-get manager-side-chan)) (apply
sync
(handle-evt
manager-side-chan
(λ (req)
(define command (list-ref req 0)) (define command (list-ref req 0))
(define bytes (list-ref req 1)) (define zo-path (list-ref req 1))
(define response-manager-side (list-ref req 2)) (define response-manager-side (list-ref req 2))
(define died-chan-manager-side (list-ref req 3))
(define compilation-thread-id (list-ref req 4))
(case command
[(lock)
(cond (cond
[(eq? command 'lock) [(hash-ref currently-locked-files zo-path #f)
(cond (log-info (format "compile-lock: ~s ~a already locked" zo-path compilation-thread-id))
[(hash-ref currently-locked-files bytes #f) (set! pending-requests (cons (pending response-manager-side zo-path died-chan-manager-side)
(set! pending-requests (cons (pending response-manager-side bytes)
pending-requests)) pending-requests))
(loop)] (loop)]
[else [else
(hash-set! currently-locked-files bytes #t) (log-info (format "compile-lock: ~s ~a obtained lock" zo-path compilation-thread-id))
(hash-set! currently-locked-files zo-path #t)
(place-channel-put response-manager-side #t) (place-channel-put response-manager-side #t)
(set! running-compiles (cons (running zo-path died-chan-manager-side) running-compiles))
(loop)])] (loop)])]
[(eq? command 'unlock) [(unlock)
(define (same-bytes? pending) (equal? (pending-bytes pending) bytes)) (log-info (format "compile-lock: ~s ~a unlocked" zo-path compilation-thread-id))
(define to-unlock (filter same-bytes? pending-requests)) (define (same-pending-zo-path? pending) (equal? (pending-zo-path pending) zo-path))
(set! pending-requests (filter (compose not same-bytes?) pending-requests)) (define to-unlock (filter same-pending-zo-path? pending-requests))
(set! pending-requests (filter (compose not same-pending-zo-path?) pending-requests))
(for ([pending (in-list to-unlock)]) (for ([pending (in-list to-unlock)])
(place-channel-put (pending-response-chan pending) #f)) (place-channel-put (pending-response-chan pending) #f))
(hash-remove! currently-locked-files bytes) (hash-remove! currently-locked-files zo-path)
(loop)])))) (set! running-compiles (filter (λ (a-running) (not (equal? (running-zo-path a-running) zo-path)))
running-compiles))
(loop)])))
(for/list ([running-compile (in-list running-compiles)])
(handle-evt
(running-died-chan-manager-side running-compile)
(λ (compilation-thread-id)
(define zo-path (running-zo-path running-compile))
(set! running-compiles (remove running-compile running-compiles))
(define same-zo-pending
(filter (λ (pending) (equal? zo-path (pending-zo-path pending)))
pending-requests))
(cond
[(null? same-zo-pending)
(log-info (format "compile-lock: ~s ~a died; no else waiting" zo-path compilation-thread-id))
(hash-remove! currently-locked-files zo-path)
(loop)]
[else
(log-info (format "compile-lock: ~s ~a died; someone else waiting" zo-path compilation-thread-id))
(define to-be-running (car same-zo-pending))
(set! pending-requests (remq to-be-running pending-requests))
(place-channel-put (pending-response-chan to-be-running) #t)
(set! running-compiles
(cons (running zo-path (pending-died-chan-manager-side to-be-running))
running-compiles))
(loop)]))))))))
build-side-chan) build-side-chan)
(define (compile-lock->parallel-lock-client build-side-chan) (define (compile-lock->parallel-lock-client build-side-chan [custodian #f])
(define monitor-threads (make-hash))
(define add-monitor-chan (make-channel))
(define kill-monitor-chan (make-channel))
(when custodian
(parameterize ([current-custodian custodian])
(thread
(λ ()
(let loop ()
(sync
(handle-evt add-monitor-chan
(λ (arg)
(define-values (zo-path monitor-thread) (apply values arg))
(hash-set! monitor-threads zo-path monitor-thread)
(loop)))
(handle-evt kill-monitor-chan
(λ (zo-path)
(define thd/f (hash-ref monitor-threads zo-path #f))
(when thd/f (kill-thread thd/f))
(hash-remove! monitor-threads zo-path)
(loop)))))))))
(λ (command zo-path) (λ (command zo-path)
(define compiling-thread (current-thread))
(define-values (response-builder-side response-manager-side) (place-channel)) (define-values (response-builder-side response-manager-side) (place-channel))
(place-channel-put build-side-chan (list command zo-path response-manager-side)) (define-values (died-chan-compiling-side died-chan-manager-side) (place-channel))
(when (eq? command 'lock) (place-channel-put build-side-chan (list command
(place-channel-get response-builder-side)))) zo-path
response-manager-side
died-chan-manager-side
(eq-hash-code compiling-thread)))
(cond
[(eq? command 'lock)
(define monitor-thread
(and custodian
(parameterize ([current-custodian custodian])
(thread
(λ ()
(thread-wait compiling-thread)
;; compiling thread died; alert the server
;; & remove this thread from the table
(place-channel-put died-chan-compiling-side (eq-hash-code compiling-thread))
(channel-put kill-monitor-chan zo-path))))))
(when monitor-thread (channel-put add-monitor-chan (list zo-path monitor-thread)))
(define res (place-channel-get response-builder-side))
(when monitor-thread
(unless res ;; someone else finished compilation for us; kill the monitor
(channel-put kill-monitor-chan zo-path)))
res]
[(eq? command 'unlock)
(when custodian
;; we finished the compilation; kill the monitor
(channel-put kill-monitor-chan zo-path))])))

2
collects/compiler/commands/make.rkt
View File

@ -66,7 +66,7 @@
(lambda (p) (lambda (p)
(set! did-one? #t) (set! did-one? #t)
(when (verbose) (when (verbose)
(printf " making ~s\n" (path->string p))))]) (printf " making ~s\n" p)))])
(for ([file source-files]) (for ([file source-files])
(unless (file-exists? file) (unless (file-exists? file)
(error mzc-symbol "file does not exist: ~a" file)) (error mzc-symbol "file does not exist: ~a" file))

21
collects/compiler/decompile.rkt
View File

@ -164,16 +164,20 @@
(define (decompile-module mod-form stack stx-ht) (define (decompile-module mod-form stack stx-ht)
(match mod-form (match mod-form
[(struct mod (name srcname self-modidx prefix provides requires body syntax-body unexported [(struct mod (name srcname self-modidx prefix provides requires body syntax-bodies unexported
max-let-depth dummy lang-info internal-context)) max-let-depth dummy lang-info internal-context))
(let-values ([(globs defns) (decompile-prefix prefix stx-ht)] (let-values ([(globs defns) (decompile-prefix prefix stx-ht)]
[(stack) (append '(#%modvars) stack)] [(stack) (append '(#%modvars) stack)]
[(closed) (make-hasheq)]) [(closed) (make-hasheq)])
`(module ,name .... `(module ,name ....
,@defns ,@defns
,@(map (lambda (form) ,@(for/list ([b (in-list syntax-bodies)])
(decompile-form form globs stack closed stx-ht)) (let loop ([n (sub1 (car b))])
syntax-body) (if (zero? n)
(cons 'begin
(for/list ([form (in-list (cdr b))])
(decompile-form form globs stack closed stx-ht)))
(list 'begin-for-syntax (loop (sub1 n))))))
,@(map (lambda (form) ,@(map (lambda (form)
(decompile-form form globs stack closed stx-ht)) (decompile-form form globs stack closed stx-ht))
body)))] body)))]
@ -190,18 +194,19 @@
(list-ref/protect (glob-desc-vars globs) pos 'def-vals)])) (list-ref/protect (glob-desc-vars globs) pos 'def-vals)]))
ids) ids)
,(decompile-expr rhs globs stack closed))] ,(decompile-expr rhs globs stack closed))]
[(struct def-syntaxes (ids rhs prefix max-let-depth)) [(struct def-syntaxes (ids rhs prefix max-let-depth dummy))
`(define-syntaxes ,ids `(define-syntaxes ,ids
,(let-values ([(globs defns) (decompile-prefix prefix stx-ht)]) ,(let-values ([(globs defns) (decompile-prefix prefix stx-ht)])
`(let () `(let ()
,@defns ,@defns
,(decompile-form rhs globs '(#%globals) closed stx-ht))))] ,(decompile-form rhs globs '(#%globals) closed stx-ht))))]
[(struct def-for-syntax (ids rhs prefix max-let-depth)) [(struct seq-for-syntax (exprs prefix max-let-depth dummy))
`(define-values-for-syntax ,ids `(begin-for-syntax
,(let-values ([(globs defns) (decompile-prefix prefix stx-ht)]) ,(let-values ([(globs defns) (decompile-prefix prefix stx-ht)])
`(let () `(let ()
,@defns ,@defns
,(decompile-form rhs globs '(#%globals) closed stx-ht))))] ,@(for/list ([rhs (in-list exprs)])
(decompile-form rhs globs '(#%globals) closed stx-ht)))))]
[(struct seq (forms)) [(struct seq (forms))
`(begin ,@(map (lambda (form) `(begin ,@(map (lambda (form)
(decompile-form form globs stack closed stx-ht)) (decompile-form form globs stack closed stx-ht))

4
collects/compiler/demodularizer/gc-toplevels.rkt
View File

@ -64,7 +64,7 @@
(build-graph! new-lhs rhs)] (build-graph! new-lhs rhs)]
[(? def-syntaxes?) [(? def-syntaxes?)
(error 'build-graph "Doesn't handle syntax")] (error 'build-graph "Doesn't handle syntax")]
[(? def-for-syntax?) [(? seq-for-syntax?)
(error 'build-graph "Doesn't handle syntax")] (error 'build-graph "Doesn't handle syntax")]
[(struct req (reqs dummy)) [(struct req (reqs dummy))
(build-graph! lhs dummy)] (build-graph! lhs dummy)]
@ -197,7 +197,7 @@
#f)] #f)]
[(? def-syntaxes?) [(? def-syntaxes?)
(error 'gc-tls "Doesn't handle syntax")] (error 'gc-tls "Doesn't handle syntax")]
[(? def-for-syntax?) [(? seq-for-syntax?)
(error 'gc-tls "Doesn't handle syntax")] (error 'gc-tls "Doesn't handle syntax")]
[(struct req (reqs dummy)) [(struct req (reqs dummy))
(make-req reqs (update dummy))] (make-req reqs (update dummy))]

3
collects/compiler/demodularizer/merge.rkt
View File

@ -108,7 +108,8 @@
(define (merge-module max-let-depth top-prefix mod-form) (define (merge-module max-let-depth top-prefix mod-form)
(match mod-form (match mod-form
[(struct mod (name srcname self-modidx mod-prefix provides requires body syntax-body unexported mod-max-let-depth dummy lang-info internal-context)) [(struct mod (name srcname self-modidx mod-prefix provides requires body syntax-bodies
unexported mod-max-let-depth dummy lang-info internal-context))
(define toplevel-offset (length (prefix-toplevels top-prefix))) (define toplevel-offset (length (prefix-toplevels top-prefix)))
(define topsyntax-offset (length (prefix-stxs top-prefix))) (define topsyntax-offset (length (prefix-stxs top-prefix)))
(define lift-offset (prefix-num-lifts top-prefix)) (define lift-offset (prefix-num-lifts top-prefix))

2
collects/compiler/demodularizer/module.rkt
View File

@ -24,7 +24,7 @@
(list (cons 0 requires)) (list (cons 0 requires))
new-forms new-forms
empty ; syntax-body empty ; syntax-body
(list empty empty empty) ; unexported (list) ; unexported
max-let-depth max-let-depth
(make-toplevel 0 0 #f #f) ; dummy (make-toplevel 0 0 #f #f) ; dummy
lang-info lang-info

3
collects/compiler/demodularizer/nodep.rkt
View File

@ -112,7 +112,8 @@
(define (nodep-module mod-form phase) (define (nodep-module mod-form phase)
(match mod-form (match mod-form
[(struct mod (name srcname self-modidx prefix provides requires body syntax-body unexported max-let-depth dummy lang-info internal-context)) [(struct mod (name srcname self-modidx prefix provides requires body syntax-bodies
unexported max-let-depth dummy lang-info internal-context))
(define new-prefix prefix) (define new-prefix prefix)
; Cache all the mpi paths ; Cache all the mpi paths
(for-each (match-lambda (for-each (match-lambda

2
collects/compiler/demodularizer/update-toplevels.rkt
View File

@ -10,7 +10,7 @@
(update rhs))] (update rhs))]
[(? def-syntaxes?) [(? def-syntaxes?)
(error 'increment "Doesn't handle syntax")] (error 'increment "Doesn't handle syntax")]
[(? def-for-syntax?) [(? seq-for-syntax?)
(error 'increment "Doesn't handle syntax")] (error 'increment "Doesn't handle syntax")]
[(struct req (reqs dummy)) [(struct req (reqs dummy))
(make-req reqs (update dummy))] (make-req reqs (update dummy))]

2
collects/compiler/main.rkt
View File

@ -510,7 +510,7 @@
(parameterize ([compile-notify-handler (parameterize ([compile-notify-handler
(lambda (path) (lambda (path)
(when (compiler:option:somewhat-verbose) (when (compiler:option:somewhat-verbose)
(printf " making ~s\n" (path->string path))))]) (printf " making ~s\n" path)))])
(apply compile-collection-zos source-files))] (apply compile-collection-zos source-files))]
[(cc) [(cc)
(for ([file source-files]) (for ([file source-files])

4
collects/compiler/private/mach-o.rkt
View File

@ -56,6 +56,7 @@
[link-edit-addr 0] [link-edit-addr 0]
[link-edit-offset 0] [link-edit-offset 0]
[link-edit-len 0] [link-edit-len 0]
[link-edit-vmlen 0]
[dyld-info-pos #f] [dyld-info-pos #f]
[dyld-info-offs #f]) [dyld-info-offs #f])
;; (printf "~a cmds, length 0x~x\n" cnt cmdssz) ;; (printf "~a cmds, length 0x~x\n" cnt cmdssz)
@ -82,6 +83,7 @@
(set! link-edit-64? 64?) (set! link-edit-64? 64?)
(set! link-edit-pos pos) (set! link-edit-pos pos)
(set! link-edit-addr vmaddr) (set! link-edit-addr vmaddr)
(set! link-edit-vmlen vmlen)
(set! link-edit-offset offset) (set! link-edit-offset offset)
(set! link-edit-len len) (set! link-edit-len len)
(when (link-edit-len . < . 0) (when (link-edit-len . < . 0)
@ -145,7 +147,7 @@
[out-offset (if move-link-edit? [out-offset (if move-link-edit?
link-edit-offset link-edit-offset
(+ link-edit-offset (round-up-page link-edit-len)))] (+ link-edit-offset (round-up-page link-edit-len)))]
[out-addr (+ link-edit-addr (round-up-page link-edit-len))]) [out-addr (+ link-edit-addr (round-up-page link-edit-vmlen))])
(unless ((+ end-cmd new-cmd-sz) . < . min-used) (unless ((+ end-cmd new-cmd-sz) . < . min-used)
(error 'check-header (error 'check-header
"no room for a new section load command (current end is ~a; min used is ~a)" "no room for a new section load command (current end is ~a; min used is ~a)"

65
collects/compiler/zo-marshal.rkt
View File

@ -158,7 +158,7 @@
(define quote-syntax-type-num 14) (define quote-syntax-type-num 14)
(define define-values-type-num 15) (define define-values-type-num 15)
(define define-syntaxes-type-num 16) (define define-syntaxes-type-num 16)
(define define-for-syntax-type-num 17) (define begin-for-syntax-type-num 17)
(define set-bang-type-num 18) (define set-bang-type-num 18)
(define boxenv-type-num 19) (define boxenv-type-num 19)
(define begin0-sequence-type-num 20) (define begin0-sequence-type-num 20)
@ -256,8 +256,6 @@
(define BITS_PER_MZSHORT 32) (define BITS_PER_MZSHORT 32)
(define *dummy* #f)
(define (int->bytes x) (define (int->bytes x)
(integer->integer-bytes x (integer->integer-bytes x
4 4
@ -522,21 +520,20 @@
(out-marshaled define-values-type-num (out-marshaled define-values-type-num
(list->vector (cons (protect-quote rhs) ids)) (list->vector (cons (protect-quote rhs) ids))
out)] out)]
[(struct def-syntaxes (ids rhs prefix max-let-depth)) [(struct def-syntaxes (ids rhs prefix max-let-depth dummy))
(out-marshaled define-syntaxes-type-num (out-marshaled define-syntaxes-type-num
(list->vector (list* (protect-quote rhs) (list->vector (list* (protect-quote rhs)
prefix prefix
max-let-depth max-let-depth
*dummy* dummy
ids)) ids))
out)] out)]
[(struct def-for-syntax (ids rhs prefix max-let-depth)) [(struct seq-for-syntax (rhs prefix max-let-depth dummy))
(out-marshaled define-for-syntax-type-num (out-marshaled begin-for-syntax-type-num
(list->vector (list* (protect-quote rhs) (vector (map protect-quote rhs)
prefix prefix
max-let-depth max-let-depth
*dummy* dummy)
ids))
out)] out)]
[(struct beg0 (forms)) [(struct beg0 (forms))
(out-marshaled begin0-sequence-type-num (map protect-quote forms) out)] (out-marshaled begin0-sequence-type-num (map protect-quote forms) out)]
@ -825,7 +822,7 @@
(define (out-module mod-form out) (define (out-module mod-form out)
(match mod-form (match mod-form
[(struct mod (name srcname self-modidx prefix provides requires body syntax-body unexported [(struct mod (name srcname self-modidx prefix provides requires body syntax-bodies unexported
max-let-depth dummy lang-info internal-context)) max-let-depth dummy lang-info internal-context))
(let* ([lookup-req (lambda (phase) (let* ([lookup-req (lambda (phase)
(let ([a (assq phase requires)]) (let ([a (assq phase requires)])
@ -844,6 +841,11 @@
(if (ormap values p) (if (ormap values p)
(list->vector p) (list->vector p)
#f)))))] #f)))))]
[extract-unexported
(lambda (phase)
(let ([a (assq phase unexported)])
(and a
(cdr a))))]
[list->vector/#f (lambda (default l) [list->vector/#f (lambda (default l)
(if (andmap (lambda (x) (equal? x default)) l) (if (andmap (lambda (x) (equal? x default)) l)
#f #f
@ -861,26 +863,39 @@
[l (cons (lookup-req 1) l)] ; et-requires [l (cons (lookup-req 1) l)] ; et-requires
[l (cons (lookup-req 0) l)] ; requires [l (cons (lookup-req 0) l)] ; requires
[l (cons (list->vector body) l)] [l (cons (list->vector body) l)]
[l (cons (list->vector [l (append (reverse
(for/list ([i (in-list syntax-body)]) (for/list ([b (in-list syntax-bodies)])
(for/vector ([i (in-list (cdr b))])
(define (maybe-one l) ;; a single symbol is ok (define (maybe-one l) ;; a single symbol is ok
(if (and (pair? l) (null? (cdr l))) (if (and (pair? l) (null? (cdr l)))
(car l) (car l)
l)) l))
(match i (match i
[(struct def-syntaxes (ids rhs prefix max-let-depth)) [(struct def-syntaxes (ids rhs prefix max-let-depth dummy))
(vector (maybe-one ids) rhs max-let-depth prefix #f)] (vector (maybe-one ids) rhs max-let-depth prefix #f)]
[(struct def-for-syntax (ids rhs prefix max-let-depth)) [(struct seq-for-syntax ((list rhs) prefix max-let-depth dummy))
(vector (maybe-one ids) rhs max-let-depth prefix #t)]))) (vector #f rhs max-let-depth prefix #t)]))))
l)] l)]
[l (append (apply [l (append (apply
append append
(map (lambda (l) (map (lambda (l)
(let ([phase (car l)] (let* ([phase (car l)]
[all (append (cadr l) (caddr l))]) [all (append (cadr l) (caddr l))]
(list phase [protects (extract-protects phase)]
(list->vector/#f 0 (map (lambda (p) (= 1 (provided-src-phase p))) [unexported (extract-unexported phase)])
all)) (append
(list phase)
(if (and (not protects)
(not unexported))
(list (void))
(let ([unexported (or unexported
'(() ()))])
(list (list->vector (cadr unexported))
(length (cadr unexported))
(list->vector (car unexported))
(length (car unexported))
protects)))
(list (list->vector/#f 0 (map provided-src-phase all))
(list->vector/#f #f (map (lambda (p) (list->vector/#f #f (map (lambda (p)
(if (eq? (provided-nom-src p) (if (eq? (provided-nom-src p)
(provided-src p)) (provided-src p))
@ -891,15 +906,11 @@
(list->vector (map provided-src all)) (list->vector (map provided-src all))
(list->vector (map provided-name all)) (list->vector (map provided-name all))
(length (cadr l)) (length (cadr l))
(length all)))) (length all)))))
provides)) provides))
l)] l)]
[l (cons (length provides) l)] ; number of provide sets [l (cons (length provides) l)] ; number of provide sets
[l (cons (extract-protects 0) l)] ; protects [l (cons (add1 (length syntax-bodies)) l)]
[l (cons (extract-protects 1) l)] ; et protects
[l (list* (list->vector (car unexported)) (length (car unexported)) l)] ; indirect-provides
[l (list* (list->vector (cadr unexported)) (length (cadr unexported)) l)] ; indirect-syntax-provides
[l (list* (list->vector (caddr unexported)) (length (caddr unexported)) l)] ; indirect-et-provides
[l (cons prefix l)] [l (cons prefix l)]
[l (cons dummy l)] [l (cons dummy l)]
[l (cons max-let-depth l)] [l (cons max-let-depth l)]

137
collects/compiler/zo-parse.rkt
View File

@ -181,19 +181,19 @@
(cdr (vector->list v)) (cdr (vector->list v))
(vector-ref v 0))) (vector-ref v 0)))
; XXX Allocates unnessary list (define (read-define-syntax v)
(define (read-define-syntaxes mk v) (make-def-syntaxes (list-tail (vector->list v) 4)
(mk (list-tail (vector->list v) 4)
(vector-ref v 0) (vector-ref v 0)
(vector-ref v 1) (vector-ref v 1)
(vector-ref v 2) (vector-ref v 2)
#;(vector-ref v 3))) (vector-ref v 3)))
(define (read-define-syntax v) (define (read-begin-for-syntax v)
(read-define-syntaxes make-def-syntaxes v)) (make-seq-for-syntax
(vector-ref v 0)
(define (read-define-for-syntax v) (vector-ref v 1)
(read-define-syntaxes make-def-for-syntax v)) (vector-ref v 2)
(vector-ref v 3)))
(define (read-set! v) (define (read-set! v)
(make-assign (cadr v) (cddr v) (car v))) (make-assign (cadr v) (cddr v) (car v)))
@ -225,50 +225,65 @@
(lambda _ #t) (lambda _ #t)
(lambda _ #t))))) (lambda _ #t)))))
(define (split-phase-data rest n)
(let loop ([n n] [rest rest] [phase-accum null])
(cond
[(zero? n)
(values (reverse phase-accum) rest)]
[else
(let ([maybe-indirect (list-ref rest 1)])
(if (void? maybe-indirect)
;; no indirect or protect info:
(loop (sub1 n)
(list-tail rest 9)
(cons (take rest 9) phase-accum))
;; has indirect or protect info:
(loop (sub1 n)
(list-tail rest (+ 5 8))
(cons (take rest (+ 5 8)) phase-accum))))])))
(define (read-module v) (define (read-module v)
(match v (match v
[`(,name ,srcname ,self-modidx ,lang-info ,functional? ,et-functional? [`(,name ,srcname ,self-modidx ,lang-info ,functional? ,et-functional?
,rename ,max-let-depth ,dummy ,rename ,max-let-depth ,dummy
,prefix ,prefix ,num-phases
,indirect-et-provides ,num-indirect-et-provides
,indirect-syntax-provides ,num-indirect-syntax-provides
,indirect-provides ,num-indirect-provides
,protects ,et-protects
,provide-phase-count . ,rest) ,provide-phase-count . ,rest)
(let ([phase-data (take rest (* 8 provide-phase-count))]) (let*-values ([(phase-data rest-module) (split-phase-data rest provide-phase-count)]
(match (list-tail rest (* 8 provide-phase-count)) [(bodies rest-module) (values (take rest-module num-phases)
[`(,syntax-body ,body (drop rest-module num-phases))])
,requires ,syntax-requires ,template-requires ,label-requires (match rest-module
[`(,requires ,syntax-requires ,template-requires ,label-requires
,more-requires-count . ,more-requires) ,more-requires-count . ,more-requires)
(make-mod name srcname self-modidx (make-mod name srcname self-modidx
prefix (let loop ([l phase-data]) prefix
(if (null? l) ;; provides:
null (for/list ([l (in-list phase-data)])
(let ([num-vars (list-ref l 6)] (let* ([phase (list-ref l 0)]
[ps (for/list ([name (in-vector (list-ref l 5))] [has-info? (not (void? (list-ref l 1)))]
[src (in-vector (list-ref l 4))] [delta (if has-info? 5 1)]
[src-name (in-vector (list-ref l 3))] [num-vars (list-ref l (+ delta 6))]
[nom-src (or (list-ref l 2) [num-all (list-ref l (+ delta 7))]
[ps (for/list ([name (in-vector (list-ref l (+ delta 5)))]
[src (in-vector (list-ref l (+ delta 4)))]
[src-name (in-vector (list-ref l (+ delta 3)))]
[nom-src (or (list-ref l (+ delta 2))
(in-cycle (in-value #f)))] (in-cycle (in-value #f)))]
[src-phase (or (list-ref l 1) [src-phase (or (list-ref l (+ delta 1))
(in-cycle (in-value #f)))] (in-cycle (in-value 0)))]
[protected? (or (case (car l) [protected? (cond
[(0) protects] [(or (not has-info?)
[(1) et-protects] (not (list-ref l 5)))
[else #f]) (in-cycle (in-value #f))]
(in-cycle (in-value #f)))]) [else (list-ref l 5)])])
(make-provided name src src-name (make-provided name src src-name
(or nom-src src) (or nom-src src)
(if src-phase 1 0) src-phase
protected?))]) protected?))])
(if (null? ps)
(loop (list-tail l 8))
(cons
(list (list
(car l) phase
(take ps num-vars) (take ps num-vars)
(drop ps num-vars)) (drop ps num-vars))))
(loop (list-tail l 8))))))) ;; requires:
(list* (list*
(cons 0 requires) (cons 0 requires)
(cons 1 syntax-requires) (cons 1 syntax-requires)
@ -276,20 +291,34 @@
(cons #f label-requires) (cons #f label-requires)
(for/list ([(phase reqs) (in-list* more-requires 2)]) (for/list ([(phase reqs) (in-list* more-requires 2)])
(cons phase reqs))) (cons phase reqs)))
(vector->list body) ;; body:
(map (lambda (sb) (vector->list (last bodies))
;; syntax-bodies: add phase to each list, break apart
(for/list ([b (cdr (reverse bodies))]
[i (in-naturals 1)])
(cons i
(for/list ([sb (in-vector b)])
(match sb (match sb
[(? def-syntaxes?) sb]
[(? def-for-syntax?) sb]
[`#(,ids ,expr ,max-let-depth ,prefix ,for-stx?) [`#(,ids ,expr ,max-let-depth ,prefix ,for-stx?)
((if for-stx? (if for-stx?
make-def-for-syntax (make-seq-for-syntax (list expr) prefix max-let-depth #f)
make-def-syntaxes) (make-def-syntaxes
(if (list? ids) ids (list ids)) expr prefix max-let-depth)])) (if (list? ids) ids (list ids)) expr prefix max-let-depth #f))]
(vector->list syntax-body)) [else (error 'zo-parse "bad phase ~a body element: ~e" i sb)]))))
(list (vector->list indirect-provides) ;; unexported:
(vector->list indirect-syntax-provides) (for/list ([l (in-list phase-data)]
(vector->list indirect-et-provides)) #:when (not (void? (list-ref l 1))))
(let* ([phase (list-ref l 0)]
[indirect-syntax
;; could check: (list-ref l 2) should be size of vector:
(list-ref l 1)]
[indirect
;; could check: (list-ref l 4) should be size of vector:
(list-ref l 3)])
(list
phase
(vector->list indirect)
(vector->list indirect-syntax))))
max-let-depth max-let-depth
dummy dummy
lang-info lang-info
@ -313,7 +342,7 @@
[(14) 'quote-syntax-type] [(14) 'quote-syntax-type]
[(15) 'define-values-type] [(15) 'define-values-type]
[(16) 'define-syntaxes-type] [(16) 'define-syntaxes-type]
[(17) 'define-for-syntax-type] [(17) 'begin-for-syntax-type]
[(18) 'set-bang-type] [(18) 'set-bang-type]
[(19) 'boxenv-type] [(19) 'boxenv-type]
[(20) 'begin0-sequence-type] [(20) 'begin0-sequence-type]
@ -350,7 +379,7 @@
(cons 'free-id-info-type read-free-id-info) (cons 'free-id-info-type read-free-id-info)
(cons 'define-values-type read-define-values) (cons 'define-values-type read-define-values)
(cons 'define-syntaxes-type read-define-syntax) (cons 'define-syntaxes-type read-define-syntax)
(cons 'define-for-syntax-type read-define-for-syntax) (cons 'begin-for-syntax-type read-begin-for-syntax)
(cons 'set-bang-type read-set!) (cons 'set-bang-type read-set!)
(cons 'boxenv-type read-boxenv) (cons 'boxenv-type read-boxenv)
(cons 'require-form-type read-require) (cons 'require-form-type read-require)

25
collects/compiler/zo-structs.rkt
View File

@ -80,7 +80,7 @@
[src (or/c module-path-index? #f)] [src (or/c module-path-index? #f)]
[src-name symbol?] [src-name symbol?]
[nom-src any/c] ; should be (or/c module-path-index? #f) [nom-src any/c] ; should be (or/c module-path-index? #f)
[src-phase (or/c 0 1)] [src-phase exact-nonnegative-integer?]
[protected? boolean?])) [protected? boolean?]))
(define-form-struct (toplevel expr) ([depth exact-nonnegative-integer?] (define-form-struct (toplevel expr) ([depth exact-nonnegative-integer?]
@ -89,18 +89,19 @@
[ready? boolean?])) ; access binding via prefix array (which is on stack) [ready? boolean?])) ; access binding via prefix array (which is on stack)
(define-form-struct (seq form) ([forms (listof (or/c form? any/c))])) ; `begin' (define-form-struct (seq form) ([forms (listof (or/c form? any/c))])) ; `begin'
(define-form-struct (seq-for-syntax form) ([forms (listof (or/c form? any/c))] ; `begin-for-syntax'
[prefix prefix?]
[max-let-depth exact-nonnegative-integer?]
[dummy (or/c toplevel? #f)]))
;; Definitions (top level or within module): ;; Definitions (top level or within module):
(define-form-struct (def-values form) ([ids (listof (or/c toplevel? symbol?))] ; added symbol? (define-form-struct (def-values form) ([ids (listof (or/c toplevel? symbol?))]
[rhs (or/c expr? seq? any/c)])) [rhs (or/c expr? seq? any/c)]))
(define-form-struct (def-syntaxes form) ([ids (listof (or/c toplevel? symbol?))] ; added symbol? (define-form-struct (def-syntaxes form) ([ids (listof (or/c toplevel? symbol?))]
[rhs (or/c expr? seq? any/c)] [rhs (or/c expr? seq? any/c)]
[prefix prefix?] [prefix prefix?]
[max-let-depth exact-nonnegative-integer?])) [max-let-depth exact-nonnegative-integer?]
(define-form-struct (def-for-syntax form) ([ids (listof (or/c toplevel? symbol?))] ; added symbol? [dummy (or/c toplevel? #f)]))
[rhs (or/c expr? seq? any/c)]
[prefix prefix?]
[max-let-depth exact-nonnegative-integer?]))
(define-form-struct (mod form) ([name symbol?] (define-form-struct (mod form) ([name symbol?]
[srcname symbol?] [srcname symbol?]
@ -112,9 +113,11 @@
[requires (listof (cons/c (or/c exact-integer? #f) [requires (listof (cons/c (or/c exact-integer? #f)
(listof module-path-index?)))] (listof module-path-index?)))]
[body (listof (or/c form? any/c))] [body (listof (or/c form? any/c))]
[syntax-body (listof (or/c def-syntaxes? def-for-syntax?))] [syntax-bodies (listof (cons/c exact-positive-integer?
[unexported (list/c (listof symbol?) (listof symbol?) (listof (or/c def-syntaxes? seq-for-syntax?))))]
(listof symbol?))] [unexported (listof (list/c exact-nonnegative-integer?
(listof symbol?)
(listof symbol?)))]
[max-let-depth exact-nonnegative-integer?] [max-let-depth exact-nonnegative-integer?]
[dummy toplevel?] [dummy toplevel?]
[lang-info (or/c #f (vector/c module-path? symbol? any/c))] [lang-info (or/c #f (vector/c module-path? symbol? any/c))]

14
collects/db/TODO
View File

@ -1,4 +1,3 @@
internal docs
---- ----
Testing Testing
@ -31,11 +30,11 @@ Types
Misc Misc
- internal docs
- use ffi/unsafe/alloc to simplify odbc handle allocation - use ffi/unsafe/alloc to simplify odbc handle allocation
- add ODBC-like functions for inspecting schemas (list-tables, etc) - add ODBC-like functions for inspecting schemas (list-tables, etc)
- util/schema (?), util/info (for information_schema) (?)
- at least, table-exists? : string [...] -> boolean?
- for wrapped/managed connections, detect if underlying connection gets - for wrapped/managed connections, detect if underlying connection gets
disconnected by server (eg, times out after 10 minutes of inactivity) disconnected by server (eg, times out after 10 minutes of inactivity)
@ -67,10 +66,15 @@ Misc
- how do people want to use cursors? - how do people want to use cursors?
- how about implicit support only in 'in-query'? - how about implicit support only in 'in-query'?
- ODBC: use async execution to avoid blocking all Racket threads
- add evt versions of functions - add evt versions of functions
- for query functions (?) - for query functions (?)
- connection-pool-lease-evt - connection-pool-lease-evt
- when is it useful in practice? - when is it useful in practice?
- would make it easier to handle timeouts... - would make it easier to handle timeouts...
- on insert, return last inserted id
- postgresql: parse CommandComplete msg tag
- mysql: in ok-packet (what conditions, though?)
- sqlite3: sqlite3_last_insert_rowid(), use sqlite3_changes() to see if insert succeeded,
but still need to tell if stmt was even insert (parse sql?)
- odbc: ???

253
collects/db/base.rkt
View File

@ -1,9 +1,250 @@
#lang racket/base #lang racket/base
(require racket/contract (require racket/contract
"private/generic/main.rkt" unstable/prop-contract)
"private/generic/connect-util.rkt"
"private/generic/dsn.rkt")
(provide (all-from-out "private/generic/main.rkt") ;; ============================================================
(all-from-out "private/generic/dsn.rkt")
(all-from-out "private/generic/connect-util.rkt")) (require "private/generic/interfaces.rkt"
"private/generic/sql-data.rkt")
(provide (struct-out simple-result)
(struct-out rows-result)
statement-binding?)
(provide sql-null
sql-null?
sql-null->false
false->sql-null)
(provide/contract
[struct sql-date ([year exact-integer?]
[month (integer-in 0 12)]
[day (integer-in 0 31)])]
[struct sql-time ([hour (integer-in 0 23)]
[minute (integer-in 0 59)]
[second (integer-in 0 61)] ;; leap seconds
[nanosecond (integer-in 0 (sub1 #e1e9))]
[tz (or/c #f exact-integer?)])]
[struct sql-timestamp ([year exact-integer?]
[month (integer-in 0 12)]
[day (integer-in 0 31)]
[hour (integer-in 0 23)]
[minute (integer-in 0 59)]
[second (integer-in 0 61)]
[nanosecond (integer-in 0 (sub1 #e1e9))]
[tz (or/c #f exact-integer?)])]
[struct sql-interval ([years exact-integer?]
[months exact-integer?]
[days exact-integer?]
[hours exact-integer?]
[minutes exact-integer?]
[seconds exact-integer?]
[nanoseconds exact-integer?])]
[sql-day-time-interval?
(-> any/c boolean?)]
[sql-year-month-interval?
(-> any/c boolean?)]
[sql-interval->sql-time
(->* (sql-interval?) (any/c)
any)]
[sql-time->sql-interval
(-> sql-time? sql-day-time-interval?)]
[make-sql-bits
(-> exact-nonnegative-integer? sql-bits?)]
[sql-bits?
(-> any/c boolean?)]
[sql-bits-length
(-> sql-bits? exact-nonnegative-integer?)]
[sql-bits-ref
(-> sql-bits? exact-nonnegative-integer? boolean?)]
[sql-bits-set!
(-> sql-bits? exact-nonnegative-integer? boolean? void?)]
[sql-bits->list
(-> sql-bits? (listof boolean?))]
[list->sql-bits
(-> (listof boolean?) sql-bits?)]
[sql-bits->string
(-> sql-bits? string?)]
[string->sql-bits
(-> string? sql-bits?)])
;; ============================================================
(require "private/generic/functions.rkt")
(provide (rename-out [in-query* in-query]))
(provide/contract
[connection?
(-> any/c any)]
[disconnect
(-> connection? any)]
[connected?
(-> connection? any)]
[connection-dbsystem
(-> connection? dbsystem?)]
[dbsystem?
(-> any/c any)]
[dbsystem-name
(-> dbsystem? symbol?)]
[dbsystem-supported-types
(-> dbsystem? (listof symbol?))]
[statement?
(-> any/c any)]
[prepared-statement?
(-> any/c any)]
[prepared-statement-parameter-types
(-> prepared-statement? (or/c list? #f))]
[prepared-statement-result-types
(-> prepared-statement? (or/c list? #f))]
[query-exec
(->* (connection? statement?) () #:rest list? any)]
[query-rows
(->* (connection? statement?)
(#:group (or/c (vectorof string?) (listof (vectorof string?))))
#:rest list? (listof vector?))]
[query-list
(->* (connection? statement?) () #:rest list? list?)]
[query-row
(->* (connection? statement?) () #:rest list? vector?)]
[query-maybe-row
(->* (connection? statement?) () #:rest list? (or/c #f vector?))]
[query-value
(->* (connection? statement?) () #:rest list? any)]
[query-maybe-value
(->* (connection? statement?) () #:rest list? any)]
[query
(->* (connection? statement?) () #:rest list? any)]
[prepare
(-> connection? (or/c string? virtual-statement?) any)]
[bind-prepared-statement
(-> prepared-statement? list? any)]
[rename virtual-statement* virtual-statement
(-> (or/c string? (-> dbsystem? string?))
virtual-statement?)]
[virtual-statement?
(-> any/c boolean?)]
[start-transaction
(->* (connection?)
(#:isolation (or/c 'serializable 'repeatable-read 'read-committed 'read-uncommitted #f))
void?)]
[commit-transaction
(-> connection? void?)]
[rollback-transaction
(-> connection? void?)]
[in-transaction?
(-> connection? boolean?)]
[needs-rollback?
(-> connection? boolean?)]
[call-with-transaction
(->* (connection? (-> any))
(#:isolation (or/c 'serializable 'repeatable-read 'read-committed 'read-uncommitted #f))
void?)]
[prop:statement
(struct-type-property/c
(-> any/c connection?
statement?))]
[list-tables
(->* (connection?)
(#:schema (or/c 'search-or-current 'search 'current))
(listof string?))]
[table-exists?
(->* (connection? string?)
(#:schema (or/c 'search-or-current 'search 'current)
#:case-sensitive? any/c)
boolean?)]
[group-rows
(->* (rows-result?
#:group (or/c (vectorof string?) (listof (vectorof string?))))
(#:group-mode (listof (or/c 'preserve-null-rows 'list)))
rows-result?)])
;; ============================================================
(require "private/generic/connect-util.rkt")
(provide/contract
[kill-safe-connection
(-> connection? connection?)]
[virtual-connection
(->* ((or/c (-> connection?) connection-pool?))
()
connection?)]
[connection-pool
(->* ((-> connection?))
(#:max-connections (or/c (integer-in 1 10000) +inf.0)
#:max-idle-connections (or/c (integer-in 1 10000) +inf.0))
connection-pool?)]
[connection-pool?
(-> any/c boolean?)]
[connection-pool-lease
(->* (connection-pool?)
((or/c custodian? evt?))
connection?)])
;; ============================================================
(require "private/generic/dsn.rkt")
(provide dsn-connect) ;; can't express "or any kw at all" w/ ->* contract
(provide/contract
[struct data-source
([connector connector?]
[args arglist?]
[extensions (listof (list/c symbol? writable-datum?))])]
[current-dsn-file (parameter/c path-string?)]
[get-dsn
(->* (symbol?) (any/c #:dsn-file path-string?) any)]
[put-dsn
(->* (symbol? (or/c data-source? #f)) (#:dsn-file path-string?) void?)]
[postgresql-data-source
(->* ()
(#:user string?
#:database string?
#:server string?
#:port exact-positive-integer?
#:socket (or/c string? 'guess)
#:password (or/c string? #f)
#:allow-cleartext-password? boolean?
#:ssl (or/c 'yes 'optional 'no)
#:notice-handler (or/c 'output 'error)
#:notification-handler (or/c 'output 'error))
data-source?)]
[mysql-data-source
(->* ()
(#:user string?
#:database string?
#:server string?
#:port exact-positive-integer?
#:socket (or/c string? 'guess)
#:password (or/c string? #f)
#:notice-handler (or/c 'output 'error))
data-source?)]
[sqlite3-data-source
(->* ()
(#:database (or/c string? 'memory 'temporary)
#:mode (or/c 'read-only 'read/write 'create)
#:busy-retry-limit (or/c exact-nonnegative-integer? +inf.0)
#:busy-retry-delay (and/c rational? (not/c negative?))
#:use-place boolean?)
data-source?)]
[odbc-data-source
(->* ()
(#:dsn string?
#:user string?
#:password string?
#:notice-handler (or/c 'output 'error)
#:strict-parameter-types? boolean?
#:character-mode (or/c 'wchar 'utf-8 'latin-1)
#:use-place boolean?)
data-source?)])

56
collects/db/main.rkt
View File

@ -1,39 +1,28 @@
#lang racket/base #lang racket/base
(require (for-syntax racket/base) (require (for-syntax racket/base)
"private/generic/lazy-require.rkt" unstable/lazy-require
racket/runtime-path
racket/promise
racket/contract racket/contract
"base.rkt") "base.rkt")
(provide (all-from-out "base.rkt")) (provide (all-from-out "base.rkt"))
(define-lazy-require-definer define-postgresql "private/postgresql/main.rkt") (lazy-require
(define-lazy-require-definer define-mysql "private/mysql/main.rkt") ["private/postgresql/main.rkt"
(define-lazy-require-definer define-sqlite3 "private/sqlite3/main.rkt") (postgresql-connect
(define-lazy-require-definer define-odbc "private/odbc/main.rkt")
(define-lazy-require-definer define-openssl 'openssl)
(define-postgresql
postgresql-connect
postgresql-guess-socket-path postgresql-guess-socket-path
postgresql-password-hash) postgresql-password-hash)]
["private/mysql/main.rkt"
(define-mysql (mysql-connect
mysql-connect
mysql-guess-socket-path mysql-guess-socket-path
mysql-password-hash) mysql-password-hash)]
["private/sqlite3/main.rkt"
(define-sqlite3 (sqlite3-connect)]
sqlite3-connect) ["private/odbc/main.rkt"
(odbc-connect
(define-odbc
odbc-connect
odbc-driver-connect odbc-driver-connect
odbc-data-sources odbc-data-sources
odbc-drivers) odbc-drivers)]
['openssl
(define-openssl (ssl-client-context?)])
ssl-client-context?)
(provide/contract (provide/contract
;; Duplicates contracts at postgresql.rkt ;; Duplicates contracts at postgresql.rkt
@ -49,7 +38,7 @@
#:ssl-context ssl-client-context? #:ssl-context ssl-client-context?
#:notice-handler (or/c 'output 'error output-port? procedure?) #:notice-handler (or/c 'output 'error output-port? procedure?)
#:notification-handler (or/c 'output 'error output-port? procedure?)) #:notification-handler (or/c 'output 'error output-port? procedure?))
any/c)] connection?)]
[postgresql-guess-socket-path [postgresql-guess-socket-path
(-> path-string?)] (-> path-string?)]
[postgresql-password-hash [postgresql-password-hash
@ -64,7 +53,7 @@
#:port (or/c exact-positive-integer? #f) #:port (or/c exact-positive-integer? #f)
#:socket (or/c path-string? 'guess #f) #:socket (or/c path-string? 'guess #f)
#:notice-handler (or/c 'output 'error output-port? procedure?)) #:notice-handler (or/c 'output 'error output-port? procedure?))
any/c)] connection?)]
[mysql-guess-socket-path [mysql-guess-socket-path
(-> path-string?)] (-> path-string?)]
[mysql-password-hash [mysql-password-hash
@ -75,8 +64,9 @@
(->* (#:database (or/c path-string? 'memory 'temporary)) (->* (#:database (or/c path-string? 'memory 'temporary))
(#:mode (or/c 'read-only 'read/write 'create) (#:mode (or/c 'read-only 'read/write 'create)
#:busy-retry-limit (or/c exact-nonnegative-integer? +inf.0) #:busy-retry-limit (or/c exact-nonnegative-integer? +inf.0)
#:busy-retry-delay (and/c rational? (not/c negative?))) #:busy-retry-delay (and/c rational? (not/c negative?))
any/c)] #:use-place boolean?)
connection?)]
;; Duplicates contracts at odbc.rkt ;; Duplicates contracts at odbc.rkt
[odbc-connect [odbc-connect
@ -85,13 +75,15 @@
#:password (or/c string? #f) #:password (or/c string? #f)
#:notice-handler (or/c 'output 'error output-port? procedure?) #:notice-handler (or/c 'output 'error output-port? procedure?)
#:strict-parameter-types? boolean? #:strict-parameter-types? boolean?
#:character-mode (or/c 'wchar 'utf-8 'latin-1)) #:character-mode (or/c 'wchar 'utf-8 'latin-1)
#:use-place boolean?)
connection?)] connection?)]
[odbc-driver-connect [odbc-driver-connect
(->* (string?) (->* (string?)
(#:notice-handler (or/c 'output 'error output-port? procedure?) (#:notice-handler (or/c 'output 'error output-port? procedure?)
#:strict-parameter-types? boolean? #:strict-parameter-types? boolean?
#:character-mode (or/c 'wchar 'utf-8 'latin-1)) #:character-mode (or/c 'wchar 'utf-8 'latin-1)
#:use-place boolean?)
connection?)] connection?)]
[odbc-data-sources [odbc-data-sources
(-> (listof (list/c string? string?)))] (-> (listof (list/c string? string?)))]

2
collects/db/mysql.rkt
View File

@ -13,7 +13,7 @@
#:port (or/c exact-positive-integer? #f) #:port (or/c exact-positive-integer? #f)
#:socket (or/c path-string? 'guess #f) #:socket (or/c path-string? 'guess #f)
#:notice-handler (or/c 'output 'error output-port? procedure?)) #:notice-handler (or/c 'output 'error output-port? procedure?))
any/c)] connection?)]
[mysql-guess-socket-path [mysql-guess-socket-path
(-> path-string?)] (-> path-string?)]
[mysql-password-hash [mysql-password-hash

6
collects/db/odbc.rkt
View File

@ -11,13 +11,15 @@
#:password (or/c string? #f) #:password (or/c string? #f)
#:notice-handler (or/c 'output 'error output-port? procedure?) #:notice-handler (or/c 'output 'error output-port? procedure?)
#:strict-parameter-types? boolean? #:strict-parameter-types? boolean?
#:character-mode (or/c 'wchar 'utf-8 'latin-1)) #:character-mode (or/c 'wchar 'utf-8 'latin-1)
#:use-place boolean?)
connection?)] connection?)]
[odbc-driver-connect [odbc-driver-connect
(->* (string?) (->* (string?)
(#:notice-handler (or/c 'output 'error output-port? procedure?) (#:notice-handler (or/c 'output 'error output-port? procedure?)
#:strict-parameter-types? boolean? #:strict-parameter-types? boolean?
#:character-mode (or/c 'wchar 'utf-8 'latin-1)) #:character-mode (or/c 'wchar 'utf-8 'latin-1)
#:use-place boolean?)
connection?)] connection?)]
[odbc-data-sources [odbc-data-sources
(-> (listof (list/c string? string?)))] (-> (listof (list/c string? string?)))]

2
collects/db/postgresql.rkt
View File

@ -18,7 +18,7 @@
#:ssl-context ssl-client-context? #:ssl-context ssl-client-context?
#:notice-handler (or/c 'output 'error output-port? procedure?) #:notice-handler (or/c 'output 'error output-port? procedure?)
#:notification-handler (or/c 'output 'error output-port? procedure?)) #:notification-handler (or/c 'output 'error output-port? procedure?))
any/c)] connection?)]
[postgresql-guess-socket-path [postgresql-guess-socket-path
(-> path-string?)] (-> path-string?)]
[postgresql-password-hash [postgresql-password-hash

44
collects/db/private/generic/connect-util.rkt
View File

@ -1,8 +1,11 @@
#lang racket/base #lang racket/base
(require racket/contract (require racket/class
racket/class "interfaces.rkt")
"interfaces.rkt" (provide kill-safe-connection
(only-in "functions.rkt" connection?)) virtual-connection
connection-pool
connection-pool?
connection-pool-lease)
;; manager% implements kill-safe manager thread w/ request channel ;; manager% implements kill-safe manager thread w/ request channel
(define manager% (define manager%
@ -22,7 +25,7 @@
(loop))))) (loop)))))
(define/public (call proc) (define/public (call proc)
(thread-resume mthread) (thread-resume mthread (current-thread))
(let ([result #f] (let ([result #f]
[sema (make-semaphore 0)]) [sema (make-semaphore 0)])
(channel-put req-channel (channel-put req-channel
@ -61,6 +64,7 @@
(get-dbsystem) (get-dbsystem)
(query fsym stmt) (query fsym stmt)
(prepare fsym stmt close-on-exec?) (prepare fsym stmt close-on-exec?)
(get-base)
(free-statement stmt) (free-statement stmt)
(transaction-status fsym) (transaction-status fsym)
(start-transaction fsym isolation) (start-transaction fsym isolation)
@ -80,7 +84,7 @@
;; Virtual connection ;; Virtual connection
(define virtual-connection% (define virtual-connection%
(class* object% (connection<%> no-cache-prepare<%>) (class* object% (connection<%>)
(init-private connector ;; called from client thread (init-private connector ;; called from client thread
get-key ;; called from client thread get-key ;; called from client thread
timeout) timeout)
@ -178,6 +182,9 @@
(#f #f (transaction-status fsym)) (#f #f (transaction-status fsym))
(#t '_ (list-tables fsym schema))) (#t '_ (list-tables fsym schema)))
(define/public (get-base)
(get-connection #t))
(define/public (disconnect) (define/public (disconnect)
(let ([c (get-connection #f)] (let ([c (get-connection #f)]
[key (get-key)]) [key (get-key)])
@ -187,7 +194,8 @@
(void)) (void))
(define/public (prepare fsym stmt close-on-exec?) (define/public (prepare fsym stmt close-on-exec?)
(unless close-on-exec? ;; FIXME: hacky way of supporting virtual-statement
(unless (or close-on-exec? (eq? fsym 'virtual-statement))
(error fsym "cannot prepare statement with virtual connection")) (error fsym "cannot prepare statement with virtual connection"))
(send (get-connection #t) prepare fsym stmt close-on-exec?)) (send (get-connection #t) prepare fsym stmt close-on-exec?))
@ -329,6 +337,7 @@
(get-dbsystem) (get-dbsystem)
(query fsym stmt) (query fsym stmt)
(prepare fsym stmt close-on-exec?) (prepare fsym stmt close-on-exec?)
(get-base)
(free-statement stmt) (free-statement stmt)
(transaction-status fsym) (transaction-status fsym)
(start-transaction fsym isolation) (start-transaction fsym isolation)
@ -370,24 +379,3 @@
(uerror 'connection-pool-lease (uerror 'connection-pool-lease
"cannot obtain connection; connection pool limit reached")) "cannot obtain connection; connection pool limit reached"))
result)) result))
;; ========================================
(provide/contract
[kill-safe-connection
(-> connection? connection?)]
[virtual-connection
(->* ((or/c (-> connection?) connection-pool?))
()
connection?)]
[connection-pool
(->* ((-> connection?))
(#:max-connections (or/c (integer-in 1 10000) +inf.0)
#:max-idle-connections (or/c (integer-in 1 10000) +inf.0))
connection-pool?)]
[connection-pool?
(-> any/c boolean?)]
[connection-pool-lease
(->* (connection-pool?)
((or/c custodian? evt?))
connection?)])

95
collects/db/private/generic/dsn.rkt
View File

@ -1,20 +1,26 @@
#lang racket/base #lang racket/base
(require "lazy-require.rkt" (require unstable/lazy-require
racket/contract
racket/match racket/match
racket/file racket/file
racket/list racket/list)
racket/runtime-path (provide dsn-connect
racket/promise (struct-out data-source)
"main.rkt") connector?
arglist?
writable-datum?
current-dsn-file
get-dsn
put-dsn
postgresql-data-source
mysql-data-source
sqlite3-data-source
odbc-data-source)
(define-lazy-require-definer define-main "../../main.rkt") (lazy-require
["../../main.rkt" (postgresql-connect
(define-main
postgresql-connect
mysql-connect mysql-connect
sqlite3-connect sqlite3-connect
odbc-connect) odbc-connect)])
#| #|
DSN v0.1 format DSN v0.1 format
@ -47,15 +53,15 @@ considered important.
(define none (gensym 'none)) (define none (gensym 'none))
(define (datum? x) (define (writable-datum? x)
(or (symbol? x) (or (symbol? x)
(string? x) (string? x)
(number? x) (number? x)
(boolean? x) (boolean? x)
(null? x) (null? x)
(and (pair? x) (and (pair? x)
(datum? (car x)) (writable-datum? (car x))
(datum? (cdr x))))) (writable-datum? (cdr x)))))
(define (connector? x) (define (connector? x)
(memq x '(postgresql mysql sqlite3 odbc))) (memq x '(postgresql mysql sqlite3 odbc)))
@ -72,11 +78,11 @@ considered important.
(reverse kwargs))] (reverse kwargs))]
[(keyword? (car x)) [(keyword? (car x))
(cond [(null? (cdr x)) (fail "keyword without argument: ~a" (car x))] (cond [(null? (cdr x)) (fail "keyword without argument: ~a" (car x))]
[(datum? (cadr x)) [(writable-datum? (cadr x))
(loop (cddr x) pargs (cons (list (car x) (cadr x)) kwargs))] (loop (cddr x) pargs (cons (list (car x) (cadr x)) kwargs))]
[else [else
(fail "expected readable datum: ~e" (cadr x))])] (fail "expected readable datum: ~e" (cadr x))])]
[(datum? (car x)) [(writable-datum? (car x))
(loop (cdr x) (cons (car x) pargs) kwargs)] (loop (cdr x) (cons (car x) pargs) kwargs)]
[else (fail "expected readable datum: ~e" (car x))])) [else (fail "expected readable datum: ~e" (car x))]))
(fail "expected list"))) (fail "expected list")))
@ -93,7 +99,7 @@ considered important.
(if (list? x) (if (list? x)
(map (lambda (x) (map (lambda (x)
(match x (match x
[(list (? symbol? key) (? datum? value)) [(list (? symbol? key) (? writable-datum? value))
x] x]
[else (fail "expected extension entry: ~e" x)])) [else (fail "expected extension entry: ~e" x)]))
x) x)
@ -189,60 +195,9 @@ considered important.
(define sqlite3-data-source (define sqlite3-data-source
(mk-specialized 'sqlite3-data-source 'sqlite3 0 (mk-specialized 'sqlite3-data-source 'sqlite3 0
'(#:database #:mode #:busy-retry-limit #:busy-retry-delay))) '(#:database #:mode #:busy-retry-limit #:busy-retry-delay #:use-place)))
(define odbc-data-source (define odbc-data-source
(mk-specialized 'odbc-data-source 'odbc 0 (mk-specialized 'odbc-data-source 'odbc 0
'(#:dsn #:user #:password #:notice-handler '(#:dsn #:user #:password #:notice-handler
#:strict-parameter-types? #:character-mode))) #:strict-parameter-types? #:character-mode #:use-place)))
(provide/contract
[struct data-source
([connector connector?]
[args arglist?]
[extensions (listof (list/c symbol? datum?))])]
[dsn-connect procedure?] ;; Can't express "or any kw at all" w/ ->* contract.
[current-dsn-file (parameter/c path-string?)]
[get-dsn
(->* (symbol?) (any/c #:dsn-file path-string?) any)]
[put-dsn
(->* (symbol? (or/c data-source? #f)) (#:dsn-file path-string?) void?)]
[postgresql-data-source
(->* ()
(#:user string?
#:database string?
#:server string?
#:port exact-positive-integer?
#:socket (or/c string? 'guess)
#:password (or/c string? #f)
#:allow-cleartext-password? boolean?
#:ssl (or/c 'yes 'optional 'no)
#:notice-handler (or/c 'output 'error)
#:notification-handler (or/c 'output 'error))
data-source?)]
[mysql-data-source
(->* ()
(#:user string?
#:database string?
#:server string?
#:port exact-positive-integer?
#:socket (or/c string? 'guess)
#:password (or/c string? #f)
#:notice-handler (or/c 'output 'error))
data-source?)]
[sqlite3-data-source
(->* ()
(#:database (or/c string? 'memory 'temporary)
#:mode (or/c 'read-only 'read/write 'create)
#:busy-retry-limit (or/c exact-nonnegative-integer? +inf.0)
#:busy-retry-delay (and/c rational? (not/c negative?)))
data-source?)]
[odbc-data-source
(->* ()
(#:dsn string?
#:user string?
#:password string?
#:notice-handler (or/c 'output 'error)
#:strict-parameter-types? boolean?
#:character-mode (or/c 'wchar 'utf-8 'latin-1))
data-source?)])

271
collects/db/private/generic/functions.rkt
View File

@ -1,9 +1,10 @@
#lang racket/base #lang racket/base
(require (for-syntax racket/base) (require (for-syntax racket/base)
racket/contract racket/vector
unstable/prop-contract
racket/class racket/class
"interfaces.rkt") "interfaces.rkt"
(only-in "sql-data.rkt" sql-null sql-null?))
(provide (all-defined-out))
;; == Administrative procedures ;; == Administrative procedures
@ -40,9 +41,6 @@
(statement-binding? x) (statement-binding? x)
(prop:statement? x))) (prop:statement? x)))
(define complete-statement?
(or/c string? statement-binding?))
(define (bind-prepared-statement pst params) (define (bind-prepared-statement pst params)
(send pst bind 'bind-prepared-statement params)) (send pst bind 'bind-prepared-statement params))
@ -61,14 +59,16 @@
(struct virtual-statement (table gen) (struct virtual-statement (table gen)
#:property prop:statement #:property prop:statement
(lambda (stmt c) (lambda (stmt c)
(let ([table (virtual-statement-table stmt)] (let* ([table (virtual-statement-table stmt)]
[gen (virtual-statement-gen stmt)] [gen (virtual-statement-gen stmt)]
[cache? (not (is-a? c no-cache-prepare<%>))]) [base-c (send c get-base)])
(let ([table-pst (hash-ref table c #f)]) (let ([table-pst (and base-c (hash-ref table base-c #f))])
(or table-pst (or table-pst
(let* ([sql-string (gen (send c get-dbsystem))] (let* ([sql-string (gen (send c get-dbsystem))]
[pst (prepare1 'virtual-statement c sql-string (not cache?))]) ;; FIXME: virtual-connection:prepare1 handles
(when cache? (hash-set! table c pst)) ;; fsym = 'virtual-statement case specially
[pst (prepare1 'virtual-statement c sql-string #f)])
(hash-set! table base-c pst)
pst)))))) pst))))))
(define virtual-statement* (define virtual-statement*
@ -84,7 +84,7 @@
(define (query1 c fsym stmt) (define (query1 c fsym stmt)
(send c query fsym stmt)) (send c query fsym stmt))
;; query/rows : connection symbol Statement nat/#f -> void ;; query/rows : connection symbol Statement nat/#f -> rows-result
(define (query/rows c fsym sql want-columns) (define (query/rows c fsym sql want-columns)
(let [(result (query1 c fsym sql))] (let [(result (query1 c fsym sql))]
(unless (rows-result? result) (unless (rows-result? result)
@ -135,9 +135,19 @@
;; Query API procedures ;; Query API procedures
;; query-rows : connection Statement arg ... -> (listof (vectorof 'a)) ;; query-rows : connection Statement arg ... -> (listof (vectorof 'a))
(define (query-rows c sql . args) (define (query-rows c sql
(let ([sql (compose-statement 'query-rows c sql args 'rows)]) #:group [group-fields-list null]
(rows-result-rows (query/rows c 'query-rows sql #f)))) #:group-mode [group-mode null]
. 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
(not (memq 'preserve-null-rows group-mode))
(memq 'list group-mode))]
[else result])])
(rows-result-rows result)))
;; query-list : connection Statement arg ... -> (listof 'a) ;; query-list : connection Statement arg ... -> (listof 'a)
;; Expects to get back a rows-result with one field per row. ;; Expects to get back a rows-result with one field per row.
@ -292,103 +302,146 @@
;; ======================================== ;; ========================================
(define preparable/c (or/c string? virtual-statement?)) (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
(not (memq 'preserve-null-rows group-mode))
(memq 'list group-mode)))
(provide (rename-out [in-query* in-query])) (define (group-rows-result* fsym result key-fields-list invert-outer? as-list?)
(let* ([key-fields-list
(if (list? key-fields-list) key-fields-list (list key-fields-list))]
[total-fields (length (rows-result-headers result))]
[name-map
(for/hash ([header (in-list (rows-result-headers result))]
[i (in-naturals)]
#:when (assq 'name header))
(values (cdr (assq 'name header)) i))]
[fields-used (make-vector total-fields #f)]
[key-indexes-list
(for/list ([key-fields (in-list key-fields-list)])
(for/vector ([key-field (in-vector key-fields)])
(let ([key-index
(cond [(string? key-field)
(hash-ref name-map key-field #f)]
[else key-field])])
(when (string? key-field)
(unless key-index
(error fsym "grouping field ~s not found" key-field)))
(when (exact-integer? key-field)
(unless (< key-index total-fields)
(error fsym "grouping index ~s out of range [0, ~a]"
key-index (sub1 total-fields))))
(when (vector-ref fields-used key-index)
(error fsym "grouping field ~s~a used multiple times"
key-field
(if (string? key-field)
(format " (index ~a)" key-index)
"")))
(vector-set! fields-used key-index #t)
key-index)))]
[residual-length
(for/sum ([x (in-vector fields-used)])
(if x 0 1))])
(when (= residual-length 0)
(error fsym "cannot group by all fields"))
(when (and (> residual-length 1) as-list?)
(error fsym
"exactly one residual field expected for #:group-mode 'list, got ~a"
residual-length))
(let* ([initial-projection
(for/vector #:length total-fields ([i (in-range total-fields)]) i)]
[headers
(group-headers (list->vector (rows-result-headers result))
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))))
(provide/contract (define (group-headers headers projection key-indexes-list)
[connection? (define (get-headers vec)
(-> any/c any)] (for/list ([index (in-vector vec)])
[disconnect (vector-ref headers index)))
(-> connection? any)] (cond [(null? key-indexes-list)
[connected? (get-headers projection)]
(-> connection? any)] [else
[connection-dbsystem (let* ([key-indexes (car key-indexes-list)]
(-> connection? dbsystem?)] [residual-projection
[dbsystem? (vector-filter-not (lambda (index) (vector-member index key-indexes))
(-> any/c any)] projection)]
[dbsystem-name [residual-headers
(-> dbsystem? symbol?)] (group-headers headers residual-projection (cdr key-indexes-list))])
[dbsystem-supported-types (append (get-headers key-indexes)
(-> dbsystem? (listof symbol?))] (list `((grouped . ,residual-headers)))))]))
[statement? (define (group-rows* fsym rows projection key-indexes-list invert-outer? as-list?)
(-> any/c any)] ;; projection is vector of indexes (actually projection and permutation)
[prepared-statement? ;; invert-outer? => residual rows with all NULL fields are dropped.
(-> any/c any)] (cond [(null? key-indexes-list)
[prepared-statement-parameter-types ;; Apply projection to each row
(-> prepared-statement? (or/c list? #f))] (cond [as-list?
[prepared-statement-result-types (unless (= (vector-length projection) 1)
(-> prepared-statement? (or/c list? #f))] (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))
[query-exec (define key-row-length (vector-length key-indexes))
(->* (connection? statement?) () #:rest list? any)] (define (row->key-row row)
[query-rows (for/vector #:length key-row-length
(->* (connection? statement?) () #:rest list? (listof vector?))] ([i (in-vector key-indexes)])
[query-list (vector-ref row i)))
(->* (connection? statement?) () #:rest list? list?)]
[query-row
(->* (connection? statement?) () #:rest list? vector?)]
[query-maybe-row
(->* (connection? statement?) () #:rest list? (or/c #f vector?))]
[query-value
(->* (connection? statement?) () #:rest list? any)]
[query-maybe-value
(->* (connection? statement?) () #:rest list? any)]
[query
(->* (connection? statement?) () #:rest list? any)]
#| (define (residual-all-null? row)
[in-query (for/and ([i (in-vector residual-projection)])
(->* (connection? statement?) () #:rest list? sequence?)] (sql-null? (vector-ref row i))))
|#
[prepare (let* ([key-table (make-hash)]
(-> connection? preparable/c any)] [r-keys
[bind-prepared-statement (for/fold ([r-keys null])
(-> prepared-statement? list? any)] ([row (in-list rows)])
(let* ([key-row (row->key-row row)]
[rename virtual-statement* virtual-statement [already-seen? (and (hash-ref key-table key-row #f) #t)])
(-> (or/c string? (-> dbsystem? string?)) (unless already-seen?
virtual-statement?)] (hash-set! key-table key-row null))
[virtual-statement? (unless (and invert-outer? (residual-all-null? row))
(-> any/c boolean?)] (hash-set! key-table key-row (cons row (hash-ref key-table key-row))))
(if already-seen?
[start-transaction r-keys
(->* (connection?) (cons key-row r-keys))))])
(#:isolation (or/c 'serializable 'repeatable-read 'read-committed 'read-uncommitted #f)) (for/list ([key (in-list (reverse r-keys))])
void?)] (let ([residuals
[commit-transaction (group-rows* fsym
(-> connection? void?)] (reverse (hash-ref key-table key))
[rollback-transaction residual-projection
(-> connection? void?)] (cdr key-indexes-list)
[in-transaction? invert-outer?
(-> connection? boolean?)] as-list?)])
[needs-rollback? (vector-append key (vector residuals))))))]))
(-> connection? boolean?)]
[call-with-transaction
(->* (connection? (-> any))
(#:isolation (or/c 'serializable 'repeatable-read 'read-committed 'read-uncommitted #f))
void?)]
[prop:statement
(struct-type-property/c
(-> any/c connection?
statement?))]
[list-tables
(->* (connection?)
(#:schema (or/c 'search-or-current 'search 'current))
(listof string?))]
[table-exists?
(->* (connection? string?)
(#:schema (or/c 'search-or-current 'search 'current)
#:case-sensitive? any/c)
boolean?)]
#|
[get-schemas
(-> connection? (listof vector?))]
[get-tables
(-> connection? (listof vector?))]
|#)

100
collects/db/private/generic/interfaces.rkt
View File

@ -1,5 +1,6 @@
#lang racket/base #lang racket/base
(require racket/class) (require racket/class
ffi/unsafe/atomic)
(provide connection<%> (provide connection<%>
dbsystem<%> dbsystem<%>
prepared-statement<%> prepared-statement<%>
@ -13,9 +14,6 @@
define-type-table define-type-table
no-cache-prepare<%>
connector<%>
locking% locking%
transactions% transactions%
@ -42,22 +40,13 @@
get-dbsystem ;; -> dbsystem<%> get-dbsystem ;; -> dbsystem<%>
query ;; symbol statement -> QueryResult query ;; symbol statement -> QueryResult
prepare ;; symbol preparable boolean -> prepared-statement<%> prepare ;; symbol preparable boolean -> prepared-statement<%>
get-base ;; -> connection<%> or #f (#f means base isn't fixed)
list-tables ;; symbol symbol -> (listof string)
start-transaction ;; symbol (U 'serializable ...) -> void start-transaction ;; symbol (U 'serializable ...) -> void
end-transaction ;; symbol (U 'commit 'rollback) -> void end-transaction ;; symbol (U 'commit 'rollback) -> void
transaction-status ;; symbol -> (U boolean 'invalid) transaction-status ;; symbol -> (U boolean 'invalid)
list-tables ;; symbol symbol -> (listof string)
free-statement)) ;; prepared-statement<%> -> void free-statement)) ;; prepared-statement<%> -> void
;; no-cache-prepare<%>
;; Interface to identify connections such as connection-generators:
;; prepare method must be called with close-on-exec? = #t and result must
;; not be cached.
(define no-cache-prepare<%>
(interface ()))
;; ==== DBSystem ;; ==== DBSystem
;; dbsystem<%> ;; dbsystem<%>
@ -102,7 +91,6 @@
;; extension hooks: usually shouldn't need to override ;; extension hooks: usually shouldn't need to override
finalize ;; -> void finalize ;; -> void
register-finalizer ;; -> void
;; inspection only ;; inspection only
get-param-types ;; -> (listof TypeDesc) get-param-types ;; -> (listof TypeDesc)
@ -176,16 +164,6 @@
(list ok? t x))))) (list ok? t x)))))
;; == Internal staging interfaces
;; connector<%>
;; Manages making connections
(define connector<%>
(interface ()
attach-to-ports ;; input-port output-port -> void
start-connection-protocol ;; string string string/#f -> void
))
;; == Notice/notification handler maker ;; == Notice/notification handler maker
;; make-handler : output-port/symbol string -> string string -> void ;; make-handler : output-port/symbol string -> string string -> void
@ -211,27 +189,33 @@
;; Connection base class (locking) ;; Connection base class (locking)
;; Disabled for now, because this is an 80% solution. Unfortunately, I
;; think a 100% solution would require an auxiliary kill-safe thread
;; with multiple thread switches *per lock acquisition*. At that
;; point, might as well just use kill-safe connection.
(define USE-LOCK-HOLDER? #f)
(define locking% (define locking%
(class object% (class object%
;; == Communication locking ;; == Communication locking
(define lock (make-semaphore 1)) ;; Goal: we would like to be able to detect if a thread has
;; Ideally, we would like to be able to detect if a thread has
;; acquired the lock and then died, leaving the connection ;; acquired the lock and then died, leaving the connection
;; permanently locked. Roughly, we would like this: if lock is ;; permanently locked.
;; held by thread th, then lock-holder = (thread-dead-evt th), ;;
;; and if lock is not held, then lock-holder = never-evt. ;; lock-holder=(thread-dead-evt thd) iff thd has acquired inner-lock
;; Unfortunately, there are intervals when this is not true. ;; - lock-holder, inner-lock always modified together within
;; Also, since lock-holder changes, reference might be stale, so ;; atomic block
;; need to double-check. ;;
;; Thus if (thread-dead-evt thd) is ready, thd died holding
;; inner-lock, so hopelessly locked.
;;
;; outer-sema = inner-lock
;; - outer-sema, inner-lock always modified together within atomic
;;
;; The outer-lock just prevents threads from spinning polling
;; inner-lock. If a thread gets past outer-lock and dies before
;; acquiring inner-lock, ok, because outer-lock still open at that
;; point, so other threads can enter outer-lock and acquire inner-lock.
(define outer-sema (make-semaphore 1))
(define outer-lock (semaphore-peek-evt outer-sema))
(define inner-lock (make-semaphore 1))
(define lock-holder never-evt) (define lock-holder never-evt)
;; Delay async calls (eg, notice handler) until unlock ;; Delay async calls (eg, notice handler) until unlock
@ -243,21 +227,32 @@
(call-with-lock* who proc #f #t)) (call-with-lock* who proc #f #t))
(define/public-final (call-with-lock* who proc hopeless require-connected?) (define/public-final (call-with-lock* who proc hopeless require-connected?)
(let* ([me (thread-dead-evt (current-thread))] (let ([me (thread-dead-evt (current-thread))]
[result (sync lock lock-holder)]) [result (sync outer-lock lock-holder)])
(cond [(eq? result lock) (cond [(eq? result outer-lock)
;; Got past outer stage
(let ([proceed?
(begin (start-atomic)
(let ([proceed? (semaphore-try-wait? inner-lock)])
(when proceed?
(set! lock-holder me)
(semaphore-wait outer-sema))
(end-atomic)
proceed?))])
(cond [proceed?
;; Acquired lock ;; Acquired lock
(when USE-LOCK-HOLDER? (set! lock-holder me)) ;; - lock-holder = me, and outer-lock is closed again
(when (and require-connected? (not (connected?))) (when (and require-connected? (not (connected?)))
(semaphore-post lock) (unlock)
(error/not-connected who)) (error/not-connected who))
(with-handlers ([values (lambda (e) (unlock) (raise e))]) (with-handlers ([values (lambda (e) (unlock) (raise e))])
(begin0 (proc) (unlock)))] (begin0 (proc) (unlock)))]
[else
;; Didn't acquire lock; retry
(call-with-lock* who proc hopeless require-connected?)]))]
[(eq? result lock-holder) [(eq? result lock-holder)
;; Thread holding lock is dead ;; Thread holding lock is dead
(if hopeless (if hopeless (hopeless) (error/hopeless who))]
(hopeless)
(error/hopeless who))]
[else [else
;; lock-holder was stale; retry ;; lock-holder was stale; retry
(call-with-lock* who proc hopeless require-connected?)]))) (call-with-lock* who proc hopeless require-connected?)])))
@ -265,8 +260,11 @@
(define/private (unlock) (define/private (unlock)
(let ([async-calls (reverse delayed-async-calls)]) (let ([async-calls (reverse delayed-async-calls)])
(set! delayed-async-calls null) (set! delayed-async-calls null)
(when USE-LOCK-HOLDER? (set! lock-holder never-evt)) (start-atomic)
(semaphore-post lock) (set! lock-holder never-evt)
(semaphore-post inner-lock)
(semaphore-post outer-sema)
(end-atomic)
(for-each call-with-continuation-barrier async-calls))) (for-each call-with-continuation-barrier async-calls)))
;; needs overriding ;; needs overriding

38
collects/db/private/generic/lazy-require.rkt
View File

@ -1,38 +0,0 @@
#lang racket/base
(require (for-syntax racket/base)
racket/runtime-path
racket/promise)
(provide define-lazy-require-definer)
(define-syntax (define-lazy-require-definer stx)
(syntax-case stx ()
[(_ name modpath)
(begin
(unless (identifier? #'name)
(raise-syntax-error #f "expected identifier" stx #'name))
#'(begin (define-runtime-module-path-index mpi-var modpath)
(define-syntax name (make-lazy-require-definer #'mpi-var))))]))
(define-for-syntax (make-lazy-require-definer mpi-var)
(lambda (stx)
(syntax-case stx ()
[(_ fun ...)
(begin
(for ([fun (in-list (syntax->list #'(fun ...)))])
(unless (identifier? fun)
(raise-syntax-error #f "expected identifier for function name" stx fun)))
(with-syntax ([(fun-p ...) (generate-temporaries #'(fun ...))]
[mpi-var mpi-var])
;; Use 'delay/sync' because 'delay' promise is not reentrant.
;; FIXME: OTOH, 'delay/sync' promise is not kill-safe.
#'(begin (define fun-p (delay/sync (dynamic-require mpi-var 'fun)))
...
(define fun (make-delayed-function 'fun fun-p))
...)))])))
(define (make-delayed-function name fun-p)
(procedure-rename
(make-keyword-procedure
(lambda (kws kwargs . args)
(keyword-apply (force fun-p) kws kwargs args)))
name))

68
collects/db/private/generic/main.rkt
View File

@ -1,68 +0,0 @@
#lang racket/base
(require racket/contract
"interfaces.rkt"
"sql-data.rkt"
"functions.rkt")
(provide (struct-out simple-result)
(struct-out rows-result)
statement-binding?
(all-from-out "functions.rkt"))
(provide sql-null
sql-null?
sql-null->false
false->sql-null)
(provide/contract
[struct sql-date ([year exact-integer?]
[month (integer-in 0 12)]
[day (integer-in 0 31)])]
[struct sql-time ([hour (integer-in 0 23)]
[minute (integer-in 0 59)]
[second (integer-in 0 61)] ;; leap seconds
[nanosecond (integer-in 0 (sub1 #e1e9))]
[tz (or/c #f exact-integer?)])]
[struct sql-timestamp ([year exact-integer?]
[month (integer-in 0 12)]
[day (integer-in 0 31)]
[hour (integer-in 0 23)]
[minute (integer-in 0 59)]
[second (integer-in 0 61)]
[nanosecond (integer-in 0 (sub1 #e1e9))]
[tz (or/c #f exact-integer?)])]
[struct sql-interval ([years exact-integer?]
[months exact-integer?]
[days exact-integer?]
[hours exact-integer?]
[minutes exact-integer?]
[seconds exact-integer?]
[nanoseconds exact-integer?])]
[sql-day-time-interval?
(-> any/c boolean?)]
[sql-year-month-interval?
(-> any/c boolean?)]
[sql-interval->sql-time
(->* (sql-interval?) (any/c)
any)]
[sql-time->sql-interval
(-> sql-time? sql-day-time-interval?)]
[make-sql-bits
(-> exact-nonnegative-integer? sql-bits?)]
[sql-bits?
(-> any/c boolean?)]
[sql-bits-length
(-> sql-bits? exact-nonnegative-integer?)]
[sql-bits-ref
(-> sql-bits? exact-nonnegative-integer? boolean?)]
[sql-bits-set!
(-> sql-bits? exact-nonnegative-integer? boolean? void?)]
[sql-bits->list
(-> sql-bits? (listof boolean?))]
[list->sql-bits
(-> (listof boolean?) sql-bits?)]
[sql-bits->string
(-> sql-bits? string?)]
[string->sql-bits
(-> string? sql-bits?)])

107
collects/db/private/generic/place-client.rkt Normal file
View File

@ -0,0 +1,107 @@
#lang racket/base
(require racket/class
racket/match
racket/place
racket/promise
racket/vector
racket/serialize
ffi/unsafe/atomic
"interfaces.rkt"
"prepared.rkt"
"sql-data.rkt")
(provide place-connect
place-proxy-connection%)
(define (pchan-put chan datum)
(place-channel-put chan (serialize datum)))
(define (pchan-get chan)
(deserialize (place-channel-get chan)))
(define connection-server-channel
(delay/sync
(dynamic-place 'db/private/generic/place-server 'connection-server)))
(define (place-connect connection-spec proxy%)
(let-values ([(channel other-channel) (place-channel)])
(place-channel-put (force connection-server-channel)
(list 'connect other-channel connection-spec))
(match (pchan-get channel)
[(list 'ok)
(new proxy% (channel channel))]
[(list 'error message)
(raise (make-exn:fail message (current-continuation-marks)))])))
(define place-proxy-connection%
(class* locking% (connection<%>)
(init-field channel)
(inherit call-with-lock
call-with-lock*)
(super-new)
(define/private (call method-name . args)
(call-with-lock method-name (lambda () (call* method-name args #t))))
(define/private (call/d method-name . args)
(call-with-lock* method-name (lambda () (call* method-name args #f)) #f #f))
(define/private (call* method-name args need-connected?)
(cond [channel
(pchan-put channel (cons method-name args))
(match (pchan-get channel)
[(cons 'values vals)
(apply values (for/list ([val (in-list vals)]) (sexpr->result val)))]
[(list 'error message)
(raise (make-exn:fail message (current-continuation-marks)))])]
[need-connected?
(unless channel
(error/not-connected method-name))]
[else (void)]))
(define/override (connected?)
;; FIXME: can underlying connection disconnect w/o us knowing?
(and channel #t))
(define/public (disconnect)
(call/d 'disconnect)
(set! channel #f))
(define/public (get-dbsystem) (error 'get-dbsystem "not implemented"))
(define/public (get-base) this)
(define/public (query fsym stmt)
(call 'query fsym
(match stmt
[(? string?) (list 'string stmt)]
[(statement-binding pst meta params)
(list 'statement-binding (send pst get-handle) meta params)])))
(define/public (prepare fsym stmt close-on-exec?)
(call 'prepare fsym stmt close-on-exec?))
(define/public (transaction-status fsym)
(call 'transaction-status fsym))
(define/public (start-transaction fsym iso)
(call 'start-transaction fsym iso))
(define/public (end-transaction fsym mode)
(call 'end-transaction fsym mode))
(define/public (list-tables fsym schema)
(call 'list-tables fsym schema))
(define/public (free-statement pst)
(start-atomic)
(let ([handle (send pst get-handle)])
(send pst set-handle #f)
(end-atomic)
(when channel
(call/d 'free-statement handle))))
(define/private (sexpr->result x)
(match x
[(list 'simple-result y)
(simple-result y)]
[(list 'rows-result h rows)
(rows-result h rows)]
[(list 'prepared-statement handle close-on-exec? param-typeids result-dvecs)
(new prepared-statement%
(handle handle)
(close-on-exec? close-on-exec?)
(param-typeids param-typeids)
(result-dvecs result-dvecs)
(owner this))]
[_ x]))))

142
collects/db/private/generic/place-server.rkt Normal file
View File

@ -0,0 +1,142 @@
#lang racket/base
(require (for-syntax racket/base)
racket/class
racket/match
racket/place
racket/serialize
unstable/lazy-require
"interfaces.rkt"
"prepared.rkt"
"sql-data.rkt"
"place-client.rkt")
(provide connection-server)
(define (pchan-put chan datum)
(place-channel-put chan (serialize datum)))
(define (pchan-get chan)
(deserialize (place-channel-get chan)))
#|
Connection creation protocol
client -> server on client-chan: (list 'connect conn-chan <connect-options>)
server -> client on conn-chan: (or (list 'ok)
(list 'error string))
where <connect-spec> ::= (list 'sqlite3 path/sym mode-sym delay-num limit-num)
| (list 'odbc string string/#f string/#f boolean symbol)
|#
(define (connection-server client-chan)
(let loop ()
(serve client-chan)
(loop)))
(lazy-require
["../../main.rkt" (sqlite3-connect
odbc-connect
odbc-driver-connect)])
(define (serve client-chan)
(match (place-channel-get client-chan)
[(list 'connect conn-chan connect-spec)
(with-handlers ([exn:fail?
(lambda (e)
(pchan-put conn-chan (list 'error (exn-message e))))])
(let* ([c
(match connect-spec
[(list 'sqlite3 db mode busy-retry-delay busy-retry-limit)
(sqlite3-connect #:database db
#:mode mode
#:busy-retry-delay busy-retry-delay
#:busy-retry-limit busy-retry-limit
#:use-place #f)]
[(list 'odbc dsn user password strict-param? char-mode)
(odbc-connect #:dsn dsn
#:user user
#:password password
#:strict-parameter-types? strict-param?
#:character-mode char-mode
#:use-place #f)]
[(list 'odbc-driver connection-string strict-param? char-mode)
(odbc-driver-connect connection-string
#:strict-parameter-types? strict-param?
#:character-mode char-mode
#:use-place #f)])]
[p (new proxy-server% (connection c) (channel conn-chan))])
(pchan-put conn-chan (list 'ok))
(thread (lambda () (send p serve)))))]))
#|
Connection methods protocol
client -> server: (list '<method-name> arg ...)
server -> client: (or (list 'values result ...)
(list 'error string))
|#
(define proxy-server%
(class object%
(init-field connection
channel)
(super-new)
(define pstmt-table (make-hash)) ;; int => prepared-statement
(define pstmt-counter 0)
(define/public (serve)
(serve1)
(when connection (serve)))
(define/private (serve1)
(with-handlers ([exn?
(lambda (e)
(pchan-put channel (list 'error (exn-message e))))])
(call-with-values
(lambda ()
(match (pchan-get channel)
[(list 'disconnect)
(send connection disconnect)
(set! connection #f)]
[(list 'free-statement pstmt-index)
(send connection free-statement (hash-ref pstmt-table pstmt-index))
(hash-remove! pstmt-table pstmt-index)]
[(list 'query fsym stmt)
(send connection query fsym (sexpr->statement stmt))]
[msg
(define-syntax-rule (forward-methods (method arg ...) ...)
(match msg
[(list 'method arg ...)
(send connection method arg ...)]
...))
(forward-methods (connected?)
(prepare w s m)
(list-tables w s)
(start-transaction w m)
(end-transaction w m)
(transaction-status w))]))
(lambda results
(let ([results (for/list ([result (in-list results)]) (result->sexpr result))])
(pchan-put channel (cons 'values results)))))))
(define/private (sexpr->statement x)
(match x
[(list 'string s) s]
[(list 'statement-binding pstmt-index meta args)
(statement-binding (hash-ref pstmt-table pstmt-index) meta args)]))
(define/private (result->sexpr x)
(match x
[(simple-result y)
(list 'simple-result y)]
[(rows-result h rows)
(list 'rows-result h rows)]
;; FIXME: Assumes prepared-statement is concrete class, not interface.
[(? (lambda (x) (is-a? x prepared-statement%)))
(let ([pstmt-index (begin (set! pstmt-counter (add1 pstmt-counter)) pstmt-counter)])
(hash-set! pstmt-table pstmt-index x)
(list 'prepared-statement
pstmt-index
(get-field close-on-exec? x)
(get-field param-typeids x)
(get-field result-dvecs x)))]
[_ x]))))

4
collects/db/private/generic/prepared.rkt
View File

@ -8,7 +8,7 @@
;; prepared-statement% ;; prepared-statement%
(define prepared-statement% (define prepared-statement%
(class* object% (prepared-statement<%>) (class* object% (prepared-statement<%>)
(init-private handle ;; handle, determined by database system, #f means closed (init-field handle ;; handle, determined by database system, #f means closed
close-on-exec? ;; boolean close-on-exec? ;; boolean
param-typeids ;; (listof typeid) param-typeids ;; (listof typeid)
result-dvecs) ;; (listof vector), layout depends on dbsys result-dvecs) ;; (listof vector), layout depends on dbsys
@ -81,7 +81,7 @@
(send owner free-statement this)))) (send owner free-statement this))))
(define/public (register-finalizer) (define/public (register-finalizer)
(thread-resume finalizer-thread) (thread-resume finalizer-thread (current-thread))
(will-register will-executor this (lambda (pst) (send pst finalize)))) (will-register will-executor this (lambda (pst) (send pst finalize))))
(super-new) (super-new)

1
collects/db/private/generic/sql-convert.rkt
View File

@ -1,5 +1,4 @@
#lang racket/base #lang racket/base
(require "sql-data.rkt")
;; ======================================== ;; ========================================

27
collects/db/private/generic/sql-data.rkt
View File

@ -1,4 +1,5 @@
#lang racket/base #lang racket/base
(require racket/serialize)
(provide (all-defined-out)) (provide (all-defined-out))
;; SQL Data ;; SQL Data
@ -10,8 +11,15 @@
(define sql-null (define sql-null
(let () (let ()
(define-struct sql-null ()) (struct sql-null ()
(make-sql-null))) ;; must deserialize to singleton, so can't just use serializable-struct
#:property prop:serializable
(make-serialize-info (lambda _ '#())
#'deserialize-info:sql-null-v0
#f
(or (current-load-relative-directory)
(current-directory))))
(sql-null)))
(define (sql-null? x) (define (sql-null? x)
(eq? x sql-null)) (eq? x sql-null))
@ -26,6 +34,11 @@
sql-null sql-null
x)) x))
(define deserialize-info:sql-null-v0
(make-deserialize-info
(lambda _ sql-null)
(lambda () (error 'deserialize-sql-null "cannot have cycles"))))
;; ---------------------------------------- ;; ----------------------------------------
;; Dates and times ;; Dates and times
@ -44,15 +57,15 @@
- timezone offset too limited - timezone offset too limited
|# |#
(define-struct sql-date (year month day) #:transparent) (define-serializable-struct sql-date (year month day) #:transparent)
(define-struct sql-time (hour minute second nanosecond tz) #:transparent) (define-serializable-struct sql-time (hour minute second nanosecond tz) #:transparent)
(define-struct sql-timestamp (define-serializable-struct sql-timestamp
(year month day hour minute second nanosecond tz) (year month day hour minute second nanosecond tz)
#:transparent) #:transparent)
;; Intervals must be "pre-multiplied" rather than carry extra sign field. ;; Intervals must be "pre-multiplied" rather than carry extra sign field.
;; Rationale: postgresql, at least, allows mixture of signs, eg "1 month - 30 days" ;; Rationale: postgresql, at least, allows mixture of signs, eg "1 month - 30 days"
(define-struct sql-interval (define-serializable-struct sql-interval
(years months days hours minutes seconds nanoseconds) (years months days hours minutes seconds nanoseconds)
#:transparent #:transparent
#:guard (lambda (years months days hours minutes seconds nanoseconds _name) #:guard (lambda (years months days hours minutes seconds nanoseconds _name)
@ -131,7 +144,7 @@ byte. (Because that's PostgreSQL's binary format.) For example:
(bytes 128 3) represents 1000000 0000011 (bytes 128 3) represents 1000000 0000011
|# |#
(struct sql-bits (length bv offset)) (serializable-struct sql-bits (length bv offset))
(define (make-sql-bits len) (define (make-sql-bits len)
(sql-bits len (make-bytes (/ceiling len 8) 0) 0)) (sql-bits len (make-bytes (/ceiling len 8) 0) 0))

2
collects/db/private/mysql/connection.rkt
View File

@ -356,6 +356,8 @@
[(? field-packet?) [(? field-packet?)
(cons (parse-field-dvec r) (prepare1:get-field-descriptions fsym))]))) (cons (parse-field-dvec r) (prepare1:get-field-descriptions fsym))])))
(define/public (get-base) this)
(define/public (free-statement pst) (define/public (free-statement pst)
(call-with-lock* 'free-statement (call-with-lock* 'free-statement
(lambda () (lambda ()

9
collects/db/private/mysql/main.rkt
View File

@ -1,16 +1,13 @@
#lang racket/base #lang racket/base
(require racket/contract (require racket/class
racket/class
racket/tcp racket/tcp
file/sha1 file/sha1
"../generic/interfaces.rkt" "../generic/interfaces.rkt"
"../generic/socket.rkt" "../generic/socket.rkt"
"connection.rkt" "connection.rkt")
"dbsystem.rkt")
(provide mysql-connect (provide mysql-connect
mysql-guess-socket-path mysql-guess-socket-path
mysql-password-hash mysql-password-hash)
(rename-out [dbsystem mysql-dbsystem]))
(define (mysql-connect #:user user (define (mysql-connect #:user user
#:database database #:database database

33
collects/db/private/odbc/connection.rkt
View File

@ -3,6 +3,7 @@
racket/list racket/list
racket/math racket/math
ffi/unsafe ffi/unsafe
ffi/unsafe/atomic
"../generic/interfaces.rkt" "../generic/interfaces.rkt"
"../generic/prepared.rkt" "../generic/prepared.rkt"
"../generic/sql-data.rkt" "../generic/sql-data.rkt"
@ -24,7 +25,7 @@
char-mode) char-mode)
(init strict-parameter-types?) (init strict-parameter-types?)
(define statement-table (make-weak-hasheq)) (define statement-table (make-hasheq))
(define lock (make-semaphore 1)) (define lock (make-semaphore 1))
(define use-describe-param? (define use-describe-param?
@ -437,13 +438,14 @@
(define/public (disconnect) (define/public (disconnect)
(define (go) (define (go)
(start-atomic)
(let ([db* db] (let ([db* db]
[env* env]) [env* env])
(when db*
(let ([statements (hash-map statement-table (lambda (k v) k))])
(set! db #f) (set! db #f)
(set! env #f) (set! env #f)
(set! statement-table #f) (end-atomic)
(when db*
(let ([statements (hash-map statement-table (lambda (k v) k))])
(for ([pst (in-list statements)]) (for ([pst (in-list statements)])
(free-statement* 'disconnect pst)) (free-statement* 'disconnect pst))
(handle-status 'disconnect (SQLDisconnect db*) db*) (handle-status 'disconnect (SQLDisconnect db*) db*)
@ -452,16 +454,21 @@
(void))))) (void)))))
(call-with-lock* 'disconnect go go #f)) (call-with-lock* 'disconnect go go #f))
(define/public (get-base) this)
(define/public (free-statement pst) (define/public (free-statement pst)
(define (go) (free-statement* 'free-statement pst)) (define (go) (free-statement* 'free-statement pst))
(call-with-lock* 'free-statement go go #f)) (call-with-lock* 'free-statement go go #f))
(define/private (free-statement* fsym pst) (define/private (free-statement* fsym pst)
(start-atomic)
(let ([stmt (send pst get-handle)]) (let ([stmt (send pst get-handle)])
(when stmt
(send pst set-handle #f) (send pst set-handle #f)
(end-atomic)
(when stmt
(handle-status 'free-statement (SQLFreeStmt stmt SQL_CLOSE) stmt) (handle-status 'free-statement (SQLFreeStmt stmt SQL_CLOSE) stmt)
(handle-status 'free-statement (SQLFreeHandle SQL_HANDLE_STMT stmt) stmt) (handle-status 'free-statement (SQLFreeHandle SQL_HANDLE_STMT stmt) stmt)
(hash-remove! statement-table pst)
(void)))) (void))))
;; Transactions ;; Transactions
@ -654,3 +661,19 @@
(define (field-dvec->typeid dvec) (define (field-dvec->typeid dvec)
(vector-ref dvec 1)) (vector-ref dvec 1))
#|
Historical note: I tried using ODBC async execution to avoid blocking
all Racket threads for a long time.
1) The postgresql, mysql, and oracle drivers don't even support async
execution. Only DB2 (and probably SQL Server, but I didn't try it).
2) Tests using the DB2 driver gave bafflind HY010 (function sequence
error). My best theory so far is that DB2 (or maybe unixodbc) requires
poll call arguments to be identical to original call arguments, which
means that I would have to replace all uses of (_ptr o X) with
something stable across invocations.
All in all, not worth it, especially given #:use-place solution.
|#

5
collects/db/private/odbc/dbsystem.rkt
View File

@ -1,11 +1,8 @@
#lang racket/base #lang racket/base
(require racket/class (require racket/class
ffi/unsafe
ffi/unsafe/atomic
"../generic/interfaces.rkt" "../generic/interfaces.rkt"
"../generic/sql-data.rkt" "../generic/sql-data.rkt"
"../generic/sql-convert.rkt" "../generic/sql-convert.rkt")
"ffi.rkt")
(provide dbsystem (provide dbsystem
supported-typeid?) supported-typeid?)

48
collects/db/private/odbc/ffi.rkt
View File

@ -1,6 +1,5 @@
#lang racket/base #lang racket/base
(require (rename-in racket/contract [-> c->]) (require ffi/unsafe
ffi/unsafe
ffi/unsafe/define ffi/unsafe/define
"ffi-constants.rkt") "ffi-constants.rkt")
(provide (all-from-out "ffi-constants.rkt")) (provide (all-from-out "ffi-constants.rkt"))
@ -21,11 +20,6 @@
(define _sqluinteger _uint) (define _sqluinteger _uint)
(define _sqlreturn _sqlsmallint) (define _sqlreturn _sqlsmallint)
;; Windows ODBC defines wchar_t, thus WCHAR, as 16-bit
;; unixodbc defines WCHAR as 16-bit for compat w/ Windows
;; (even though Linux wchar_t is 32-bit)
(define WCHAR-SIZE 2)
(define-ffi-definer define-mz #f) (define-ffi-definer define-mz #f)
(define-mz scheme_utf16_to_ucs4 (define-mz scheme_utf16_to_ucs4
@ -119,10 +113,28 @@ Docs at http://msdn.microsoft.com/en-us/library/ms712628%28v=VS.85%29.aspx
(define odbc-lib (define odbc-lib
(case (system-type) (case (system-type)
((windows) (ffi-lib "odbc32.dll")) ((windows) (ffi-lib "odbc32.dll"))
(else (ffi-lib "libodbc" '("1" #f))))) ((macosx) (ffi-lib "libiodbc" '("2" #f)))
((unix) (ffi-lib "libodbc" '("1" #f)))))
(define WCHAR-SIZE
(case (system-type)
((windows)
;; Windows ODBC defines wchar_t, thus WCHAR, thus SQLWCHAR, as 16-bit
2)
((macosx)
;; MacOSX uses iodbc, which defines SQLWCHAR as wchar_t, as 32-bit
4)
((unix)
;; unixodbc defines WCHAR as 16-bit for compat w/ Windows
;; (even though Linux wchar_t is 32-bit)
2)))
(define-ffi-definer define-odbc odbc-lib) (define-ffi-definer define-odbc odbc-lib)
(define (ok-status? n)
(or (= n SQL_SUCCESS)
(= n SQL_SUCCESS_WITH_INFO)))
(define-odbc SQLAllocHandle (define-odbc SQLAllocHandle
(_fun (type : _sqlsmallint) (_fun (type : _sqlsmallint)
(parent : _sqlhandle/null) (parent : _sqlhandle/null)
@ -168,7 +180,8 @@ Docs at http://msdn.microsoft.com/en-us/library/ms712628%28v=VS.85%29.aspx
(len : (_ptr o _sqlsmallint)) (len : (_ptr o _sqlsmallint))
-> (status : _sqlreturn) -> (status : _sqlreturn)
-> (values status -> (values status
(bytes->string/utf-8 value #f 0 len))))) (and (ok-status? status)
(bytes->string/utf-8 value #f 0 len))))))
(define-odbc SQLGetFunctions (define-odbc SQLGetFunctions
(_fun (handle : _sqlhdbc) (_fun (handle : _sqlhdbc)
@ -211,7 +224,7 @@ Docs at http://msdn.microsoft.com/en-us/library/ms712628%28v=VS.85%29.aspx
(out-len : (_ptr o _sqlsmallint)) (out-len : (_ptr o _sqlsmallint))
-> (status : _sqlreturn) -> (status : _sqlreturn)
-> (values status -> (values status
(and (or (= status SQL_SUCCESS) (= status SQL_SUCCESS_WITH_INFO)) (and (ok-status? status)
(bytes->string/utf-8 out-buf #f 0 out-len))))) (bytes->string/utf-8 out-buf #f 0 out-len)))))
(define-odbc SQLDataSources (define-odbc SQLDataSources
@ -226,9 +239,9 @@ Docs at http://msdn.microsoft.com/en-us/library/ms712628%28v=VS.85%29.aspx
(descr-length : (_ptr o _sqlsmallint)) (descr-length : (_ptr o _sqlsmallint))
-> (status : _sqlreturn) -> (status : _sqlreturn)
-> (values status -> (values status
(and (or (= status SQL_SUCCESS) (= status SQL_SUCCESS_WITH_INFO)) (and (ok-status? status)
(bytes->string/utf-8 server-buf #f 0 server-length)) (bytes->string/utf-8 server-buf #f 0 server-length))
(and (or (= status SQL_SUCCESS) (= status SQL_SUCCESS_WITH_INFO)) (and (ok-status? status)
(bytes->string/utf-8 descr-buf #f 0 descr-length))))) (bytes->string/utf-8 descr-buf #f 0 descr-length)))))
(define-odbc SQLDrivers (define-odbc SQLDrivers
@ -242,7 +255,7 @@ Docs at http://msdn.microsoft.com/en-us/library/ms712628%28v=VS.85%29.aspx
((if attrs-buf (bytes-length attrs-buf) 0) : _sqlsmallint) ((if attrs-buf (bytes-length attrs-buf) 0) : _sqlsmallint)
(attrs-length : (_ptr o _sqlsmallint)) (attrs-length : (_ptr o _sqlsmallint))
-> (status : _sqlreturn) -> (status : _sqlreturn)
-> (if (or (= status SQL_SUCCESS) (= status SQL_SUCCESS_WITH_INFO)) -> (if (ok-status? status)
(values status (values status
(bytes->string/utf-8 driver-buf #f 0 driver-length) (bytes->string/utf-8 driver-buf #f 0 driver-length)
attrs-length) attrs-length)
@ -308,7 +321,8 @@ Docs at http://msdn.microsoft.com/en-us/library/ms712628%28v=VS.85%29.aspx
(nullable : (_ptr o _sqlsmallint)) (nullable : (_ptr o _sqlsmallint))
-> (status : _sqlreturn) -> (status : _sqlreturn)
-> (values status -> (values status
(bytes->string/utf-8 column-buf #f 0 column-len) (and (ok-status? status)
(bytes->string/utf-8 column-buf #f 0 column-len))
data-type size digits nullable))) data-type size digits nullable)))
(define-odbc SQLFetch (define-odbc SQLFetch
@ -356,9 +370,11 @@ Docs at http://msdn.microsoft.com/en-us/library/ms712628%28v=VS.85%29.aspx
(message-len : (_ptr o _sqlsmallint)) (message-len : (_ptr o _sqlsmallint))
-> (status : _sqlreturn) -> (status : _sqlreturn)
-> (values status -> (values status
(bytes->string/utf-8 sql-state-buf #\? 0 5) (and (ok-status? status)
(bytes->string/utf-8 sql-state-buf #\? 0 5))
native-errcode native-errcode
(bytes->string/utf-8 message-buf #\? 0 message-len)))) (and (ok-status? status)
(bytes->string/utf-8 message-buf #\? 0 message-len)))))
(define-odbc SQLEndTran (define-odbc SQLEndTran
(_fun (handle completion-type) :: (_fun (handle completion-type) ::

29
collects/db/private/odbc/main.rkt
View File

@ -1,22 +1,26 @@
#lang racket/base #lang racket/base
(require racket/class (require racket/class
racket/contract
"../generic/interfaces.rkt" "../generic/interfaces.rkt"
"../generic/place-client.rkt"
"connection.rkt" "connection.rkt"
"dbsystem.rkt" "dbsystem.rkt"
"ffi.rkt") "ffi.rkt")
(provide odbc-connect (provide odbc-connect
odbc-driver-connect odbc-driver-connect
odbc-data-sources odbc-data-sources
odbc-drivers odbc-drivers)
(rename-out [dbsystem odbc-dbsystem]))
(define (odbc-connect #:dsn dsn (define (odbc-connect #:dsn dsn
#:user [user #f] #:user [user #f]
#:password [auth #f] #:password [auth #f]
#:notice-handler [notice-handler void] #:notice-handler [notice-handler void]
#:strict-parameter-types? [strict-parameter-types? #f] #:strict-parameter-types? [strict-parameter-types? #f]
#:character-mode [char-mode 'wchar]) #:character-mode [char-mode 'wchar]
#:use-place [use-place #f])
(cond [use-place
(place-connect (list 'odbc dsn user auth strict-parameter-types? char-mode)
odbc-proxy%)]
[else
(let ([notice-handler (make-handler notice-handler "notice")]) (let ([notice-handler (make-handler notice-handler "notice")])
(call-with-env 'odbc-connect (call-with-env 'odbc-connect
(lambda (env) (lambda (env)
@ -29,12 +33,17 @@
(db db) (db db)
(notice-handler notice-handler) (notice-handler notice-handler)
(strict-parameter-types? strict-parameter-types?) (strict-parameter-types? strict-parameter-types?)
(char-mode char-mode))))))))) (char-mode char-mode))))))))]))
(define (odbc-driver-connect connection-string (define (odbc-driver-connect connection-string
#:notice-handler [notice-handler void] #:notice-handler [notice-handler void]
#:strict-parameter-types? [strict-parameter-types? #f] #:strict-parameter-types? [strict-parameter-types? #f]
#:character-mode [char-mode 'wchar]) #:character-mode [char-mode 'wchar]
#:use-place [use-place #f])
(cond [use-place
(place-connect (list 'odbc-driver connection-string strict-parameter-types? char-mode)
odbc-proxy%)]
[else
(let ([notice-handler (make-handler notice-handler "notice")]) (let ([notice-handler (make-handler notice-handler "notice")])
(call-with-env 'odbc-driver-connect (call-with-env 'odbc-driver-connect
(lambda (env) (lambda (env)
@ -47,7 +56,7 @@
(db db) (db db)
(notice-handler notice-handler) (notice-handler notice-handler)
(strict-parameter-types? strict-parameter-types?) (strict-parameter-types? strict-parameter-types?)
(char-mode char-mode))))))))) (char-mode char-mode))))))))]))
(define (odbc-data-sources) (define (odbc-data-sources)
(define server-buf (make-bytes 1024)) (define server-buf (make-bytes 1024))
@ -97,6 +106,12 @@
(let ([=-pos (caar m)]) (let ([=-pos (caar m)])
(cons (substring s 0 =-pos) (substring s (+ 1 =-pos)))))))) (cons (substring s 0 =-pos) (substring s (+ 1 =-pos))))))))
(define odbc-proxy%
(class place-proxy-connection%
(super-new)
(define/override (get-dbsystem) dbsystem)))
;; ---- ;; ----
;; Aux functions to free handles on error. ;; Aux functions to free handles on error.

9
collects/db/private/postgresql/connection.rkt
View File

@ -14,6 +14,13 @@
;; ======================================== ;; ========================================
;; connector<%>
;; Manages making connections
(define connector<%>
(interface ()
attach-to-ports ;; input-port output-port -> void
start-connection-protocol)) ;; string string string/#f -> void
(define connection-base% (define connection-base%
(class* transactions% (connection<%> connector<%>) (class* transactions% (connection<%> connector<%>)
(init-private notice-handler (init-private notice-handler
@ -396,6 +403,8 @@
(set! name-counter (add1 name-counter)) (set! name-counter (add1 name-counter))
(format "λmz_~a_~a" process-id n))) (format "λmz_~a_~a" process-id n)))
(define/public (get-base) this)
;; free-statement : prepared-statement -> void ;; free-statement : prepared-statement -> void
(define/public (free-statement pst) (define/public (free-statement pst)
(call-with-lock* 'free-statement (call-with-lock* 'free-statement

7
collects/db/private/postgresql/main.rkt
View File

@ -1,16 +1,13 @@
#lang racket/base #lang racket/base
(require racket/class (require racket/class
racket/contract
racket/tcp racket/tcp
openssl openssl
"../generic/interfaces.rkt" "../generic/interfaces.rkt"
"../generic/socket.rkt" "../generic/socket.rkt"
"connection.rkt" "connection.rkt")
"dbsystem.rkt")
(provide postgresql-connect (provide postgresql-connect
postgresql-guess-socket-path postgresql-guess-socket-path
postgresql-password-hash postgresql-password-hash)
(rename-out [dbsystem postgresql-dbsystem]))
(define (postgresql-connect #:user user (define (postgresql-connect #:user user
#:database database #:database database

78
collects/db/private/sqlite3/connection.rkt
View File

@ -1,6 +1,7 @@
#lang racket/base #lang racket/base
(require racket/class (require racket/class
ffi/unsafe ffi/unsafe
ffi/unsafe/atomic
"../generic/interfaces.rkt" "../generic/interfaces.rkt"
"../generic/prepared.rkt" "../generic/prepared.rkt"
"../generic/sql-data.rkt" "../generic/sql-data.rkt"
@ -18,7 +19,7 @@
busy-retry-delay) busy-retry-delay)
(define -db db) (define -db db)
(define statement-table (make-weak-hasheq)) (define statement-table (make-hasheq))
(define saved-tx-status #f) ;; set by with-lock, only valid while locked (define saved-tx-status #f) ;; set by with-lock, only valid while locked
(inherit call-with-lock* (inherit call-with-lock*
@ -36,14 +37,13 @@
(define/override (connected?) (and -db #t)) (define/override (connected?) (and -db #t))
(define/public (query fsym stmt) (define/public (query fsym stmt)
(let-values ([(stmt* info rows) (let-values ([(stmt* result)
(call-with-lock fsym (call-with-lock fsym
(lambda () (lambda ()
(check-valid-tx-status fsym) (check-valid-tx-status fsym)
(query1 fsym stmt)))]) (query1 fsym stmt)))])
(statement:after-exec stmt) (statement:after-exec stmt)
(cond [(pair? info) (rows-result info rows)] result))
[else (simple-result '())])))
(define/private (query1 fsym stmt) (define/private (query1 fsym stmt)
(let* ([stmt (cond [(string? stmt) (let* ([stmt (cond [(string? stmt)
@ -63,12 +63,23 @@
(load-param fsym db stmt i param)) (load-param fsym db stmt i param))
(let* ([info (let* ([info
(for/list ([i (in-range (sqlite3_column_count stmt))]) (for/list ([i (in-range (sqlite3_column_count stmt))])
`((name ,(sqlite3_column_name stmt i)) `((name . ,(sqlite3_column_name stmt i))
(decltype ,(sqlite3_column_decltype stmt i))))] (decltype . ,(sqlite3_column_decltype stmt i))))]
[rows (step* fsym db stmt)]) [rows (step* fsym db stmt)])
(HANDLE fsym (sqlite3_reset stmt)) (HANDLE fsym (sqlite3_reset stmt))
(HANDLE fsym (sqlite3_clear_bindings stmt)) (HANDLE fsym (sqlite3_clear_bindings stmt))
(values stmt info rows))))) (values stmt
(cond [(pair? info)
(rows-result info rows)]
[else
(let ([changes (sqlite3_changes db)])
(cond [(and (positive? changes)
#f ;; Note: currently disabled
#| FIXME: statement was INSERT stmt |#)
(simple-result
(list (cons 'last-insert-rowid
(sqlite3_last_insert_rowid db))))]
[else (simple-result '())]))]))))))
(define/private (load-param fsym db stmt i param) (define/private (load-param fsym db stmt i param)
(HANDLE fsym (HANDLE fsym
@ -149,31 +160,35 @@
pst))) pst)))
(define/public (disconnect) (define/public (disconnect)
;; FIXME: Reorder effects to be more robust if thread killed within disconnect (?)
(define (go) (define (go)
(when -db (start-atomic)
(let ([db -db] (let ([db -db])
[statements (hash-map statement-table (lambda (k v) k))])
(set! -db #f) (set! -db #f)
(set! statement-table #f) (end-atomic)
(when db
(let ([statements (hash-map statement-table (lambda (k v) k))])
(for ([pst (in-list statements)]) (for ([pst (in-list statements)])
(let ([stmt (send pst get-handle)]) (do-free-statement 'disconnect pst))
(when stmt (HANDLE 'disconnect2 (sqlite3_close db))
(send pst set-handle #f) (void)))))
(HANDLE 'disconnect (sqlite3_finalize stmt)))))
(HANDLE 'disconnect (sqlite3_close db))
(void))))
(call-with-lock* 'disconnect go go #f)) (call-with-lock* 'disconnect go go #f))
(define/public (get-base) this)
(define/public (free-statement pst) (define/public (free-statement pst)
(define (go) (define (go) (do-free-statement 'free-statement pst))
(let ([stmt (send pst get-handle)])
(when stmt
(send pst set-handle #f)
(HANDLE 'free-statement (sqlite3_finalize stmt))
(void))))
(call-with-lock* 'free-statement go go #f)) (call-with-lock* 'free-statement go go #f))
(define/private (do-free-statement fsym pst)
(start-atomic)
(let ([stmt (send pst get-handle)])
(send pst set-handle #f)
(end-atomic)
(hash-remove! statement-table pst)
(when stmt
(HANDLE fsym (sqlite3_finalize stmt))
(void))))
;; == Transactions ;; == Transactions
@ -198,7 +213,7 @@
(let ([db (get-db fsym)]) (let ([db (get-db fsym)])
(when (get-tx-status db) (when (get-tx-status db)
(error/already-in-tx fsym)) (error/already-in-tx fsym))
(let-values ([(stmt* _info _rows) (let-values ([(stmt* _result)
(query1 fsym "BEGIN TRANSACTION")]) (query1 fsym "BEGIN TRANSACTION")])
stmt*))))]) stmt*))))])
(statement:after-exec stmt) (statement:after-exec stmt)
@ -212,7 +227,7 @@
(unless (eq? mode 'rollback) (unless (eq? mode 'rollback)
(check-valid-tx-status fsym)) (check-valid-tx-status fsym))
(when (get-tx-status db) (when (get-tx-status db)
(let-values ([(stmt* _info _rows) (let-values ([(stmt* _result)
(case mode (case mode
((commit) ((commit)
(query1 fsym "COMMIT TRANSACTION")) (query1 fsym "COMMIT TRANSACTION"))
@ -230,14 +245,11 @@
;; schema ignored, because sqlite doesn't support ;; schema ignored, because sqlite doesn't support
(string-append "SELECT tbl_name from sqlite_master " (string-append "SELECT tbl_name from sqlite_master "
"WHERE type = 'table' or type = 'view'")]) "WHERE type = 'table' or type = 'view'")])
(let-values ([(stmt rows) (let-values ([(stmt result)
(call-with-lock fsym (call-with-lock fsym
(lambda () (lambda () (query1 fsym stmt)))])
(let-values ([(stmt _info rows)
(query1 fsym stmt)])
(values stmt rows))))])
(statement:after-exec stmt) (statement:after-exec stmt)
(for/list ([row (in-list rows)]) (for/list ([row (in-list (rows-result-rows result))])
(vector-ref row 0))))) (vector-ref row 0)))))
;; ---- ;; ----
@ -260,7 +272,7 @@
;; Can't figure out how to test... ;; Can't figure out how to test...
(define/private (handle-status who s) (define/private (handle-status who s)
(when (memv s maybe-rollback-status-list) (when (memv s maybe-rollback-status-list)
(when (and saved-tx-status (not (get-tx-status -db))) ;; was in trans, now not (when (and saved-tx-status -db (not (get-tx-status -db))) ;; was in trans, now not
(set! tx-status 'invalid))) (set! tx-status 'invalid)))
(handle-status* who s -db)) (handle-status* who s -db))

4
collects/db/private/sqlite3/dbsystem.rkt
View File

@ -1,8 +1,6 @@
#lang racket/base #lang racket/base
(require racket/class (require racket/class
"../generic/interfaces.rkt" "../generic/interfaces.rkt")
"../generic/sql-data.rkt"
"ffi-constants.rkt")
(provide dbsystem) (provide dbsystem)
(define sqlite3-dbsystem% (define sqlite3-dbsystem%

16
collects/db/private/sqlite3/ffi.rkt
View File

@ -132,6 +132,22 @@
(_fun _sqlite3_database (_fun _sqlite3_database
-> _bool)) -> _bool))
(define-sqlite sqlite3_next_stmt
(_fun _sqlite3_database _sqlite3_statement/null
-> _sqlite3_statement/null))
(define-sqlite sqlite3_sql
(_fun _sqlite3_statement
-> _string))
(define-sqlite sqlite3_changes
(_fun _sqlite3_database
-> _int))
(define-sqlite sqlite3_last_insert_rowid
(_fun _sqlite3_database
-> _int))
;; ---------------------------------------- ;; ----------------------------------------
#| #|

42
collects/db/private/sqlite3/main.rkt
View File

@ -1,34 +1,39 @@
#lang racket/base #lang racket/base
(require racket/class (require racket/class
racket/contract
ffi/file ffi/file
"../generic/place-client.rkt"
"connection.rkt" "connection.rkt"
"dbsystem.rkt" "dbsystem.rkt"
"ffi.rkt") "ffi.rkt")
(provide sqlite3-connect (provide sqlite3-connect)
(rename-out [dbsystem sqlite3-dbsystem]))
(define (sqlite3-connect #:database path-or-sym (define (sqlite3-connect #:database path
#:mode [mode 'read/write] #:mode [mode 'read/write]
#:busy-retry-delay [busy-retry-delay 0.1] #:busy-retry-delay [busy-retry-delay 0.1]
#:busy-retry-limit [busy-retry-limit 10]) #:busy-retry-limit [busy-retry-limit 10]
#:use-place [use-place #f])
(let ([path (let ([path
(cond [(symbol? path-or-sym) (case path
(case path-or-sym ((memory temporary) path)
;; Private, temporary in-memory (else
[(memory) #":memory:"] (let ([path (cleanse-path (path->complete-path path))])
;; Private, temporary on-disk
[(temporary) #""])]
[(or (path? path-or-sym) (string? path-or-sym))
(let ([path (cleanse-path (path->complete-path path-or-sym))])
(security-guard-check-file 'sqlite3-connect (security-guard-check-file 'sqlite3-connect
path path
(case mode (case mode
((read-only) '(read)) ((read-only) '(read))
(else '(read write)))) (else '(read write))))
(path->bytes path))])]) path)))])
(cond [use-place
(place-connect (list 'sqlite3 path mode busy-retry-delay busy-retry-limit)
sqlite-place-proxy%)]
[else
(let ([path-bytes
(case path
((memory) #":memory:")
((temporary) #"")
(else (path->bytes path)))])
(let-values ([(db open-status) (let-values ([(db open-status)
(sqlite3_open_v2 path (sqlite3_open_v2 path-bytes
(case mode (case mode
((read-only) SQLITE_OPEN_READONLY) ((read-only) SQLITE_OPEN_READONLY)
((read/write) SQLITE_OPEN_READWRITE) ((read/write) SQLITE_OPEN_READWRITE)
@ -38,4 +43,9 @@
(new connection% (new connection%
(db db) (db db)
(busy-retry-limit busy-retry-limit) (busy-retry-limit busy-retry-limit)
(busy-retry-delay busy-retry-delay))))) (busy-retry-delay busy-retry-delay))))])))
(define sqlite-place-proxy%
(class place-proxy-connection%
(super-new)
(define/override (get-dbsystem) dbsystem)))

9
collects/db/scribblings/config.rkt
View File

@ -1,21 +1,26 @@
#lang racket/base #lang racket/base
(require scribble/manual (require scribble/manual
scribble/eval scribble/eval
racket/sandbox
(for-label racket/base (for-label racket/base
racket/contract)) racket/contract))
(provide (all-defined-out) (provide (all-defined-out)
(for-label (all-from-out racket/base) (for-label (all-from-out racket/base)
(all-from-out racket/contract))) (all-from-out racket/contract)))
(define (tech/reference . pre-flows)
(apply tech #:doc '(lib "scribblings/reference/reference.scrbl") pre-flows))
;; ---- ;; ----
(define the-eval (make-base-eval)) (define the-eval (make-base-eval))
(void (void
(interaction-eval #:eval the-eval (interaction-eval #:eval the-eval
(require racket/class (require racket/class
db racket/pretty
db/base
db/util/datetime)) db/util/datetime))
(interaction-eval #:eval the-eval
(current-print pretty-print-handler))
(interaction-eval #:eval the-eval (interaction-eval #:eval the-eval
(define connection% (class object% (super-new)))) (define connection% (class object% (super-new))))
(interaction-eval #:eval the-eval (interaction-eval #:eval the-eval

36
collects/db/scribblings/connect.scrbl
View File

@ -16,6 +16,22 @@ administrative functions for managing connections.
@declare-exporting[db] @declare-exporting[db]
There are four kinds of base connection, and they are divided into two
groups: @deftech{wire-based connections} and @deftech{FFI-based
connections}. PostgreSQL and MySQL connections are wire-based, and
SQLite and ODBC connections are FFI-based.
Wire-based connections communicate using @tech/reference{ports}, which
do not cause other Racket threads to block. In contrast, all Racket
threads are blocked during an FFI call, so FFI-based connections can
seriously degrade the interactivity of a Racket program, particularly
if long-running queries are performed using the connection. This
problem can be avoided by creating the FFI-based connection in a
separate @tech/reference{place} using the @racket[#:use-place]
keyword argument. Such a connection will not block all Racket threads
during queries; the disadvantage is the cost of creating and
communicating with a separate @tech/reference{place}.
Base connections are made using the following functions. Base connections are made using the following functions.
@defproc[(postgresql-connect [#:user user string?] @defproc[(postgresql-connect [#:user user string?]
@ -188,7 +204,8 @@ Base connections are made using the following functions.
[#:busy-retry-limit busy-retry-limit [#:busy-retry-limit busy-retry-limit
(or/c exact-nonnegative-integer? +inf.0) 10] (or/c exact-nonnegative-integer? +inf.0) 10]
[#:busy-retry-delay busy-retry-delay [#:busy-retry-delay busy-retry-delay
(and/c rational? (not/c negative?)) 0.1]) (and/c rational? (not/c negative?)) 0.1]
[#:use-place use-place boolean? #f])
connection?]{ connection?]{
Opens the SQLite database at the file named by @racket[database], if Opens the SQLite database at the file named by @racket[database], if
@ -214,6 +231,10 @@ Base connections are made using the following functions.
attempted once. If after @racket[busy-retry-limit] retries the attempted once. If after @racket[busy-retry-limit] retries the
operation still does not succeed, an exception is raised. operation still does not succeed, an exception is raised.
If @racket[use-place] is true, the actual connection is created in
a distinct @tech/reference{place} for database connections and a
proxy is returned.
If the connection cannot be made, an exception is raised. If the connection cannot be made, an exception is raised.
@(examples/results @(examples/results
@ -234,7 +255,8 @@ Base connections are made using the following functions.
[#:strict-parameter-types? strict-parameter-types? boolean? #f] [#:strict-parameter-types? strict-parameter-types? boolean? #f]
[#:character-mode character-mode [#:character-mode character-mode
(or/c 'wchar 'utf-8 'latin-1) (or/c 'wchar 'utf-8 'latin-1)
'wchar]) 'wchar]
[#:use-place use-place boolean? #f])
connection?]{ connection?]{
Creates a connection to the ODBC Data Source named @racket[dsn]. The Creates a connection to the ODBC Data Source named @racket[dsn]. The
@ -258,6 +280,10 @@ Base connections are made using the following functions.
See @secref["odbc-status"] for notes on specific ODBC drivers and See @secref["odbc-status"] for notes on specific ODBC drivers and
recommendations for connection options. recommendations for connection options.
If @racket[use-place] is true, the actual connection is created in
a distinct @tech/reference{place} for database connections and a
proxy is returned.
If the connection cannot be made, an exception is raised. If the connection cannot be made, an exception is raised.
} }
@ -269,7 +295,8 @@ Base connections are made using the following functions.
[#:strict-parameter-types? strict-parameter-types? boolean? #f] [#:strict-parameter-types? strict-parameter-types? boolean? #f]
[#:character-mode character-mode [#:character-mode character-mode
(or/c 'wchar 'utf-8 'latin-1) (or/c 'wchar 'utf-8 'latin-1)
'wchar]) 'wchar]
[#:use-place use-place boolean? #f])
connection?]{ connection?]{
Creates a connection using an ODBC connection string containing a Creates a connection using an ODBC connection string containing a
@ -606,7 +633,8 @@ ODBC's DSNs.
[#:busy-retry-limit busy-retry-limit [#:busy-retry-limit busy-retry-limit
(or/c exact-nonnegative-integer? +inf.0) @#,absent] (or/c exact-nonnegative-integer? +inf.0) @#,absent]
[#:busy-retry-delay busy-retry-delay [#:busy-retry-delay busy-retry-delay
(and/c rational? (not/c negative?)) @#,absent]) (and/c rational? (not/c negative?)) @#,absent]
[#:use-place use-place boolean? @#,absent])
data-source?] data-source?]
@defproc[(odbc-data-source @defproc[(odbc-data-source
[#:dsn dsn (or/c string? #f) @#,absent] [#:dsn dsn (or/c string? #f) @#,absent]

16
collects/db/scribblings/db.scrbl
View File

@ -26,17 +26,15 @@ native client library is required.}
@item{@bold{@as-index{@hyperlink["http://www.sqlite.org"]{SQLite}} version @item{@bold{@as-index{@hyperlink["http://www.sqlite.org"]{SQLite}} version
3.} The SQLite native client library is required; see 3.} The SQLite native client library is required; see
@secref["sqlite3-native-libs"].} @secref["sqlite3-requirements"].}
@item{@bold{@as-index{ODBC}.} An ODBC Driver Manager and appropriate @item{@bold{@as-index{ODBC}.} An ODBC Driver Manager and appropriate
ODBC drivers are required; see @secref["odbc-native-libs"]. The ODBC drivers are required; see @secref["odbc-requirements"]. The
following additional database systems are known to work with this following database systems are known to work with this library via
library's ODBC support (see @secref["odbc-status"] for details): ODBC (see @secref["odbc-status"] for details):
@itemlist[ @bold{@as-index{@hyperlink["http://www.ibm.com/software/data/db2/"]{DB2}}},
@item{@bold{@as-index{@hyperlink["http://www.oracle.com"]{Oracle}}}} @bold{@as-index{@hyperlink["http://www.oracle.com"]{Oracle}}}, and
@item{@bold{@as-index{@hyperlink["http://www.ibm.com/software/data/db2/"]{DB2}}}} @bold{@as-index{@hyperlink["http://www.microsoft.com/sqlserver/"]{SQL Server}}}.}
@item{@bold{@as-index{@hyperlink["http://www.microsoft.com/sqlserver/"]{SQL Server}}}}
]}
] ]
The query operations are functional in spirit: queries return results The query operations are functional in spirit: queries return results

21
collects/db/scribblings/introduction.scrbl
View File

@ -202,15 +202,18 @@ web-server
] ]
The main problem with using one connection for all requests is that The main problem with using one connection for all requests is that
while all connection functions are thread-safe, two threads accessing multiple threads accessing the same connection are not properly
a connection concurrently may still interfere. For example, if two @hyperlink["http://en.wikipedia.org/wiki/Isolation_%28database_systems%29"]{isolated}. For
threads both attempt to start a new transaction, the second one will example, if two threads both attempt to start a new transaction, the
fail, because the first thread has already put the connection into an second one will fail, because the first thread has already put the
``in transaction'' state. And if one thread is accessing the connection into an ``in transaction'' state. And if one thread is
connection within a transaction and another thread issues a query, the accessing the connection within a transaction and another thread
second thread may see invalid data or even disrupt the work of the issues a query, the second thread may see invalid data or even disrupt
first thread (see the work of the first thread.
@hyperlink["http://en.wikipedia.org/wiki/Isolation_%28database_systems%29"]{isolation}).
A secondary problem is performance. A connection can only perform a
single query at a time, whereas most database systems are capable of
concurrent query processing.
The proper way to use database connections in a servlet is to create a The proper way to use database connections in a servlet is to create a
connection for each request and disconnect it when the request connection for each request and disconnect it when the request

141
collects/db/scribblings/notes.scrbl
View File

@ -4,25 +4,27 @@
scribble/struct scribble/struct
racket/sandbox racket/sandbox
"config.rkt" "config.rkt"
(for-label db)) (for-label db
setup/dirs))
@title[#:tag "notes"]{Notes} @title[#:tag "notes"]{Notes}
This section describes miscellaneous issues. This section discusses issues related to specific database systems.
@section[#:tag "connecting-to-server"]{Local Sockets for PostgreSQL and MySQL Servers} @section[#:tag "connecting-to-server"]{Local Sockets for PostgreSQL and MySQL Servers}
PostgreSQL and MySQL servers are sometimes configured by default to PostgreSQL and MySQL servers are sometimes configured by default to
listen only on local sockets (also called ``unix domain listen only on local sockets (also called ``unix domain
sockets''). This library provides support for communication over local sockets''). This library provides support for communication over local
sockets, but only on Linux (x86 and x86-64) and Mac OS X. If local sockets on Linux (x86 and x86-64) and Mac OS X. If local socket
socket communication is not available, the server must be reconfigured communication is not available, the server must be reconfigured to
to listen on a TCP port. listen on a TCP port.
The socket file for a PostgreSQL server is located in the directory The socket file for a PostgreSQL server is located in the directory
specified by the @tt{unix_socket_directory} variable in the specified by the @tt{unix_socket_directory} variable in the
@tt{postgresql.conf} server configuration file. For example, on @tt{postgresql.conf} server configuration file. For example, on
Ubuntu 10.10 running PostgreSQL 8.4, the socket directory is Ubuntu 11.04 running PostgreSQL 8.4, the socket directory is
@tt{/var/run/postgresql} and the socket file is @tt{/var/run/postgresql} and the socket file is
@tt{/var/run/postgresql/.s.PGSQL.5432}. Common socket paths may be @tt{/var/run/postgresql/.s.PGSQL.5432}. Common socket paths may be
searched automatically using the @racket[postgresql-guess-socket-path] searched automatically using the @racket[postgresql-guess-socket-path]
@ -30,20 +32,19 @@ function.
The socket file for a MySQL server is located at the path specified by The socket file for a MySQL server is located at the path specified by
the @tt{socket} variable in the @tt{my.cnf} configuration file. For the @tt{socket} variable in the @tt{my.cnf} configuration file. For
example, on Ubuntu 10.10 running MySQL 5.1, the socket is located at example, on Ubuntu 11.04 running MySQL 5.1, the socket is located at
@tt{/var/run/mysqld/mysqld.sock}. Common socket paths for MySQL can be @tt{/var/run/mysqld/mysqld.sock}. Common socket paths for MySQL can be
searched using the @racket[mysql-guess-socket-path] function. searched using the @racket[mysql-guess-socket-path] function.
@section{Database Character Encodings} @section{PostgreSQL Database Character Encoding}
In most cases, a PostgreSQL or MySQL database's character encoding is In most cases, a database's character encoding is irrelevant, since
irrelevant, since the connect function always requests translation to the connect function always requests translation to Unicode (UTF-8)
Unicode (UTF-8) when creating a connection. If a PostgreSQL database's when creating a connection. If a PostgreSQL database's character
character encoding is @tt{SQL_ASCII}, however, PostgreSQL will not encoding is @tt{SQL_ASCII}, however, PostgreSQL will not honor the
honor the connection encoding; it will instead send untranslated connection encoding; it will instead send untranslated octets, which
octets, which will cause corrupt data or internal errors in the client will cause corrupt data or internal errors in the client connection.
connection.
To convert a PostgreSQL database from @tt{SQL_ASCII} to something To convert a PostgreSQL database from @tt{SQL_ASCII} to something
sensible, @tt{pg_dump} the database, recode the dump file (using a sensible, @tt{pg_dump} the database, recode the dump file (using a
@ -51,31 +52,17 @@ utility such as @tt{iconv}), create a new database with the desired
encoding, and @tt{pg_restore} from the recoded dump file. encoding, and @tt{pg_restore} from the recoded dump file.
@section{Prepared Query Parameter Types}
Different database systems vary in their handling of query parameter
types. For example, consider the following parameterized SQL
statement:
@tt{SELECT 1 + ?;}
PostgreSQL reports an expected type of @tt{integer} for the parameter and
will not accept other types. MySQL and SQLite, in contrast, report no
useful parameter type information, and ODBC connections vary in
behavior based on the driver, the data source configuration, and the
connection parameters (see @secref["odbc-status"] for specific notes).
@section{PostgreSQL Authentication} @section{PostgreSQL Authentication}
PostgreSQL supports a large variety of authentication mechanisms, PostgreSQL supports a large variety of
controlled by the @tt{pg_hba.conf} server configuration file. This @hyperlink["http://www.postgresql.org/docs/8.4/static/auth-pg-hba-conf.html"]{authentication
library currently supports only cleartext and md5-hashed passwords, mechanisms}, controlled by the @tt{pg_hba.conf} server configuration
and it does not send cleartext passwords unless explicitly ordered to file. This library currently supports only cleartext and md5-hashed
(see @racket[postgresql-connect]). These correspond to the @tt{md5} passwords, and it does not send cleartext passwords unless explicitly
and @tt{password} authentication methods in the parlance of ordered to (see @racket[postgresql-connect]). These correspond to the
@tt{md5} and @tt{password} authentication methods in the parlance of
@tt{pg_hba.conf}, respectively. On Linux, @tt{ident} authentication is @tt{pg_hba.conf}, respectively. On Linux, @tt{ident} authentication is
automatically supported for unix domain sockets (but not TCP). The automatically supported for local sockets, but not TCP sockets. The
@tt{gss}, @tt{sspi}, @tt{krb5}, @tt{pam}, and @tt{ldap} methods are @tt{gss}, @tt{sspi}, @tt{krb5}, @tt{pam}, and @tt{ldap} methods are
not supported. not supported.
@ -89,36 +76,69 @@ plugins}. The only plugin currently supported by this library is
password authentication mechanism used since version 4.1. password authentication mechanism used since version 4.1.
@section[#:tag "sqlite3-native-libs"]{SQLite Native Library} @section[#:tag "sqlite3-requirements"]{SQLite Requirements}
SQLite support requires the appropriate native library, specifically SQLite support requires the appropriate native library.
@tt{libsqlite3.so.0} on Unix or @tt{sqlite3.dll} on Windows.
@itemlist[
@item{On Windows, the library is @tt{sqlite3.dll}. It can be obtained
from @hyperlink["http://www.sqlite.org/download.html"]{the SQLite
download page}; the DLL file should be extracted and placed into one
of the directories produced by
@racketblock[(begin (require setup/dirs) (get-lib-search-dirs))]}
@item{On Mac OS X, the library is @tt{libsqlite3.0.dylib}, which is
included (in @tt{/usr/lib}) in Mac OS X version 10.4 onwards.}
@item{On Linux, the library is @tt{libsqlite3.so.0}. It is included in
the @tt{libsqlite3-0} package in Debian/Ubuntu and in the @tt{sqlite}
package in Red Hat.}
]
@section[#:tag "odbc-native-libs"]{ODBC Native Libraries} @section[#:tag "odbc-requirements"]{ODBC Requirements}
ODBC support requires the appropriate native library, specifically ODBC requires the appropriate driver manager native library as well as
@tt{libodbc.so.1} (from unixODBC; iODBC is not supported) on Unix or driver native libraries for each database system you want use ODBC to
@tt{odbc32.dll} on Windows. In addition, the appropriate ODBC Drivers connect to.
must be installed and any Data Sources configured.
@itemlist[
@item{On Windows, the driver manager is @tt{odbc32.dll}, which is
included automatically with Windows.}
@item{On Mac OS X, the driver manager is @tt{libiodbc.2.dylib}
(@hyperlink["http://www.iodbc.org"]{iODBC}), which is included (in
@tt{/usr/lib}) in Mac OS X version 10.2 onwards.}
@item{On Linux, the driver manager is @tt{libodbc.so.1}
(@hyperlink["http://www.unixodbc.org"]{unixODBC}---iODBC is not
supported). It is available from the @tt{unixodbc} package in
Debian/Ubuntu and in the @tt{unixODBC} package in Red Hat.}
]
In addition, you must install the appropriate ODBC Drivers and
configure Data Sources. Refer to the ODBC documentation for the
specific database system for more information.
@section[#:tag "odbc-status"]{ODBC Support Status} @section[#:tag "odbc-status"]{ODBC Status}
ODBC support is experimental. This library is compatible only with ODBC support is experimental. The behavior of ODBC connections can
ODBC 3.x Driver Managers. The behavior of ODBC connections can vary vary widely depending on the driver in use and even the configuration
widely depending on the driver in use and even the configuration of a of a particular data source.
particular data source.
The following sections describe the configurations that this library The following sections describe the configurations that this library
has been tested with. The platform @bold{win32} means Windows Vista on has been tested with.
a 32-bit processor and @bold{linux} means Ubuntu 11.04 and unixODBC on
both x86 (32-bit) and x86-64 processors, unless otherwise
specified. The iODBC Driver Manager is not supported.
Reports of success or failure on other platforms or with other drivers Reports of success or failure on other platforms or with other drivers
would be appreciated. would be appreciated.
@;{
** There's no reason to actually use the following drivers. They're just
** useful for testing ODBC support.
@subsection{PostgreSQL ODBC Driver} @subsection{PostgreSQL ODBC Driver}
The PostgreSQL ODBC driver version 09.00.0300 has been tested on The PostgreSQL ODBC driver version 09.00.0300 has been tested on
@ -149,15 +169,18 @@ Furthermore, this driver interprets the declared types of columns
strictly, replacing nonconforming values in query results with strictly, replacing nonconforming values in query results with
@tt{NULL}. All computed columns, even those with explicit @tt{CAST}s, @tt{NULL}. All computed columns, even those with explicit @tt{CAST}s,
seem to be returned as @tt{text}. seem to be returned as @tt{text}.
}
@subsection{DB2 ODBC Driver} @subsection{DB2 ODBC Driver}
The driver from IBM DB2 Express-C v9.7 has been tested on @bold{linux} The driver from IBM DB2 Express-C v9.7 has been tested on Ubuntu 11.04
(32-bit only). (32-bit only).
For a typical installation where the instance resides at For a typical installation where the instance resides at
@tt{/home/db2inst1}, set the following option in the Driver @tt{/home/db2inst1}, set the following option in the Driver
configuration: @tt{Driver = /home/db2inst1/sqllib/lib32/libdb2.so}. configuration: @tt{Driver =
/home/db2inst1/sqllib/lib32/libdb2.so}. (The path would presumably be
different for a 64-bit installation.)
The DB2 driver does not seem to accept a separate argument for the The DB2 driver does not seem to accept a separate argument for the
database to connect to; it must be the same as the Data Source name. database to connect to; it must be the same as the Data Source name.
@ -165,7 +188,7 @@ database to connect to; it must be the same as the Data Source name.
@subsection{Oracle ODBC Driver} @subsection{Oracle ODBC Driver}
The driver from Oracle Database 10g Release 2 Express Edition has been The driver from Oracle Database 10g Release 2 Express Edition has been
tested on @bold{linux} (32-bit only). tested on Ubuntu 11.04 (32-bit only).
It seems the @tt{ORACLE_HOME} and @tt{LD_LIBRARY_PATH} environment It seems the @tt{ORACLE_HOME} and @tt{LD_LIBRARY_PATH} environment
variables must be set according to the @tt{oracle_env.{csh,sh}} script variables must be set according to the @tt{oracle_env.{csh,sh}} script
@ -185,5 +208,5 @@ Maybe Oracle bug? See:
@subsection{SQL Server ODBC Driver} @subsection{SQL Server ODBC Driver}
Basic SQL Server support has been verified on @bold{win32}, but the Basic SQL Server support has been verified on Windows (32-bit only),
automated test suite has not yet been adapted and run. but the automated test suite has not yet been adapted and run.

92
collects/db/scribblings/query.scrbl
View File

@ -68,8 +68,7 @@ way to make kill-safe connections.
All query functions require both a connection and a All query functions require both a connection and a
@deftech{statement}, which is one of the following: @deftech{statement}, which is one of the following:
@itemlist[ @itemlist[
@item{a string containing a single SQL statement, possibly with @item{a string containing a single SQL statement}
parameters}
@item{a @tech{prepared statement} produced by @racket[prepare]} @item{a @tech{prepared statement} produced by @racket[prepare]}
@item{a @tech{virtual statement} produced by @item{a @tech{virtual statement} produced by
@racket[virtual-statement]} @racket[virtual-statement]}
@ -78,6 +77,29 @@ All query functions require both a connection and a
@item{an instance of a struct type that implements @racket[prop:statement]} @item{an instance of a struct type that implements @racket[prop:statement]}
] ]
A SQL statement may contain parameter placeholders that stand for SQL
scalar values. The parameter values must be supplied when the
statement is executed; the parameterized statement and parameter
values are sent to the database back end, which combines them
correctly and safely.
Use parameters instead of Racket string interpolation (eg,
@racket[format] or @racket[string-append]) to avoid
@hyperlink["http://xkcd.com/327/"]{SQL injection}, where a string
intended to represent a SQL scalar value is interpreted as---possibly
malicious---SQL code instead.
The syntax of placeholders varies depending on the database
system. For example:
@centered{
@tabbing{
PostgreSQL: @& @tt{select * from the_numbers where n > $1;} @//
MySQL, ODBC: @& @tt{select * from the_numbers where n > ?;} @//
SQLite: @& supports both syntaxes (plus others)
}
}
@defproc[(statement? [x any/c]) boolean?]{ @defproc[(statement? [x any/c]) boolean?]{
Returns @racket[#t] if @racket[x] is a @tech{statement}, @racket[#f] Returns @racket[#t] if @racket[x] is a @tech{statement}, @racket[#f]
@ -118,7 +140,13 @@ The types of parameters and returned fields are described in
@defproc[(query-rows [connection connection?] @defproc[(query-rows [connection connection?]
[stmt statement?] [stmt statement?]
[arg any/c] ...) [arg any/c] ...
[#:group grouping-fields
(or/c (vectorof string?) (listof (vectorof string?)))
null]
[#:group-mode group-mode
(listof (or/c 'preserve-null-rows 'list))
null])
(listof vector?)]{ (listof vector?)]{
Executes a SQL query, which must produce rows, and returns the list Executes a SQL query, which must produce rows, and returns the list
@ -130,6 +158,9 @@ The types of parameters and returned fields are described in
[(query-rows c "select 17") [(query-rows c "select 17")
(list (vector 17))] (list (vector 17))]
] ]
If @racket[grouping-fields] is not empty, the result is the same as if
@racket[group-rows] had been called on the result rows.
} }
@defproc[(query-list [connection connection?] @defproc[(query-list [connection connection?]
@ -286,23 +317,56 @@ future version of this library (even new minor versions).
supports both rows-returning and effect-only queries. supports both rows-returning and effect-only queries.
} }
@defproc[(group-rows [result rows-result?]
[#:group grouping-fields
(or/c (vectorof string?) (listof (vectorof string?)))]
[#:group-mode group-mode
(listof (or/c 'preserve-null-rows 'list))
null])
rows-result?]{
If @racket[grouping-fields] is a vector, the elements must be names of
fields in @racket[result], and @racket[result]'s rows are regrouped
using the given fields. Each grouped row contains N+1 fields; the
first N fields are the @racket[grouping-fields], and the final field
is a list of ``residual rows'' over the rest of the fields. A residual
row of all NULLs is dropped (for convenient processing of @tt{OUTER
JOIN} results) unless @racket[group-mode] includes
@racket['preserve-null-rows]. If @racket[group-mode] contains
@racket['list], there must be exactly one residual field, and its
values are included without a vector wrapper (similar to
@racket[query-list]).
@examples[#:eval the-eval
(define vehicles-result
(rows-result
'(((name . "type")) ((name . "maker")) ((name . "model")))
`(#("car" "honda" "civic")
#("car" "ford" "focus")
#("car" "ford" "pinto")
#("bike" "giant" "boulder")
#("bike" "schwinn" ,sql-null))))
(group-rows vehicles-result
#:group '(#("type")))
]
The @racket[grouping-fields] argument may also be a list of vectors;
in that case, the grouping process is repeated for each set of
grouping fields. The grouping fields must be distinct.
@examples[#:eval the-eval
(group-rows vehicles-result
#:group '(#("type") #("maker"))
#:group-mode '(list))
]
}
@section{Prepared Statements} @section{Prepared Statements}
A @deftech{prepared statement} is the result of a call to A @deftech{prepared statement} is the result of a call to
@racket[prepare]. @racket[prepare].
The syntax of parameterized queries varies depending on the database
system. For example:
@centered{
@tabbing{
PostgreSQL: @& @tt{select * from the_numbers where n > $1;} @//
MySQL, ODBC: @& @tt{select * from the_numbers where n > ?;} @//
SQLite: @& supports both syntaxes (plus others)
}
}
Any server-side or native-library resources associated with a prepared Any server-side or native-library resources associated with a prepared
statement are released when the prepared statement is statement are released when the prepared statement is
garbage-collected or when the connection that owns it is closed; garbage-collected or when the connection that owns it is closed;

140
collects/db/scribblings/sql-types.scrbl
View File

@ -2,7 +2,7 @@
@(require scribble/manual @(require scribble/manual
scribble/eval scribble/eval
scribble/struct scribble/struct
scheme/sandbox racket/sandbox
"config.rkt" "config.rkt"
"tabbing.rkt" "tabbing.rkt"
(for-label (prefix-in srfi: srfi/19) (for-label (prefix-in srfi: srfi/19)
@ -57,33 +57,33 @@ along with their corresponding Racket representations.
@centered{ @centered{
@tabbing{ @tabbing{
@bold{PostgreSQL type} @& @bold{pg_type.typname} @& @bold{Racket type} @// @bold{PostgreSQL type} @& @bold{pg_type.typname} @& @bold{Racket type} @//
@racket['boolean] @& @tt{bool} @& @scheme[boolean?] @// @racket['boolean] @& @tt{bool} @& @racket[boolean?] @//
@racket['char1] @& @tt{char} @& @scheme[char?] @// @racket['char1] @& @tt{char} @& @racket[char?] @//
@racket['smallint] @& @tt{int2} @& @scheme[exact-integer?] @// @racket['smallint] @& @tt{int2} @& @racket[exact-integer?] @//
@racket['integer] @& @tt{int4} @& @scheme[exact-integer?] @// @racket['integer] @& @tt{int4} @& @racket[exact-integer?] @//
@racket['bigint] @& @tt{int8} @& @scheme[exact-integer?] @// @racket['bigint] @& @tt{int8} @& @racket[exact-integer?] @//
@racket['real] @& @tt{float4} @& @scheme[real?] @// @racket['real] @& @tt{float4} @& @racket[real?] @//
@racket['double] @& @tt{float8} @& @scheme[real?] @// @racket['double] @& @tt{float8} @& @racket[real?] @//
@racket['decimal] @& @tt{numeric} @& @scheme[number?] @// @racket['decimal] @& @tt{numeric} @& @racket[number?] @//
@racket['character] @& @tt{bpchar} @& @scheme[string?] @// @racket['character] @& @tt{bpchar} @& @racket[string?] @//
@racket['varchar] @& @tt{varchar} @& @scheme[string?] @// @racket['varchar] @& @tt{varchar} @& @racket[string?] @//
@racket['text] @& @tt{text} @& @scheme[string?] @// @racket['text] @& @tt{text} @& @racket[string?] @//
@racket['bytea] @& @tt{bytea} @& @scheme[bytes?] @// @racket['bytea] @& @tt{bytea} @& @racket[bytes?] @//
@racket['date] @& @tt{date} @& @scheme[sql-date?] @// @racket['date] @& @tt{date} @& @racket[sql-date?] @//
@racket['time] @& @tt{time} @& @scheme[sql-time?] @// @racket['time] @& @tt{time} @& @racket[sql-time?] @//
@racket['timetz] @& @tt{timetz} @& @scheme[sql-time?] @// @racket['timetz] @& @tt{timetz} @& @racket[sql-time?] @//
@racket['timestamp] @& @tt{timestamp} @& @scheme[sql-timestamp?] @// @racket['timestamp] @& @tt{timestamp} @& @racket[sql-timestamp?] @//
@racket['timestamptz] @& @tt{timestamptz} @& @scheme[sql-timestamp?] @// @racket['timestamptz] @& @tt{timestamptz} @& @racket[sql-timestamp?] @//
@racket['interval] @& @tt{interval} @& @scheme[sql-interval?] @// @racket['interval] @& @tt{interval} @& @racket[sql-interval?] @//
@racket['bit] @& @tt{bit} @& @scheme[sql-bits?] @// @racket['bit] @& @tt{bit} @& @racket[sql-bits?] @//
@racket['varbit] @& @tt{varbit} @& @scheme[sql-bits?] @// @racket['varbit] @& @tt{varbit} @& @racket[sql-bits?] @//
@racket['point] @& @tt{point} @& @scheme[point?] @// @racket['point] @& @tt{point} @& @racket[point?] @//
@racket['lseg] @& @tt{lseg} @& @scheme[line?] @// @racket['lseg] @& @tt{lseg} @& @racket[line?] @//
@racket['path] @& @tt{path} @& @scheme[pg-path?] @// @racket['path] @& @tt{path} @& @racket[pg-path?] @//
@racket['box] @& @tt{box} @& @scheme[pg-box?] @// @racket['box] @& @tt{box} @& @racket[pg-box?] @//
@racket['polygon] @& @tt{polygon} @& @scheme[polygon?] @// @racket['polygon] @& @tt{polygon} @& @racket[polygon?] @//
@racket['circle] @& @tt{circle} @& @scheme[pg-circle?] @racket['circle] @& @tt{circle} @& @racket[pg-circle?]
} }
} }
@ -92,7 +92,7 @@ syntax (the quotation marks are significant), is one byte, essentially
a tiny integer written as a character. a tiny integer written as a character.
A SQL value of type @tt{decimal} is converted to either an exact A SQL value of type @tt{decimal} is converted to either an exact
rational or @scheme[+nan.0]. When converting Racket values to SQL rational or @racket[+nan.0]. When converting Racket values to SQL
@tt{decimal}, exact rational values representable by finite decimal @tt{decimal}, exact rational values representable by finite decimal
strings are converted without loss of precision. (Precision may be strings are converted without loss of precision. (Precision may be
lost, of course, if the value is then stored in a database field of lost, of course, if the value is then stored in a database field of
@ -136,19 +136,19 @@ with their corresponding Racket representations.
@centered{ @centered{
@tabbing[#:spacing 8]{ @tabbing[#:spacing 8]{
@bold{MySQL type} @& @bold{Racket type} @// @bold{MySQL type} @& @bold{Racket type} @//
@racket['integer] @& @scheme[exact-integer?] @// @racket['integer] @& @racket[exact-integer?] @//
@racket['tinyint] @& @scheme[exact-integer?] @// @racket['tinyint] @& @racket[exact-integer?] @//
@racket['smallint] @& @scheme[exact-integer?] @// @racket['smallint] @& @racket[exact-integer?] @//
@racket['mediumint] @& @scheme[exact-integer?] @// @racket['mediumint] @& @racket[exact-integer?] @//
@racket['bigint] @& @scheme[exact-integer?] @// @racket['bigint] @& @racket[exact-integer?] @//
@racket['real] @& @scheme[real?] @// @racket['real] @& @racket[real?] @//
@racket['double] @& @scheme[real?] @// @racket['double] @& @racket[real?] @//
@racket['decimal] @& @scheme[exact?] @// @racket['decimal] @& @racket[exact?] @//
@racket['varchar] @& @scheme[string?] @// @racket['varchar] @& @racket[string?] @//
@racket['var-string] @& @scheme[string?] or @scheme[bytes?], but see below @// @racket['var-string] @& @racket[string?] or @racket[bytes?], but see below @//
@racket['date] @& @scheme[sql-date?] @// @racket['date] @& @racket[sql-date?] @//
@racket['time] @& @scheme[sql-time?] or @racket[sql-day-time-interval?] @// @racket['time] @& @racket[sql-time?] or @racket[sql-day-time-interval?] @//
@racket['datetime] @& @scheme[sql-timestamp?] @// @racket['datetime] @& @racket[sql-timestamp?] @//
@racket['blob] @& @racket[bytes?] @// @racket['blob] @& @racket[bytes?] @//
@racket['tinyblob] @& @racket[bytes?] @// @racket['tinyblob] @& @racket[bytes?] @//
@ -195,10 +195,10 @@ constraints (with the exception of @tt{integer primary key}) on
@centered{ @centered{
@tabbing{ @tabbing{
@bold{SQLite storage class} @& @bold{Racket type} @// @bold{SQLite storage class} @& @bold{Racket type} @//
@tt{integer} @& @scheme[exact-integer?] @// @tt{integer} @& @racket[exact-integer?] @//
@tt{real} @& @scheme[real?] @// @tt{real} @& @racket[real?] @//
@tt{text} @& @scheme[string?] @// @tt{text} @& @racket[string?] @//
@tt{blob} @& @scheme[bytes?] @tt{blob} @& @racket[bytes?]
} }
} }
@ -229,26 +229,26 @@ along with their corresponding Racket representations.
@centered{ @centered{
@tabbing[#:spacing 8]{ @tabbing[#:spacing 8]{
@bold{ODBC type} @& @bold{Racket type} @// @bold{ODBC type} @& @bold{Racket type} @//
@racket['character] @& @scheme[string?] @// @racket['character] @& @racket[string?] @//
@racket['varchar] @& @scheme[string?] @// @racket['varchar] @& @racket[string?] @//
@racket['longvarchar] @& @scheme[string?] @// @racket['longvarchar] @& @racket[string?] @//
@racket['numeric] @& @scheme[rational?] @// @racket['numeric] @& @racket[rational?] @//
@racket['decimal] @& @scheme[rational?] @// @racket['decimal] @& @racket[rational?] @//
@racket['integer] @& @scheme[exact-integer?] @// @racket['integer] @& @racket[exact-integer?] @//
@racket['tinyint] @& @scheme[exact-integer?] @// @racket['tinyint] @& @racket[exact-integer?] @//
@racket['smallint] @& @scheme[exact-integer?] @// @racket['smallint] @& @racket[exact-integer?] @//
@racket['bigint] @& @scheme[exact-integer?] @// @racket['bigint] @& @racket[exact-integer?] @//
@racket['float] @& @scheme[real?] @// @racket['float] @& @racket[real?] @//
@racket['real] @& @scheme[real?] @// @racket['real] @& @racket[real?] @//
@racket['double] @& @scheme[real?] @// @racket['double] @& @racket[real?] @//
@racket['date] @& @scheme[sql-date?] @// @racket['date] @& @racket[sql-date?] @//
@racket['time] @& @scheme[sql-time?] @// @racket['time] @& @racket[sql-time?] @//
@racket['datetime] @& @scheme[sql-timestamp?] @// @racket['datetime] @& @racket[sql-timestamp?] @//
@racket['timestamp] @& @scheme[sql-timestamp?] @// @racket['timestamp] @& @racket[sql-timestamp?] @//
@racket['binary] @& @scheme[bytes?] @// @racket['binary] @& @racket[bytes?] @//
@racket['varbinary] @& @scheme[bytes?] @// @racket['varbinary] @& @racket[bytes?] @//
@racket['longvarbinary] @& @scheme[bytes?] @// @racket['longvarbinary] @& @racket[bytes?] @//
@racket['bit1] @& @scheme[boolean?] @racket['bit1] @& @racket[boolean?]
} }
} }
@ -281,13 +281,13 @@ that have no existing appropriate counterpart in Racket.
@subsection{SQL NULL} @subsection{SQL NULL}
SQL @tt{NULL} is translated into the unique @scheme[sql-null] value. SQL @tt{NULL} is translated into the unique @racket[sql-null] value.
@defthing[sql-null sql-null?]{ @defthing[sql-null sql-null?]{
A special value used to represent @tt{NULL} values in query A special value used to represent @tt{NULL} values in query
results. The @scheme[sql-null] value may be recognized using results. The @racket[sql-null] value may be recognized using
@scheme[eq?]. @racket[eq?].
@(examples/results @(examples/results
[(query-value c "select NULL") [(query-value c "select NULL")
@ -362,12 +362,12 @@ values.
Represents SQL times and timestamps. Represents SQL times and timestamps.
The @scheme[tz] field indicates the time zone offset as the number The @racket[tz] field indicates the time zone offset as the number
of seconds east of GMT (as in SRFI 19). If @racket[tz] is of seconds east of GMT (as in SRFI 19). If @racket[tz] is
@racket[#f], the time or timestamp does not carry time zone @racket[#f], the time or timestamp does not carry time zone
information. information.
The @scheme[sql-time] and @scheme[sql-timestamp] structures store The @racket[sql-time] and @racket[sql-timestamp] structures store
fractional seconds to nanosecond precision for compatibility with fractional seconds to nanosecond precision for compatibility with
SRFI 19. Note, however, that database systems generally do not SRFI 19. Note, however, that database systems generally do not
support nanosecond precision; PostgreSQL, for example, only supports support nanosecond precision; PostgreSQL, for example, only supports

2
collects/db/scribblings/util.scrbl
View File

@ -2,7 +2,7 @@
@(require scribble/manual @(require scribble/manual
scribble/eval scribble/eval
scribble/struct scribble/struct
scheme/sandbox racket/sandbox
"config.rkt" "config.rkt"
(for-label db db/util/datetime db/util/geometry db/util/postgresql)) (for-label db db/util/datetime db/util/geometry db/util/postgresql))

5
collects/db/sqlite3.rkt
View File

@ -9,5 +9,6 @@
(->* (#:database (or/c path-string? 'memory 'temporary)) (->* (#:database (or/c path-string? 'memory 'temporary))
(#:mode (or/c 'read-only 'read/write 'create) (#:mode (or/c 'read-only 'read/write 'create)
#:busy-retry-limit (or/c exact-nonnegative-integer? +inf.0) #:busy-retry-limit (or/c exact-nonnegative-integer? +inf.0)
#:busy-retry-delay (and/c rational? (not/c negative?))) #:busy-retry-delay (and/c rational? (not/c negative?))
any/c)]) #:use-place any/c)
connection?)])

3
collects/db/util/private/geometry.rkt
View File

@ -1,6 +1,5 @@
#lang racket/base #lang racket/base
(require racket/contract (require racket/list)
racket/list)
(provide (all-defined-out)) (provide (all-defined-out))
#| #|

4
collects/deinprogramm/signature/module-begin.rkt
View File

@ -174,7 +174,7 @@
;; Lift out certain forms to make them visible to the module ;; Lift out certain forms to make them visible to the module
;; expander: ;; expander:
(syntax-case e2 (#%require #%provide (syntax-case e2 (#%require #%provide
define-syntaxes define-values-for-syntax define-values begin define-syntaxes begin-for-syntax define-values begin
define-record-procedures define-record-procedures-2 define-record-procedures define-record-procedures-2
define-record-procedures-parametric define-record-procedures-parametric-2 define-record-procedures-parametric define-record-procedures-parametric-2
define-contract :) define-contract :)
@ -184,7 +184,7 @@
#`(begin #,e2 (frm e3s #,e1s #,def-ids))) #`(begin #,e2 (frm e3s #,e1s #,def-ids)))
((define-syntaxes (id ...) . _) ((define-syntaxes (id ...) . _)
#`(begin #,e2 (frm e3s #,e1s (id ... . #,def-ids)))) #`(begin #,e2 (frm e3s #,e1s (id ... . #,def-ids))))
((define-values-for-syntax . _) ((begin-for-syntax . _)
#`(begin #,e2 (frm e3s #,e1s #,def-ids))) #`(begin #,e2 (frm e3s #,e1s #,def-ids)))
((begin b1 ...) ((begin b1 ...)
(syntax-track-origin (syntax-track-origin

5
collects/drracket/private/auto-language.rkt
View File

@ -1,4 +1,4 @@
#lang typed-scheme #lang typed/racket/base
(require typed/framework/framework (require typed/framework/framework
typed/mred/mred typed/mred/mred
@ -6,9 +6,6 @@
(provide pick-new-language looks-like-module?) (provide pick-new-language looks-like-module?)
(: reader-tag String)
(define reader-tag "#reader")
(define-type-alias (Language:Language% Settings) (define-type-alias (Language:Language% Settings)
(Class () () ([get-reader-module (-> Sexp)] (Class () () ([get-reader-module (-> Sexp)]
[get-metadata-lines (-> Number)] [get-metadata-lines (-> Number)]

12
collects/drracket/private/debug.rkt
View File

@ -900,7 +900,8 @@ profile todo:
(message-box (string-constant drscheme) (message-box (string-constant drscheme)
(string-constant editor-changed-since-srcloc-recorded) (string-constant editor-changed-since-srcloc-recorded)
frame frame
'(ok caution)))) '(ok caution)
#:dialog-mixin frame:focus-table-mixin)))
(when (and rep editor) (when (and rep editor)
(when (is-a? editor text:basic<%>) (when (is-a? editor text:basic<%>)
(send rep highlight-errors same-src-srclocs '()) (send rep highlight-errors same-src-srclocs '())
@ -1007,7 +1008,8 @@ profile todo:
(string-constant test-coverage-clear-and-do-not-ask-again) (string-constant test-coverage-clear-and-do-not-ask-again)
(send (get-canvas) get-top-level-window) (send (get-canvas) get-top-level-window)
'(default=1) '(default=1)
2)]) 2
#:dialog-mixin frame:focus-table-mixin)])
(case msg-box-result (case msg-box-result
[(1) #t] [(1) #t]
[(2) #f] [(2) #f]
@ -1419,7 +1421,8 @@ profile todo:
(eq? (message-box (string-constant drscheme) (eq? (message-box (string-constant drscheme)
(string-constant profiling-clear?) (string-constant profiling-clear?)
frame frame
'(yes-no)) '(yes-no)
#:dialog-mixin frame:focus-table-mixin)
'yes)))))) 'yes))))))
(define/private (do-reset-profile) (define/private (do-reset-profile)
@ -1561,7 +1564,8 @@ profile todo:
(send (get-current-tab) refresh-profile)] (send (get-current-tab) refresh-profile)]
[else [else
(message-box (string-constant drscheme) (message-box (string-constant drscheme)
(string-constant profiling-no-information-available))])) (string-constant profiling-no-information-available)
#:dialog-mixin frame:focus-table-mixin)]))
(define/public (hide-profile-gui) (define/public (hide-profile-gui)
(when profile-gui-constructed? (when profile-gui-constructed?

4
collects/drracket/private/expanding-place.rkt
View File

@ -17,7 +17,8 @@
;; get the module-language-compile-lock in the initial message ;; get the module-language-compile-lock in the initial message
(set! module-language-parallel-lock-client (set! module-language-parallel-lock-client
(compile-lock->parallel-lock-client (compile-lock->parallel-lock-client
(place-channel-get p))) (place-channel-get p)
(current-custodian)))
;; get the handlers in a second message ;; get the handlers in a second message
(set! handlers (for/list ([lst (place-channel-get p)]) (set! handlers (for/list ([lst (place-channel-get p)])
@ -43,6 +44,7 @@
(define (abort-job job) (define (abort-job job)
(custodian-shutdown-all (job-cust job)) (custodian-shutdown-all (job-cust job))
(log-info "expanding-place.rkt: kill")
(place-channel-put (job-response-pc job) #f)) (place-channel-put (job-response-pc job) #f))
(struct exn:access exn:fail ()) (struct exn:access exn:fail ())

9
collects/drracket/private/frame.rkt
View File

@ -295,7 +295,8 @@
[else [else
(message-box (string-constant drscheme) (message-box (string-constant drscheme)
(format (string-constant keybindings-planet-malformed-spec) (format (string-constant keybindings-planet-malformed-spec)
planet-spec))])))))) planet-spec)
#:dialog-mixin frame:focus-table-mixin)]))))))
(let ([ud (preferences:get 'drracket:user-defined-keybindings)]) (let ([ud (preferences:get 'drracket:user-defined-keybindings)])
(unless (null? ud) (unless (null? ud)
(new separator-menu-item% (parent keybindings-menu)) (new separator-menu-item% (parent keybindings-menu))
@ -343,7 +344,8 @@
(if (path? item) (if (path? item)
(path->string item) (path->string item)
(format "~s" item)) (format "~s" item))
(exn-message x))) (exn-message x))
#:dialog-mixin frame:focus-table-mixin)
#f)]) #f)])
(keymap:add-user-keybindings-file item) (keymap:add-user-keybindings-file item)
#t)) #t))
@ -459,7 +461,8 @@
(message-box (string-constant drscheme) (message-box (string-constant drscheme)
(if (exn? exn) (if (exn? exn)
(format "~a" (exn-message exn)) (format "~a" (exn-message exn))
(format "~s" exn))))]) (format "~s" exn))
#:dialog-mixin frame:focus-table-mixin))])
(let* ([url (string->url s-url)] (let* ([url (string->url s-url)]
[tmp-filename (make-temporary-file "tmp~a.plt")] [tmp-filename (make-temporary-file "tmp~a.plt")]
[port (get-impure-port url)] [port (get-impure-port url)]

5
collects/drracket/private/init.rkt
View File

@ -1,7 +1,8 @@
#lang racket/unit #lang racket/unit
(require string-constants (require string-constants
"drsig.rkt" "drsig.rkt"
racket/gui/base) racket/gui/base
framework)
(import) (import)
@ -50,4 +51,4 @@
(parameterize ([current-custodian system-custodian]) (parameterize ([current-custodian system-custodian])
(parameterize ([current-eventspace error-display-eventspace]) (parameterize ([current-eventspace error-display-eventspace])
(message-box title text #f '(stop ok)))))))) (message-box title text #f '(stop ok) #:dialog-mixin frame:focus-table-mixin)))))))

13
collects/drracket/private/language-configuration.rkt
View File

@ -162,7 +162,7 @@
(define language-dialog (define language-dialog
(λ (show-welcome? language-settings-to-show [parent #f]) (λ (show-welcome? language-settings-to-show [parent #f])
(define ret-dialog% (define ret-dialog%
(class dialog% (class (frame:focus-table-mixin dialog%)
(define/override (on-subwindow-char receiver evt) (define/override (on-subwindow-char receiver evt)
(case (send evt get-key-code) (case (send evt get-key-code)
[(escape) (cancel-callback)] [(escape) (cancel-callback)]
@ -170,7 +170,7 @@
[else [else
(or (key-pressed receiver evt) (or (key-pressed receiver evt)
(super on-subwindow-char receiver evt))])) (super on-subwindow-char receiver evt))]))
(super-instantiate ()))) (super-new)))
(define dialog (instantiate ret-dialog% () (define dialog (instantiate ret-dialog% ()
(label (if show-welcome? (label (if show-welcome?
@ -214,7 +214,8 @@
(define (ok-callback) (define (ok-callback)
(unless (enter-callback) (unless (enter-callback)
(message-box (string-constant drscheme) (message-box (string-constant drscheme)
(string-constant please-select-a-language)))) (string-constant please-select-a-language)
#:dialog-mixin frame:focus-table-mixin)))
;; cancel-callback : -> void ;; cancel-callback : -> void
(define (cancel-callback) (define (cancel-callback)
@ -1285,7 +1286,8 @@
(message-box (string-constant drscheme) (message-box (string-constant drscheme)
(if (exn? x) (if (exn? x)
(exn-message x) (exn-message x)
(format "uncaught exception: ~s" x))) (format "uncaught exception: ~s" x))
#:dialog-mixin frame:focus-table-mixin)
read-syntax/namespace-introduce)]) read-syntax/namespace-introduce)])
(contract (contract
(->* () (->* ()
@ -1335,7 +1337,8 @@
numberss numberss
summaries summaries
urls urls
reader-specs))]))))) reader-specs)
#:dialog-mixin frame:focus-table-mixin)])))))
(define (platform-independent-string->path str) (define (platform-independent-string->path str)
(apply (apply

15
collects/drracket/private/language.rkt
View File

@ -783,7 +783,8 @@
[(string=? "" filename-str) [(string=? "" filename-str)
(message-box (string-constant drscheme) (message-box (string-constant drscheme)
(string-constant please-specify-a-filename) (string-constant please-specify-a-filename)
dlg) dlg
#:dialog-mixin frame:focus-table-mixin)
#f] #f]
[(not (users-name-ok? mode extension dlg (string->path filename-str))) [(not (users-name-ok? mode extension dlg (string->path filename-str)))
#f] #f]
@ -797,7 +798,8 @@
(eq? (message-box (string-constant drscheme) (eq? (message-box (string-constant drscheme)
(format (string-constant are-you-sure-delete?) filename) (format (string-constant are-you-sure-delete?) filename)
dlg dlg
'(yes-no)) '(yes-no)
#:dialog-mixin frame:focus-table-mixin)
'yes)) 'yes))
(define cancelled? #t) (define cancelled? #t)
@ -904,7 +906,8 @@
[(distribution) (string-constant distribution)]) [(distribution) (string-constant distribution)])
name name
extension) extension)
parent) parent
#:dialog-mixin frame:focus-table-mixin)
#f))))) #f)))))
;; default-executable-filename : path symbol boolean -> path ;; default-executable-filename : path symbol boolean -> path
@ -940,7 +943,8 @@
(λ (x) (λ (x)
(message-box (message-box
(string-constant drscheme) (string-constant drscheme)
(format "~a" (exn-message x))) (format "~a" (exn-message x))
#:dialog-mixin frame:focus-table-mixin)
(void))]) (void))])
(define init-code-tmp-filename (make-temporary-file "drs-standalone-exectable-init~a")) (define init-code-tmp-filename (make-temporary-file "drs-standalone-exectable-init~a"))
(define bootstrap-tmp-filename (make-temporary-file "drs-standalone-exectable-bootstrap~a")) (define bootstrap-tmp-filename (make-temporary-file "drs-standalone-exectable-bootstrap~a"))
@ -1163,7 +1167,8 @@
(λ (x) (λ (x)
(message-box (message-box
(string-constant drscheme) (string-constant drscheme)
(format "~a" (exn-message x))) (format "~a" (exn-message x))
#:dialog-mixin frame:focus-table-mixin)
(void))]) (void))])
((if gui? make-mred-launcher make-mzscheme-launcher) ((if gui? make-mred-launcher make-mzscheme-launcher)

6
collects/drracket/private/main.rkt
View File

@ -116,7 +116,7 @@
ll)))) ll))))
(drr:set-default 'drracket:module-language-first-line-special? #t boolean?) (drr:set-default 'drracket:module-language-first-line-special? #t boolean?)
(drr:set-default 'drracket:use-old-style-keybindings #f boolean?)
(drr:set-default 'drracket:defns-popup-sort-by-name? #f boolean?) (drr:set-default 'drracket:defns-popup-sort-by-name? #f boolean?)
(drr:set-default 'drracket:show-line-numbers? #f boolean?) (drr:set-default 'drracket:show-line-numbers? #f boolean?)
@ -329,6 +329,10 @@
(make-check-box 'drracket:module-language-first-line-special? (make-check-box 'drracket:module-language-first-line-special?
(string-constant ml-always-show-#lang-line) (string-constant ml-always-show-#lang-line)
editor-panel)
(make-check-box 'drracket:use-old-style-keybindings
(string-constant old-style-keybindings)
editor-panel))) editor-panel)))
(preferences:add-to-editor-checkbox-panel (preferences:add-to-editor-checkbox-panel

17
collects/drracket/private/module-language-tools.rkt
View File

@ -89,7 +89,7 @@
(define definitions-text-mixin (define definitions-text-mixin
(mixin (text:basic<%> drracket:unit:definitions-text<%>) (drracket:module-language-tools:definitions-text<%>) (mixin (text:basic<%> drracket:unit:definitions-text<%>) (drracket:module-language-tools:definitions-text<%>)
(inherit get-next-settings) (inherit get-next-settings get-filename)
(define in-module-language? #f) ;; true when we are in the module language (define in-module-language? #f) ;; true when we are in the module language
(define hash-lang-last-location #f) ;; non-false when we know where the hash-lang line ended (define hash-lang-last-location #f) ;; non-false when we know where the hash-lang line ended
(define hash-lang-language #f) ;; non-false is the string that was parsed for the language (define hash-lang-language #f) ;; non-false is the string that was parsed for the language
@ -101,13 +101,26 @@
(inner (void) after-delete start len) (inner (void) after-delete start len)
(modification-at start)) (modification-at start))
(define last-filename #f)
(define/augment (after-save-file success?)
(inner (void) after-save-file success?)
(define this-filename (get-filename))
(unless (equal? last-filename this-filename)
(set! last-filename this-filename)
(modification-at #f)))
(define timer #f) (define timer #f)
;; modification-at : (or/c #f number) -> void
;; checks to see if the lang line has changed when start
;; is in the region of the lang line, or when start is #f, or
;; when there is no #lang line known.
(define/private (modification-at start) (define/private (modification-at start)
(send (send (get-tab) get-frame) when-initialized (send (send (get-tab) get-frame) when-initialized
(λ () (λ ()
(when in-module-language? (when in-module-language?
(when (or (not hash-lang-last-location) (when (or (not start)
(not hash-lang-last-location)
(<= start hash-lang-last-location)) (<= start hash-lang-last-location))
(unless timer (unless timer

127
collects/drracket/private/module-language.rkt
View File

@ -9,7 +9,7 @@
racket/sandbox racket/sandbox
racket/runtime-path racket/runtime-path
racket/math racket/math
mred racket/gui/base
compiler/embed compiler/embed
compiler/cm compiler/cm
launcher launcher
@ -18,6 +18,7 @@
planet/config planet/config
setup/dirs setup/dirs
racket/place racket/place
"tooltip.rkt"
"drsig.rkt" "drsig.rkt"
"rep.rkt" "rep.rkt"
"eval-helpers.rkt" "eval-helpers.rkt"
@ -532,7 +533,9 @@
new-parent new-parent
#:case-sensitive #t #:case-sensitive #t
#:get-debugging-radio-box (λ (rb-l rb-r) (set! left-debugging-radio-box rb-l) (set! right-debugging-radio-box rb-r)) #:get-debugging-radio-box (λ (rb-l rb-r)
(set! left-debugging-radio-box rb-l)
(set! right-debugging-radio-box rb-r))
#:debugging-radio-box-callback #:debugging-radio-box-callback
(λ (debugging-radio-box evt) (λ (debugging-radio-box evt)
@ -658,7 +661,8 @@
(define (get-lb-vector) (define (get-lb-vector)
(list->vector (for/list ([n (in-range (send collection-paths-lb get-number))]) (list->vector (for/list ([n (in-range (send collection-paths-lb get-number))])
(cons (send collection-paths-lb get-string n) (send collection-paths-lb get-data n))))) (cons (send collection-paths-lb get-string n)
(send collection-paths-lb get-data n)))))
(define (set-lb-vector vec) (define (set-lb-vector vec)
(send collection-paths-lb clear) (send collection-paths-lb clear)
@ -829,7 +833,9 @@
[stretchable-height #f] [stretchable-height #f]
[parent expand-error-parent-panel])) [parent expand-error-parent-panel]))
(set! expand-error-message (new error-message% [parent expand-error-panel] [stretchable-width #t] [msg "hi"])) (set! expand-error-message (new error-message% [parent expand-error-panel]
[stretchable-width #t]
[msg "hi"]))
(set! expand-error-button-parent-panel (set! expand-error-button-parent-panel
(new vertical-panel% (new vertical-panel%
[stretchable-width #f] [stretchable-width #f]
@ -909,24 +915,11 @@
(cond (cond
[tooltip-labels [tooltip-labels
(unless tooltip-frame (unless tooltip-frame
(set! tooltip-frame (set! tooltip-frame (new tooltip-frame%)))
(new (class frame% (send tooltip-frame set-tooltip tooltip-labels)
(define/override (on-subwindow-event r evt)
(cond
[(send evt button-down?)
(hide-tooltip)
#t]
[else #f]))
(super-new [style '(no-resize-border no-caption float)]
[label ""]
[stretchable-width #f]
[stretchable-height #f] ))))
(new yellow-message% [parent tooltip-frame]))
(send (car (send tooltip-frame get-children)) set-lab tooltip-labels)
(send tooltip-frame reflow-container)
(define-values (rx ry) (send running-canvas client->screen 0 0)) (define-values (rx ry) (send running-canvas client->screen 0 0))
(send tooltip-frame move (- rx (send tooltip-frame get-width)) (- ry (send tooltip-frame get-height))) (define-values (cw ch) (send running-canvas get-client-size))
(send tooltip-frame show #t)] (send tooltip-frame show-over rx ry cw ch #:prefer-upper-left? #t)]
[else [else
(when tooltip-frame (when tooltip-frame
(send tooltip-frame show #f))])) (send tooltip-frame show #f))]))
@ -1098,7 +1091,8 @@
(unless place-initialized? (unless place-initialized?
(set! place-initialized? #t) (set! place-initialized? #t)
(place-channel-put expanding-place module-language-compile-lock) (place-channel-put expanding-place module-language-compile-lock)
(place-channel-put expanding-place (place-channel-put
expanding-place
(for/list ([o-e-h (in-list (drracket:module-language-tools:get-online-expansion-handlers))]) (for/list ([o-e-h (in-list (drracket:module-language-tools:get-online-expansion-handlers))])
(list (drracket:module-language-tools:online-expansion-handler-mod-path o-e-h) (list (drracket:module-language-tools:online-expansion-handler-mod-path o-e-h)
(drracket:module-language-tools:online-expansion-handler-id o-e-h))))) (drracket:module-language-tools:online-expansion-handler-id o-e-h)))))
@ -1131,7 +1125,7 @@
drracket:unit:definitions-text<%> drracket:unit:definitions-text<%>
drracket:module-language-tools:definitions-text<%>) () drracket:module-language-tools:definitions-text<%>) ()
(inherit last-position find-first-snip get-top-level-window get-filename (inherit last-position find-first-snip get-top-level-window get-filename
get-tab highlight-range get-canvas get-tab get-canvas invalidate-bitmap-cache
set-position get-start-position get-end-position) set-position get-start-position get-end-position)
(define compilation-out-of-date? #f) (define compilation-out-of-date? #f)
@ -1145,7 +1139,6 @@
(define/private (buffer-modified) (define/private (buffer-modified)
(clear-old-error) (clear-old-error)
(set! clear-old-error void)
(reset-frame-expand-error) (reset-frame-expand-error)
(let ([tlw (get-top-level-window)]) (let ([tlw (get-top-level-window)])
(when expanding-place (when expanding-place
@ -1178,7 +1171,6 @@
(λ (res) (show-results res))) (λ (res) (show-results res)))
(when status-line-open? (when status-line-open?
(clear-old-error) (clear-old-error)
(set! clear-old-error void)
(reset-frame-expand-error)) (reset-frame-expand-error))
(send (get-tab) show-bkg-running 'running sc-online-expansion-running))))) (send (get-tab) show-bkg-running 'running sc-online-expansion-running)))))
@ -1203,7 +1195,6 @@
(values str fn))) (values str fn)))
(define status-line-open? #f) (define status-line-open? #f)
(define clear-old-error void)
(define error-message-str #f) (define error-message-str #f)
(define error-message-srclocs '()) (define error-message-srclocs '())
@ -1255,40 +1246,35 @@
[(exn) [(exn)
(define tlw (send (get-tab) get-frame)) (define tlw (send (get-tab) get-frame))
(send (get-tab) show-bkg-running 'nothing #f) (send (get-tab) show-bkg-running 'nothing #f)
(clear-old-error)
(set! error-message-str (vector-ref res 1)) (set! error-message-str (vector-ref res 1))
(set! error-message-srclocs (vector-ref res 2)) (set! error-message-srclocs (vector-ref res 2))
(set! clear-old-error (set! error-ranges
(for/fold ([clear void]) (for/list ([range (in-list (vector-ref res 2))])
([range (in-list (vector-ref res 2))])
(define pos (vector-ref range 0)) (define pos (vector-ref range 0))
(define span (vector-ref range 1)) (define span (vector-ref range 1))
(define clear-next (highlight-range (- pos 1) (+ pos span -1) "Gold" #f 'high)) (list (- pos 1) (+ pos span -1))))
(lambda () (clear) (clear-next)))) ;; should really only invalidate the appropriate region here (and in clear-error-ranges)
(invalidate-bitmap-cache 0 0 'display-end 'display-end)
(update-frame-expand-error)] (update-frame-expand-error)]
[(access-violation) [(access-violation)
(send (get-tab) show-bkg-running 'failed (gui-utils:format-literal-label "~a" (vector-ref res 1))) (send (get-tab) show-bkg-running 'failed (gui-utils:format-literal-label "~a" (vector-ref res 1)))
(clear-old-error) (clear-old-error)
(set! clear-old-error void)
(reset-frame-expand-error)] (reset-frame-expand-error)]
[(reader-in-defs-error) [(reader-in-defs-error)
(send (get-tab) show-bkg-running 'reader-in-defs-error (gui-utils:format-literal-label "~a" (vector-ref res 1))) (send (get-tab) show-bkg-running 'reader-in-defs-error
(gui-utils:format-literal-label "~a" (vector-ref res 1)))
(clear-old-error) (clear-old-error)
(set! clear-old-error void)
(reset-frame-expand-error)] (reset-frame-expand-error)]
[(abnormal-termination) [(abnormal-termination)
(send (get-tab) show-bkg-running 'failed sc-abnormal-termination) (send (get-tab) show-bkg-running 'failed sc-abnormal-termination)
(clear-old-error) (clear-old-error)
(set! clear-old-error void)
(reset-frame-expand-error)] (reset-frame-expand-error)]
[(no-errors) [(no-errors)
(send (get-tab) show-bkg-running 'nothing #f) (send (get-tab) show-bkg-running 'nothing #f)
(clear-old-error) (clear-old-error)
(set! clear-old-error void)
(reset-frame-expand-error)] (reset-frame-expand-error)]
[(handler-results) [(handler-results)
(clear-old-error) (clear-old-error)
(set! clear-old-error void)
(reset-frame-expand-error) (reset-frame-expand-error)
;; inform the installed handlers that something has come back ;; inform the installed handlers that something has come back
(for ([key-val (in-list (vector-ref res 1))]) (for ([key-val (in-list (vector-ref res 1))])
@ -1303,6 +1289,68 @@
[else [else
(error 'module-language.rkt "unknown response from the expanding place: ~s\n" res)])) (error 'module-language.rkt "unknown response from the expanding place: ~s\n" res)]))
(define error-ranges '())
(define/private (clear-old-error)
(set! error-ranges '())
(invalidate-bitmap-cache 0 0 'display-end 'display-end))
(define byt (box 0.0))
(define byb (box 0.0))
(define vbx (box 0.0))
(define vby (box 0.0))
(define vbw (box 0.0))
(define vbh (box 0.0))
(inherit position-location get-admin)
(define/override (on-paint before? dc left top right bottom dx dy draw-caret)
(super on-paint before? dc left top right bottom dx dy draw-caret)
(unless before?
(define pen-width 8)
(define saved-brush (send dc get-brush))
(define saved-pen (send dc get-pen))
(define smoothing (send dc get-smoothing))
(send dc set-smoothing 'smoothed)
(define path (new dc-path%))
(send dc set-brush "black" 'transparent)
(send dc set-pen (send the-pen-list find-or-create-pen "red" pen-width 'solid 'butt 'miter))
(send dc set-alpha .4)
(for ([error-range (in-list error-ranges)])
(define start-pos (list-ref error-range 0))
(define end-pos (list-ref error-range 1))
(position-location start-pos #f byt)
(position-location end-pos #f byb #f)
(send (get-admin) get-view vbx vby vbw vbh)
(define x2 (+ dx (unbox vbx) (unbox vbw) (- (/ pen-width 2)) (- (/ pen-width 1))))
(define y2 (+ dy (unbox byt)))
(define x1 (+ x2 (- (/ pen-width 1))))
(define y1 y2)
(define x3 x2)
(define y3 (+ dy (unbox byb)))
(define x4 x1)
(define y4 y3)
(send path move-to x1 y1)
(send path line-to x2 y2)
(send path line-to x3 y3)
(send path line-to x4 y4)
(send path line-to x3 y3)
(send path line-to x2 y2)
(send path move-to x1 y1)
(send path close))
(send dc draw-path path)
(send dc set-alpha 1)
(send dc set-brush saved-brush)
(send dc set-pen saved-pen)
(send dc set-smoothing smoothing)))
(define/override (move-to-new-language) (define/override (move-to-new-language)
;; this is here to get things running for the initital tab in a new frame ;; this is here to get things running for the initital tab in a new frame
(super move-to-new-language) (super move-to-new-language)
@ -1396,7 +1444,8 @@
(define module-language-parallel-lock-client (define module-language-parallel-lock-client
(compile-lock->parallel-lock-client (compile-lock->parallel-lock-client
module-language-compile-lock)) module-language-compile-lock
(current-custodian)))
;; in-module-language : top-level-window<%> -> module-language-settings or #f ;; in-module-language : top-level-window<%> -> module-language-settings or #f
(define (in-module-language tlw) (define (in-module-language tlw)

8
collects/drracket/private/rep.rkt
View File

@ -903,7 +903,7 @@ TODO
(floor (/ new-limit 1024 1024)))) (floor (/ new-limit 1024 1024))))
frame frame
'(default=1 stop) '(default=1 stop)
)]) #:dialog-mixin frame:focus-table-mixin)])
(when (equal? ans 3) (when (equal? ans 3)
(set-custodian-limit new-limit) (set-custodian-limit new-limit)
(preferences:set 'drracket:child-only-memory-limit new-limit)) (preferences:set 'drracket:child-only-memory-limit new-limit))
@ -1369,7 +1369,8 @@ TODO
#f #f
(or (get-top-level-window) (get-can-close-parent)) (or (get-top-level-window) (get-can-close-parent))
'(default=1 caution) '(default=1 caution)
2) 2
#:dialog-mixin frame:focus-table-mixin)
1)] 1)]
[(let ([user-eventspace (get-user-eventspace)]) [(let ([user-eventspace (get-user-eventspace)])
(and user-eventspace (and user-eventspace
@ -1383,7 +1384,8 @@ TODO
#f #f
(or (get-top-level-window) (get-can-close-parent)) (or (get-top-level-window) (get-can-close-parent))
'(default=1 caution) '(default=1 caution)
2) 2
#:dialog-mixin frame:focus-table-mixin)
1)] 1)]
[else #t]) [else #t])
(inner #t can-close?))) (inner #t can-close?)))

2
collects/drracket/private/syncheck/contract-traversal.rkt
View File

@ -109,7 +109,7 @@
(call-give-up)] (call-give-up)]
[(define-syntaxes (id ...) expr) [(define-syntaxes (id ...) expr)
(call-give-up)] (call-give-up)]
[(define-values-for-syntax (id ...) expr) [(begin-for-syntax (id ...) expr)
(call-give-up)] (call-give-up)]
[(#%require rspec ...) [(#%require rspec ...)
(call-give-up)] (call-give-up)]

138
collects/drracket/private/syncheck/gui.rkt
View File

@ -50,7 +50,8 @@ If the namespace does not, they are colored the unbound color.
"intf.rkt" "intf.rkt"
"colors.rkt" "colors.rkt"
"traversals.rkt" "traversals.rkt"
"annotate.rkt") "annotate.rkt"
"../tooltip.rkt")
(provide tool@) (provide tool@)
(define orig-output-port (current-output-port)) (define orig-output-port (current-output-port))
@ -198,6 +199,8 @@ If the namespace does not, they are colored the unbound color.
#:transparent) #:transparent)
(define-struct (tail-arrow arrow) (from-text from-pos to-text to-pos) #:transparent) (define-struct (tail-arrow arrow) (from-text from-pos to-text to-pos) #:transparent)
(define-struct tooltip-info (text pos-left pos-right msg) #:transparent)
;; color : string ;; color : string
;; text: text:basic<%> ;; text: text:basic<%>
;; start, fin: number ;; start, fin: number
@ -470,10 +473,7 @@ If the namespace does not, they are colored the unbound color.
(set! arrow-records (make-hasheq)) (set! arrow-records (make-hasheq))
(set! bindings-table (make-hash)) (set! bindings-table (make-hash))
(set! cleanup-texts '()) (set! cleanup-texts '())
(set! style-mapping (make-hash)) (set! style-mapping (make-hash)))
(let ([f (get-top-level-window)])
(when f
(send f open-status-line 'drracket:check-syntax:mouse-over))))
(define/public (syncheck:arrows-visible?) (define/public (syncheck:arrows-visible?)
(or arrow-records cursor-location cursor-text)) (or arrow-records cursor-location cursor-text))
@ -493,9 +493,7 @@ If the namespace does not, they are colored the unbound color.
(set! style-mapping #f) (set! style-mapping #f)
(invalidate-bitmap-cache) (invalidate-bitmap-cache)
(update-docs-background #f) (update-docs-background #f)
(let ([f (get-top-level-window)]) (clear-tooltips)))
(when f
(send f close-status-line 'drracket:check-syntax:mouse-over)))))
;; syncheck:apply-style/remember : (is-a?/c text%) number number style% symbol -> void ;; syncheck:apply-style/remember : (is-a?/c text%) number number style% symbol -> void
(define/public (syncheck:apply-style/remember txt start finish style mode) (define/public (syncheck:apply-style/remember txt start finish style mode)
@ -538,14 +536,13 @@ If the namespace does not, they are colored the unbound color.
[else #f])) [else #f]))
(define/public (syncheck:add-require-open-menu text start-pos end-pos file) (define/public (syncheck:add-require-open-menu text start-pos end-pos file)
(define (make-require-open-menu file) (define ((make-require-open-menu file) menu)
(λ (menu) (define-values (base name dir?) (split-path file))
(let-values ([(base name dir?) (split-path file)]) (new menu-item%
(instantiate menu-item% ()
(label (fw:gui-utils:format-literal-label (string-constant cs-open-file) (path->string name))) (label (fw:gui-utils:format-literal-label (string-constant cs-open-file) (path->string name)))
(parent menu) (parent menu)
(callback (λ (x y) (fw:handler:edit-file file)))) (callback (λ (x y) (fw:handler:edit-file file))))
(void)))) (void))
(syncheck:add-menu text start-pos end-pos #f (make-require-open-menu file))) (syncheck:add-menu text start-pos end-pos #f (make-require-open-menu file)))
(define/public (syncheck:add-docs-menu text start-pos end-pos id the-label path tag) (define/public (syncheck:add-docs-menu text start-pos end-pos id the-label path tag)
@ -573,14 +570,14 @@ If the namespace does not, they are colored the unbound color.
(define/public (syncheck:add-rename-menu id-as-sym to-be-renamed/poss name-dup?) (define/public (syncheck:add-rename-menu id-as-sym to-be-renamed/poss name-dup?)
(define (make-menu menu) (define (make-menu menu)
(let ([name-to-offer (format "~a" id-as-sym)]) (let ([name-to-offer (format "~a" id-as-sym)])
(instantiate menu-item% () (new menu-item%
(parent menu) [parent menu]
(label (fw:gui-utils:format-literal-label (string-constant cs-rename-var) name-to-offer)) [label (fw:gui-utils:format-literal-label (string-constant cs-rename-var) name-to-offer)]
(callback [callback
(λ (x y) (λ (x y)
(let ([frame-parent (find-menu-parent menu)]) (let ([frame-parent (find-menu-parent menu)])
(rename-callback name-to-offer (rename-callback name-to-offer
frame-parent))))))) frame-parent)))])))
;; rename-callback : string ;; rename-callback : string
;; (and/c syncheck-text<%> definitions-text<%>) ;; (and/c syncheck-text<%> definitions-text<%>)
@ -597,7 +594,8 @@ If the namespace does not, they are colored the unbound color.
(string-constant cs-rename-id) (string-constant cs-rename-id)
(fw:gui-utils:format-literal-label (string-constant cs-rename-var-to) name-to-offer) (fw:gui-utils:format-literal-label (string-constant cs-rename-var-to) name-to-offer)
parent parent
name-to-offer)))]) name-to-offer
#:dialog-mixin frame:focus-table-mixin)))])
(when new-str (when new-str
(define new-sym (format "~s" (string->symbol new-str))) (define new-sym (format "~s" (string->symbol new-str)))
(define dup-name? (name-dup? new-sym)) (define dup-name? (name-dup? new-sym))
@ -613,7 +611,8 @@ If the namespace does not, they are colored the unbound color.
(string-constant cancel) (string-constant cancel)
#f #f
parent parent
'(stop default=2)) '(stop default=2)
#:dialog-mixin frame:focus-table-mixin)
1))) 1)))
(when do-renaming? (when do-renaming?
@ -666,7 +665,7 @@ If the namespace does not, they are colored the unbound color.
(define/private (syncheck:add-menu text start-pos end-pos key make-menu) (define/private (syncheck:add-menu text start-pos end-pos key make-menu)
(when arrow-records (when arrow-records
(when (and (<= 0 start-pos end-pos (last-position))) (when (<= 0 start-pos end-pos (last-position))
(add-to-range/key text start-pos end-pos make-menu key (and key #t))))) (add-to-range/key text start-pos end-pos make-menu key (and key #t)))))
(define/public (syncheck:add-background-color text start fin color) (define/public (syncheck:add-background-color text start fin color)
@ -704,9 +703,10 @@ If the namespace does not, they are colored the unbound color.
;; syncheck:add-mouse-over-status : text pos-left pos-right string -> void ;; syncheck:add-mouse-over-status : text pos-left pos-right string -> void
(define/public (syncheck:add-mouse-over-status text pos-left pos-right str) (define/public (syncheck:add-mouse-over-status text pos-left pos-right str)
(let ([str (gui-utils:format-literal-label "~a" str)])
(when arrow-records (when arrow-records
(add-to-range/key text pos-left pos-right str #f #f)))) (add-to-range/key text pos-left pos-right
(make-tooltip-info text pos-left pos-right str)
#f #f)))
;; add-to-range/key : text number number any any boolean -> void ;; add-to-range/key : text number number any any boolean -> void
;; adds `key' to the range `start' - `end' in the editor ;; adds `key' to the range `start' - `end' in the editor
@ -880,7 +880,6 @@ If the namespace does not, they are colored the unbound color.
(define last-known-mouse-x #f) (define last-known-mouse-x #f)
(define last-known-mouse-y #f) (define last-known-mouse-y #f)
(define/override (on-event event) (define/override (on-event event)
(cond (cond
[(send event leaving?) [(send event leaving?)
(set! last-known-mouse-x #f) (set! last-known-mouse-x #f)
@ -897,9 +896,6 @@ If the namespace does not, they are colored the unbound color.
(set! cursor-location #f) (set! cursor-location #f)
(set! cursor-text #f) (set! cursor-text #f)
(set! cursor-eles #f) (set! cursor-eles #f)
(let ([f (get-top-level-window)])
(when f
(send f update-status-line 'drracket:check-syntax:mouse-over #f)))
(invalidate-bitmap-cache)) (invalidate-bitmap-cache))
(super on-event event)] (super on-event event)]
[(or (send event moving?) [(or (send event moving?)
@ -938,20 +934,18 @@ If the namespace does not, they are colored the unbound color.
(set! cursor-eles eles) (set! cursor-eles eles)
(update-docs-background eles) (update-docs-background eles)
(when eles (when eles
(update-status-line eles) (update-tooltips eles)
(for ([ele (in-list eles)]) (for ([ele (in-list eles)])
(cond [(arrow? ele) (cond [(arrow? ele)
(update-arrow-poss ele)])) (update-arrow-poss ele)]))
(invalidate-bitmap-cache)))))] (invalidate-bitmap-cache)))))]
[else [else
(update-docs-background #f) (update-docs-background #f)
(let ([f (get-top-level-window)])
(when f
(send f update-status-line 'drracket:check-syntax:mouse-over #f)))
(when (or cursor-location cursor-text) (when (or cursor-location cursor-text)
(set! cursor-location #f) (set! cursor-location #f)
(set! cursor-text #f) (set! cursor-text #f)
(set! cursor-eles #f) (set! cursor-eles #f)
(clear-tooltips)
(invalidate-bitmap-cache))]))) (invalidate-bitmap-cache))])))
(define/public (syncheck:build-popup-menu pos text) (define/public (syncheck:build-popup-menu pos text)
@ -970,7 +964,8 @@ If the namespace does not, they are colored the unbound color.
[arrows (filter arrow? vec-ents)] [arrows (filter arrow? vec-ents)]
[def-links (filter def-link? vec-ents)] [def-links (filter def-link? vec-ents)]
[var-arrows (filter var-arrow? arrows)] [var-arrows (filter var-arrow? arrows)]
[add-menus (map cdr (filter pair? vec-ents))]) [add-menus (append (map cdr (filter pair? vec-ents))
(filter procedure? vec-ents))])
(unless (null? arrows) (unless (null? arrows)
(make-object menu-item% (make-object menu-item%
(string-constant cs-tack/untack-arrow) (string-constant cs-tack/untack-arrow)
@ -1035,22 +1030,70 @@ If the namespace does not, they are colored the unbound color.
menu)])))))) menu)]))))))
(define/private (update-status-line eles) (define tooltip-frame #f)
(let ([has-txt? #f]) (define/private (update-tooltips eles)
(for-each (λ (ele) (unless tooltip-frame (set! tooltip-frame (new tooltip-frame%)))
(define tooltip-infos (filter tooltip-info? eles))
(cond (cond
[(string? ele) [(null? tooltip-infos)
(set! has-txt? #t) (send tooltip-frame show #f)]
(let ([f (get-top-level-window)]) [else
(when f (send tooltip-frame set-tooltip (map tooltip-info-msg tooltip-infos))
(send f update-status-line (let loop ([tooltip-infos tooltip-infos]
'drracket:check-syntax:mouse-over [l #f]
ele)))])) [t #f]
eles) [r #f]
(unless has-txt? [b #f])
(let ([f (get-top-level-window)]) (cond
(when f [(null? tooltip-infos)
(send f update-status-line 'drracket:check-syntax:mouse-over #f)))))) (if (and l t r b)
(send tooltip-frame show-over l t (- r l) (- b t))
(send tooltip-frame show #f))]
[else
(define-values (tl tt tr tb) (tooltip-info->ltrb (car tooltip-infos)))
(define (min/f x y) (cond [(and x y) (min x y)] [x x] [y y] [else #f]))
(define (max/f x y) (cond [(and x y) (max x y)] [x x] [y y] [else #f]))
(loop (cdr tooltip-infos)
(min/f tl l)
(min/f tt t)
(max/f tr r)
(max/f tb b))]))]))
(define/private (clear-tooltips)
(when tooltip-frame (send tooltip-frame show #f)))
(define/private (tooltip-info->ltrb tooltip)
(define xlb (box 0))
(define ylb (box 0))
(define xrb (box 0))
(define yrb (box 0))
(define left-pos (tooltip-info-pos-left tooltip))
(define right-pos (tooltip-info-pos-right tooltip))
(define text (tooltip-info-text tooltip))
(send text position-location left-pos xlb ylb #t)
(send text position-location right-pos xrb yrb #f)
(define-values (xl-off yl-off) (send text editor-location-to-dc-location (unbox xlb) (unbox ylb)))
(define-values (xr-off yr-off) (send text editor-location-to-dc-location (unbox xrb) (unbox yrb)))
(define window
(let loop ([ed text])
(cond
[(send ed get-canvas) => values]
[else
(define admin (send ed get-admin))
(if (is-a? admin editor-snip-editor-admin<%>)
(loop (send (send admin get-snip) get-editor))
#f)])))
(cond
[window
(define (c n) (inexact->exact (round n)))
(define-values (glx gly) (send window client->screen (c xl-off) (c yl-off)))
(define-values (grx gry) (send window client->screen (c xr-off) (c yr-off)))
(values (min glx grx)
(min gly gry)
(max glx grx)
(max gly gry))]
[else
(values #f #f #f #f)]))
(define current-colored-region #f) (define current-colored-region #f)
;; update-docs-background : (or/c false/c (listof any)) -> void ;; update-docs-background : (or/c false/c (listof any)) -> void
@ -1711,6 +1754,7 @@ If the namespace does not, they are colored the unbound color.
(define module-language? (define module-language?
(is-a? (drracket:language-configuration:language-settings-language settings) (is-a? (drracket:language-configuration:language-settings-language settings)
drracket:module-language:module-language<%>)) drracket:module-language:module-language<%>))
(send definitions-text-copy set-style-list (send definitions-text get-style-list)) ;; speeds up the copy
(send definitions-text copy-self-to definitions-text-copy) (send definitions-text copy-self-to definitions-text-copy)
(with-lock/edit-sequence (with-lock/edit-sequence
definitions-text-copy definitions-text-copy

2
collects/drracket/private/syncheck/online-comp.rkt
View File

@ -31,7 +31,7 @@
(set! trace (cons (cons 'name args) trace)))) (set! trace (cons (cons 'name args) trace))))
; (log syncheck:color-range) ;; we don't want log these as they are too distracting to keep popping up ; (log syncheck:color-range) ;; we don't want log these as they are too distracting to keep popping up
; (log syncheck:add-mouse-over-status) ;; we don't log these as they require space in the window (log syncheck:add-mouse-over-status)
(log syncheck:add-arrow) (log syncheck:add-arrow)
(log syncheck:add-tail-arrow) (log syncheck:add-tail-arrow)
(log syncheck:add-background-color) (log syncheck:add-background-color)

8
collects/drracket/private/syncheck/traversals.rkt
View File

@ -185,7 +185,7 @@
(syntax-case* sexp (#%plain-lambda case-lambda if begin begin0 let-values letrec-values set! (syntax-case* sexp (#%plain-lambda case-lambda if begin begin0 let-values letrec-values set!
quote quote-syntax with-continuation-mark quote quote-syntax with-continuation-mark
#%plain-app #%top #%plain-module-begin #%plain-app #%top #%plain-module-begin
define-values define-syntaxes define-values-for-syntax module define-values define-syntaxes begin-for-syntax module
#%require #%provide #%expression) #%require #%provide #%expression)
(if high-level? free-transformer-identifier=? free-identifier=?) (if high-level? free-transformer-identifier=? free-identifier=?)
[(#%plain-lambda args bodies ...) [(#%plain-lambda args bodies ...)
@ -317,12 +317,10 @@
(add-binders (syntax names) binders binding-inits #'exp) (add-binders (syntax names) binders binding-inits #'exp)
(maybe-jump (syntax names)) (maybe-jump (syntax names))
(level-loop (syntax exp) #t))] (level-loop (syntax exp) #t))]
[(define-values-for-syntax names exp) [(begin-for-syntax exp ...)
(begin (begin
(annotate-raw-keyword sexp varrefs) (annotate-raw-keyword sexp varrefs)
(add-binders (syntax names) high-binders binding-inits #'exp) (for-each (lambda (e) (level-loop e #t)) (syntax->list (syntax (exp ...)))))]
(maybe-jump (syntax names))
(level-loop (syntax exp) #t))]
[(module m-name lang (#%plain-module-begin bodies ...)) [(module m-name lang (#%plain-module-begin bodies ...))
(begin (begin
(annotate-raw-keyword sexp varrefs) (annotate-raw-keyword sexp varrefs)

87
collects/drracket/private/tooltip.rkt Normal file
View File

@ -0,0 +1,87 @@
#lang racket/base
(require racket/gui/base
racket/class)
(provide tooltip-frame%)
(define tooltip-frame%
(class frame%
(inherit show reflow-container move get-width get-height)
(define/override (on-subwindow-event r evt)
(cond
[(send evt button-down?)
(show #f)
#t]
[else #f]))
(define/public (set-tooltip ls)
(send yellow-message set-lab ls))
(define/public (show-over x y w h #:prefer-upper-left? [prefer-upper-left? #f])
(reflow-container)
(define mw (get-width))
(define mh (get-height))
(define (upper-left must?)
(define the-x (- x mw))
(define the-y (- y mh))
(if must?
(move the-x the-y)
(try-moving-to the-x the-y mw mh)))
(define (lower-right must?)
(define the-x (+ x w))
(define the-y (+ y h))
(if must?
(move the-x the-y)
(try-moving-to the-x the-y mw mh)))
(if prefer-upper-left?
(or (upper-left #t) (lower-right #f) (upper-left #t))
(or (lower-right #t) (upper-left #f) (lower-right #t)))
(show #t))
(define/private (try-moving-to x y w h)
(and (for/or ([m (in-range 0 (get-display-count))])
(define-values (mx my) (get-display-left-top-inset #:monitor m))
(define-values (mw mh) (get-display-size #:monitor m))
(and (<= (- mx) x (+ x w) (+ (- mx) mw))
(<= (- my) y (+ y h) (+ (- my) mh))))
(begin (move x y)
#t)))
(super-new [style '(no-resize-border no-caption float)]
[label ""]
[stretchable-width #f]
[stretchable-height #f])
(define yellow-message (new yellow-message% [parent this]))))
(define yellow-message%
(class canvas%
(inherit get-dc refresh get-client-size
min-width min-height
get-parent)
(define labels '(""))
(define/public (set-lab _ls)
(unless (equal? labels _ls)
(set! labels _ls)
(update-size)
(refresh)))
(define/private (update-size)
(define dc (get-dc))
(send dc set-font small-control-font)
(define-values (w h _1 _2) (send dc get-text-extent (car labels)))
(send (get-parent) begin-container-sequence)
(min-width (+ 5 (inexact->exact (ceiling w))))
(min-height (+ 5 (* (length labels) (inexact->exact (ceiling h)))))
(send (get-parent) end-container-sequence)
(send (get-parent) reflow-container))
(define/override (on-paint)
(define dc (get-dc))
(send dc set-font small-control-font)
(define-values (w h) (get-client-size))
(define-values (tw th _1 _2) (send dc get-text-extent (car labels)))
(send dc set-pen "black" 1 'transparent)
(send dc set-brush "LemonChiffon" 'solid)
(send dc set-pen "black" 1 'solid)
(send dc draw-rectangle 0 0 w h)
(for ([label (in-list labels)]
[i (in-naturals)])
(send dc draw-text label 2 (+ 2 (* i th)))))
(super-new [stretchable-width #f] [stretchable-height #f])))

99
collects/drracket/private/unit.rkt
View File

@ -150,7 +150,8 @@ module browser threading seems wrong.
[else [else
(message-box (message-box
(string-constant drscheme) (string-constant drscheme)
"Must choose a filename that ends with either .png, .jpg, .xbm, or .xpm")])))))])))))) "Must choose a filename that ends with either .png, .jpg, .xbm, or .xpm"
#:dialog-mixin frame:focus-table-mixin)])))))]))))))
(void)))))) (void))))))
@ -338,7 +339,8 @@ module browser threading seems wrong.
(message-box (message-box
(string-constant drscheme) (string-constant drscheme)
v v
dlg)])))] dlg
#:dialog-mixin frame:focus-table-mixin)])))]
[cancel-callback [cancel-callback
(λ () (send dlg show #f))]) (λ () (send dlg show #f))])
(let-values ([(ok cancel) (let-values ([(ok cancel)
@ -364,7 +366,8 @@ module browser threading seems wrong.
[(not program-filename) [(not program-filename)
(message-box (string-constant create-executable-title) (message-box (string-constant create-executable-title)
(string-constant must-save-before-executable) (string-constant must-save-before-executable)
frame)] frame
#:dialog-mixin frame:focus-table-mixin)]
[else [else
(when (or (not (send definitions-text is-modified?)) (when (or (not (send definitions-text is-modified?))
(gui-utils:get-choice (gui-utils:get-choice
@ -1146,12 +1149,10 @@ module browser threading seems wrong.
(define/public-final (set-i _i) (set! i _i)) (define/public-final (set-i _i) (set! i _i))
(define/public (disable-evaluation) (define/public (disable-evaluation)
(set! enabled? #f) (set! enabled? #f)
(send defs lock #t)
(send ints lock #t) (send ints lock #t)
(send frame disable-evaluation-in-tab this)) (send frame disable-evaluation-in-tab this))
(define/public (enable-evaluation) (define/public (enable-evaluation)
(set! enabled? #t) (set! enabled? #t)
(send defs lock #f)
(send ints lock #f) (send ints lock #f)
(send frame enable-evaluation-in-tab this)) (send frame enable-evaluation-in-tab this))
(define/public (get-enabled) enabled?) (define/public (get-enabled) enabled?)
@ -1264,6 +1265,8 @@ module browser threading seems wrong.
(define/public-final (toggle-log) (define/public-final (toggle-log)
(set! log-visible? (not log-visible?)) (set! log-visible? (not log-visible?))
(send frame show/hide-log log-visible?)) (send frame show/hide-log log-visible?))
(define/public-final (hide-log)
(when log-visible? (toggle-log)))
(define/public-final (update-log) (define/public-final (update-log)
(send frame show/hide-log log-visible?)) (send frame show/hide-log log-visible?))
(define/public-final (update-logger-window command) (define/public-final (update-logger-window command)
@ -1430,19 +1433,25 @@ module browser threading seems wrong.
(remq logger-panel l)])))] (remq logger-panel l)])))]
[else [else
(when show? ;; if we want to hide and it isn't built yet, do nothing (when show? ;; if we want to hide and it isn't built yet, do nothing
(define logger-gui-tab-panel-parent (new horizontal-panel% [parent logger-panel] [stretchable-height #f]))
(set! logger-gui-tab-panel (set! logger-gui-tab-panel
(new tab-panel% (new tab-panel%
[choices (list (string-constant logging-all) [choices (list (string-constant logging-all)
"fatal" "error" "warning" "info" "debug")] "fatal" "error" "warning" "info" "debug")]
[parent logger-panel] [parent logger-gui-tab-panel-parent]
[stretchable-height #f]
[style '(no-border)]
[callback [callback
(λ (tp evt) (λ (tp evt)
(preferences:set 'drracket:logger-gui-tab-panel-level (send logger-gui-tab-panel get-selection)) (preferences:set 'drracket:logger-gui-tab-panel-level (send logger-gui-tab-panel get-selection))
(update-logger-window #f))])) (update-logger-window #f))]))
(new button% [label (string-constant hide-log)]
[callback (λ (x y) (send current-tab hide-log))]
[parent logger-gui-tab-panel-parent])
(send logger-gui-tab-panel set-selection (preferences:get 'drracket:logger-gui-tab-panel-level)) (send logger-gui-tab-panel set-selection (preferences:get 'drracket:logger-gui-tab-panel-level))
(new-logger-text) (new-logger-text)
(set! logger-gui-canvas (set! logger-gui-canvas
(new editor-canvas% [parent logger-gui-tab-panel] [editor logger-gui-text])) (new editor-canvas% [parent logger-panel] [editor logger-gui-text]))
(send logger-menu-item set-label (string-constant hide-log)) (send logger-menu-item set-label (string-constant hide-log))
(update-logger-window #f) (update-logger-window #f)
(send logger-parent-panel change-children (lambda (l) (append l (list logger-panel)))))]) (send logger-parent-panel change-children (lambda (l) (append l (list logger-panel)))))])
@ -1669,7 +1678,8 @@ module browser threading seems wrong.
(gui-utils:format-literal-label (string-constant erase-log-directory-contents) (gui-utils:format-literal-label (string-constant erase-log-directory-contents)
transcript-directory) transcript-directory)
this this
'(yes-no))]) '(yes-no)
#:dialog-mixin frame:focus-table-mixin)])
(cond (cond
[(eq? query 'no) [(eq? query 'no)
#f] #f]
@ -1682,7 +1692,8 @@ module browser threading seems wrong.
(if (exn? exn) (if (exn? exn)
(format "~a" (exn-message exn)) (format "~a" (exn-message exn))
(format "~s" exn))) (format "~s" exn)))
this) this
#:dialog-mixin frame:focus-table-mixin)
#f)]) #f)])
(for-each (λ (file) (delete-file (build-path transcript-directory file))) (for-each (λ (file) (delete-file (build-path transcript-directory file)))
dir-list) dir-list)
@ -2647,23 +2658,17 @@ module browser threading seems wrong.
(send interactions-text reset-console) (send interactions-text reset-console)
(send interactions-text clear-undos) (send interactions-text clear-undos)
(let ([start 0]) (define name (send definitions-text get-port-name))
(send definitions-text split-snip start) (define defs-copy (new text%))
(let* ([name (send definitions-text get-port-name)] (send defs-copy set-style-list (send definitions-text get-style-list)) ;; speeds up the copy
[text-port (open-input-text-editor definitions-text start 'end values name #t)]) (send definitions-text copy-self-to defs-copy)
(define text-port (open-input-text-editor defs-copy 0 'end values name #t))
(port-count-lines! text-port) (port-count-lines! text-port)
(let* ([line (send definitions-text position-paragraph start)]
[column (- start (send definitions-text paragraph-start-position line))]
[relocated-port (relocate-input-port text-port
(+ line 1)
column
(+ start 1))])
(port-count-lines! relocated-port)
(send interactions-text evaluate-from-port (send interactions-text evaluate-from-port
relocated-port text-port
#t #t
(λ () (λ ()
(send interactions-text clear-undos)))))))) (send interactions-text clear-undos)))))
(inherit revert save) (inherit revert save)
(define/private (check-if-save-file-up-to-date) (define/private (check-if-save-file-up-to-date)
@ -2677,7 +2682,8 @@ module browser threading seems wrong.
#f #f
this this
'(caution default=2 number-order) '(caution default=2 number-order)
1)]) 1
#:dialog-mixin frame:focus-table-mixin)])
(case user-choice (case user-choice
[(1) (void)] [(1) (void)]
[(2) (revert)])))) [(2) (revert)]))))
@ -2983,22 +2989,33 @@ module browser threading seems wrong.
(update-close-menu-item-shortcut (file-menu:get-close-item))) (update-close-menu-item-shortcut (file-menu:get-close-item)))
(define/private (update-close-tab-menu-item-shortcut item) (define/private (update-close-tab-menu-item-shortcut item)
(let ([just-one? (and (pair? tabs) (null? (cdr tabs)))]) (define just-one? (and (pair? tabs) (null? (cdr tabs))))
(send item set-label (if just-one? (send item set-label (if just-one?
(string-constant close-tab) (string-constant close-tab)
(string-constant close-tab-amp))) (string-constant close-tab-amp)))
(when (preferences:get 'framework:menu-bindings) (when (preferences:get 'framework:menu-bindings)
(send item set-shortcut (if just-one? #f #\w))))) (send item set-shortcut (if just-one? #f #\w))))
(define/private (update-close-menu-item-shortcut item) (define/private (update-close-menu-item-shortcut item)
(let ([just-one? (and (pair? tabs) (null? (cdr tabs)))]) (cond
[(eq? (system-type) 'unix)
(send item set-label (string-constant close-menu-item))]
[else
(define just-one? (and (pair? tabs) (null? (cdr tabs))))
(send item set-label (if just-one? (send item set-label (if just-one?
(string-constant close-menu-item) (string-constant close-window-menu-item)
(string-constant close))) (string-constant close-window)))
(when (preferences:get 'framework:menu-bindings) (when (preferences:get 'framework:menu-bindings)
(send item set-shortcut-prefix (if just-one? (send item set-shortcut-prefix (if just-one?
(get-default-shortcut-prefix) (get-default-shortcut-prefix)
(cons 'shift (get-default-shortcut-prefix))))))) (cons 'shift (get-default-shortcut-prefix)))))]))
(define/override (file-menu:close-callback item control)
(define just-one? (and (pair? tabs) (null? (cdr tabs))))
(if (and (eq? (system-type) 'unix)
(not just-one?))
(close-current-tab)
(super file-menu:close-callback item control)))
;; offer-to-save-file : path -> void ;; offer-to-save-file : path -> void
;; bring the tab that edits the file named by `path' to the front ;; bring the tab that edits the file named by `path' to the front
@ -3113,8 +3130,7 @@ module browser threading seems wrong.
[label (string-constant show-log)] [label (string-constant show-log)]
[parent show-menu] [parent show-menu]
[callback [callback
(λ (x y) (send current-tab toggle-log))])) (λ (x y) (send current-tab toggle-log))])))
)
; ;
@ -3174,7 +3190,8 @@ module browser threading seems wrong.
strs))]) strs))])
(unless can-browse? (unless can-browse?
(message-box (string-constant drscheme) (message-box (string-constant drscheme)
(string-constant module-browser-only-in-plt-and-module-langs))) (string-constant module-browser-only-in-plt-and-module-langs)
#:dialog-mixin frame:focus-table-mixin))
can-browse?)) can-browse?))
(define/private (update-module-browser-pane) (define/private (update-module-browser-pane)
@ -3328,7 +3345,7 @@ module browser threading seems wrong.
(set! file-menu:create-new-tab-item (set! file-menu:create-new-tab-item
(new menu:can-restore-menu-item% (new menu:can-restore-menu-item%
(label (string-constant new-tab)) (label (string-constant new-tab))
(shortcut #\=) (shortcut (if (preferences:get 'drracket:use-old-style-keybindings) #\= #\t))
(parent file-menu) (parent file-menu)
(callback (callback
(λ (x y) (λ (x y)
@ -3339,6 +3356,7 @@ module browser threading seems wrong.
(make-object separator-menu-item% file-menu))] (make-object separator-menu-item% file-menu))]
(define close-tab-menu-item #f) (define close-tab-menu-item #f)
(define/override (file-menu:between-close-and-quit file-menu) (define/override (file-menu:between-close-and-quit file-menu)
(unless (eq? (system-type) 'unix)
(set! close-tab-menu-item (set! close-tab-menu-item
(new (get-menu-item%) (new (get-menu-item%)
(label (string-constant close-tab)) (label (string-constant close-tab))
@ -3348,7 +3366,7 @@ module browser threading seems wrong.
(parent file-menu) (parent file-menu)
(callback (callback
(λ (x y) (λ (x y)
(close-current-tab))))) (close-current-tab))))))
(super file-menu:between-close-and-quit file-menu)) (super file-menu:between-close-and-quit file-menu))
(define/override (file-menu:save-string) (string-constant save-definitions)) (define/override (file-menu:save-string) (string-constant save-definitions))
@ -3406,8 +3424,13 @@ module browser threading seems wrong.
(preferences:get 'framework:print-output-mode))))) (preferences:get 'framework:print-output-mode)))))
(super file-menu:between-print-and-close file-menu)) (super file-menu:between-print-and-close file-menu))
(inherit edit-menu:get-replace-item)
(define/override (edit-menu:between-find-and-preferences edit-menu) (define/override (edit-menu:between-find-and-preferences edit-menu)
(super edit-menu:between-find-and-preferences edit-menu) (super edit-menu:between-find-and-preferences edit-menu)
(when (preferences:get 'drracket:use-old-style-keybindings)
(define item (edit-menu:get-replace-item))
(send item set-shortcut #\r)
(send item set-shortcut-prefix (get-default-shortcut-prefix)))
(new menu:can-restore-menu-item% (new menu:can-restore-menu-item%
[label (string-constant complete-word)] [label (string-constant complete-word)]
[shortcut #\/] [shortcut #\/]
@ -3573,7 +3596,8 @@ module browser threading seems wrong.
(send l capability-value 'drscheme:teachpack-menu-items) (send l capability-value 'drscheme:teachpack-menu-items)
(format "\n ~a" (send l get-language-name)))) (format "\n ~a" (send l get-language-name))))
(drracket:language-configuration:get-languages)))))) (drracket:language-configuration:get-languages))))))
this))])))]))) this
#:dialog-mixin frame:focus-table-mixin))])))])))
(define/private (initialize-menus) (define/private (initialize-menus)
(let* ([mb (get-menu-bar)] (let* ([mb (get-menu-bar)]
@ -3609,7 +3633,7 @@ module browser threading seems wrong.
(string-constant execute-menu-item-label) (string-constant execute-menu-item-label)
language-specific-menu language-specific-menu
(λ (_1 _2) (execute-callback)) (λ (_1 _2) (execute-callback))
#\t (if (preferences:get 'drracket:use-old-style-keybindings) #\t #\r)
(string-constant execute-menu-item-help-string))) (string-constant execute-menu-item-help-string)))
(make-object menu:can-restore-menu-item% (make-object menu:can-restore-menu-item%
(string-constant ask-quit-menu-item-label) (string-constant ask-quit-menu-item-label)
@ -4646,8 +4670,9 @@ module browser threading seems wrong.
(frame:editor-mixin (frame:editor-mixin
(frame:standard-menus-mixin (frame:standard-menus-mixin
(frame:register-group-mixin (frame:register-group-mixin
(frame:focus-table-mixin
(frame:basic-mixin (frame:basic-mixin
frame%)))))))))))))))))) frame%)))))))))))))))))))
(define-local-member-name enable-two-way-prefs) (define-local-member-name enable-two-way-prefs)
(define (make-two-way-prefs-dragable-panel% % pref-key) (define (make-two-way-prefs-dragable-panel% % pref-key)

12
collects/errortrace/stacktrace.rkt
View File

@ -377,16 +377,14 @@
expr expr
(rebuild disarmed-expr (list (cons #'rhs marked)))))] (rebuild disarmed-expr (list (cons #'rhs marked)))))]
[(define-values-for-syntax (name ...) rhs) [(begin-for-syntax . exprs)
top? top?
(let ([marked (with-mark expr
(annotate-named
(one-name (syntax (name ...)))
(syntax rhs)
(add1 phase)))])
(rearm (rearm
expr expr
(rebuild disarmed-expr (list (cons #'rhs marked)))))] (annotate-seq disarmed-expr
(syntax exprs)
annotate-top
(add1 phase)))]
[(module name init-import mb) [(module name init-import mb)
(syntax-case (disarm #'mb) () (syntax-case (disarm #'mb) ()

22
collects/framework/main.rkt
View File

@ -11,6 +11,11 @@
(for-syntax scheme/base) (for-syntax scheme/base)
scribble/srcdoc) scribble/srcdoc)
;; these next two lines do a little dance to make the
;; require/doc setup work out properly
(require (prefix-in :: framework/private/focus-table))
(define frame:lookup-focus-table ::frame:lookup-focus-table)
(require framework/preferences (require framework/preferences
framework/test framework/test
framework/gui-utils framework/gui-utils
@ -710,6 +715,23 @@
Defaults to @racket[#f].}) Defaults to @racket[#f].})
(proc-doc/names
frame:lookup-focus-table
(->* () (eventspace?) (listof (is-a?/c frame:focus-table<%>)))
(()
((eventspace (current-eventspace))))
@{Returns a list of the frames in @racket[eventspace], where the first element of the list
is the frame with the focus.
The order and contents of the list are maintained by
the methods in @racket[frame:focus-table-mixin], meaning that the
OS-level callbacks that track the focus of individual frames is
ignored.
See also @racket[test:use-focus-table] and @racket[test:get-active-top-level-window].
})
(proc-doc/names (proc-doc/names
group:get-the-frame-group group:get-the-frame-group
(-> (is-a?/c group:%)) (-> (is-a?/c group:%))

3
collects/framework/private/color.rkt
View File

@ -638,7 +638,8 @@ added get-regions
(if (is-a? color color%) (if (is-a? color color%)
color color
(if color mismatch-color (get-match-color))) (if color mismatch-color (get-match-color)))
(= caret-pos (+ start-pos start)))]) (= caret-pos (+ start-pos start))
'low)])
(set! clear-old-locations (set! clear-old-locations
(let ([old clear-old-locations]) (let ([old clear-old-locations])
(λ () (λ ()

12
collects/framework/private/finder.rkt
View File

@ -1,14 +1,15 @@
#lang scheme/unit #lang scheme/unit
(require string-constants (require string-constants
(prefix-in r: racket/gui/base)
"sig.rkt" "sig.rkt"
"../preferences.rkt" "../preferences.rkt"
mred/mred-sig mred/mred-sig
scheme/path) scheme/path)
(import mred^ (import mred^
[prefix keymap: framework:keymap^]) [prefix keymap: framework:keymap^]
[prefix frame: framework:frame^])
(export (rename framework:finder^ (export (rename framework:finder^
[-put-file put-file] [-put-file put-file]
@ -44,7 +45,8 @@
[name (or (and (string? name) (file-name-from-path name)) [name (or (and (string? name) (file-name-from-path name))
name)] name)]
[f (put-file prompt parent-win directory name [f (put-file prompt parent-win directory name
(default-extension) style (default-filters))]) (default-extension) style (default-filters)
#:dialog-mixin frame:focus-table-mixin)])
(and f (or (not filter) (filter-match? filter f filter-msg)) (and f (or (not filter) (filter-match? filter f filter-msg))
(let* ([f (normal-case-path (simple-form-path f))] (let* ([f (normal-case-path (simple-form-path f))]
[dir (path-only f)] [dir (path-only f)]
@ -60,6 +62,7 @@
#f] #f]
[else f])))))) [else f]))))))
(define op (current-output-port))
(define (*get-file style) (define (*get-file style)
(lambda ([directory #f] (lambda ([directory #f]
[prompt (string-constant select-file)] [prompt (string-constant select-file)]
@ -67,7 +70,8 @@
[filter-msg (string-constant file-wrong-form)] [filter-msg (string-constant file-wrong-form)]
[parent-win (dialog-parent-parameter)]) [parent-win (dialog-parent-parameter)])
(let ([f (get-file prompt parent-win directory #f (let ([f (get-file prompt parent-win directory #f
(default-extension) style (default-filters))]) (default-extension) style (default-filters)
#:dialog-mixin frame:focus-table-mixin)])
(and f (or (not filter) (filter-match? filter f filter-msg)) (and f (or (not filter) (filter-match? filter f filter-msg))
(cond [(directory-exists? f) (cond [(directory-exists? f)
(message-box (string-constant error) (message-box (string-constant error)

13
collects/framework/private/focus-table.rkt Normal file
View File

@ -0,0 +1,13 @@
#lang racket/base
(require racket/gui/base racket/class)
(provide frame:lookup-focus-table
frame:set-focus-table)
;; focus-table : hash[eventspace -o> (listof frame)]
(define focus-table (make-hash))
(define (frame:lookup-focus-table [eventspace (current-eventspace)])
(hash-ref focus-table eventspace '()))
(define (frame:set-focus-table eventspace new)
(if (null? new)
(hash-remove! focus-table eventspace)
(hash-set! focus-table eventspace new)))

30
collects/framework/private/frame.rkt
View File

@ -9,6 +9,7 @@
"../preferences.rkt" "../preferences.rkt"
"../gui-utils.rkt" "../gui-utils.rkt"
"bday.rkt" "bday.rkt"
framework/private/focus-table
mrlib/close-icon mrlib/close-icon
mred/mred-sig mred/mred-sig
scheme/path) scheme/path)
@ -131,6 +132,26 @@
editing-this-file? editing-this-file?
get-filename get-filename
make-visible)) make-visible))
(define focus-table<%> (interface (top-level-window<%>)))
(define focus-table-mixin
(mixin (top-level-window<%>) (focus-table<%>)
(inherit get-eventspace)
(define/override (show on?)
(define old (remove this (frame:lookup-focus-table (get-eventspace))))
(define new (if on? (cons this old) old))
(frame:set-focus-table (get-eventspace) new)
(super show on?))
(define/augment (on-close)
(frame:set-focus-table (get-eventspace) (remove this (frame:lookup-focus-table (get-eventspace))))
(inner (void) on-close))
(super-new)
(frame:set-focus-table (get-eventspace) (frame:lookup-focus-table (get-eventspace)))))
(define basic-mixin (define basic-mixin
(mixin ((class->interface frame%)) (basic<%>) (mixin ((class->interface frame%)) (basic<%>)
@ -190,12 +211,11 @@
(λ (% parent) (λ (% parent)
(make-object % parent))) (make-object % parent)))
(inherit can-close? on-close) (inherit on-close can-close?)
(define/public close (define/public (close)
(λ ()
(when (can-close?) (when (can-close?)
(on-close) (on-close)
(show #f)))) (show #f)))
(inherit accept-drop-files) (inherit accept-drop-files)
@ -2710,7 +2730,7 @@
(min-width (+ (inexact->exact (ceiling indicator-width)) 4)) (min-width (+ (inexact->exact (ceiling indicator-width)) 4))
(min-height (+ (inexact->exact (ceiling indicator-height)) 4)))) (min-height (+ (inexact->exact (ceiling indicator-height)) 4))))
(define basic% (register-group-mixin (basic-mixin frame%))) (define basic% (focus-table-mixin (register-group-mixin (basic-mixin frame%))))
(define size-pref% (size-pref-mixin basic%)) (define size-pref% (size-pref-mixin basic%))
(define info% (info-mixin basic%)) (define info% (info-mixin basic%))
(define text-info% (text-info-mixin info%)) (define text-info% (text-info-mixin info%))

55
collects/framework/private/handler.rkt
View File

@ -120,25 +120,29 @@
;; add-to-recent : path -> void ;; add-to-recent : path -> void
(define (add-to-recent filename) (define (add-to-recent filename)
(let* ([old-list (preferences:get 'framework:recently-opened-files/pos)]
[old-ents (filter (λ (x) (string=? (path->string (car x))
(path->string filename)))
old-list)]
[old-ent (if (null? old-ents)
#f
(car old-ents))]
[new-ent (list filename
(if old-ent (cadr old-ent) 0)
(if old-ent (caddr old-ent) 0))]
[added-in (cons new-ent
(remove new-ent old-list compare-recent-list-items))]
[new-recent (size-down added-in
(preferences:get 'framework:recent-max-count))])
(preferences:set 'framework:recently-opened-files/pos new-recent)))
;; compare-recent-list-items : recent-list-item recent-list-item -> boolean (define old-list (preferences:get 'framework:recently-opened-files/pos))
(define (compare-recent-list-items l1 l2) (define old-ents (filter (λ (x) (recently-opened-files-same-enough-path? (car x) filename))
(equal? (car l1) (car l2))) old-list))
(define new-ent (if (null? old-ents)
(list filename 0 0)
(cons filename (cdr (car old-ents)))))
(define added-in (cons new-ent
(remove* (list new-ent)
old-list
(λ (l1 l2)
(recently-opened-files-same-enough-path? (car l1) (car l2))))))
(define new-recent (size-down added-in
(preferences:get 'framework:recent-max-count)))
(preferences:set 'framework:recently-opened-files/pos new-recent))
;; same-enough-path? : path path -> boolean
;; used to determine if the open-recent-files menu item considers two paths to be the same
(define (recently-opened-files-same-enough-path? p1 p2)
(equal? (simplify-path (normal-case-path p1) #f)
(simplify-path (normal-case-path p2) #f)))
;; size-down : (listof X) -> (listof X)[< recent-max-count] ;; size-down : (listof X) -> (listof X)[< recent-max-count]
;; takes a list of stuff and returns the ;; takes a list of stuff and returns the
@ -167,7 +171,7 @@
(preferences:get 'framework:recently-opened-files/pos)] (preferences:get 'framework:recently-opened-files/pos)]
[new-recent-items [new-recent-items
(map (λ (x) (map (λ (x)
(if (string=? (path->string (car x)) (if (recently-opened-files-same-enough-path? (path->string (car x))
(path->string filename)) (path->string filename))
(list* (car x) start end (cdddr x)) (list* (car x) start end (cdddr x))
x)) x))
@ -198,9 +202,8 @@
(define (recent-list-item->menu-label recent-list-item) (define (recent-list-item->menu-label recent-list-item)
(let ([filename (car recent-list-item)]) (let ([filename (car recent-list-item)])
(gui-utils:trim-string (gui-utils:quote-literal-label
(regexp-replace* #rx"&" (path->string filename) "\\&\\&") (path->string filename))))
200)))
;; this function must mimic what happens in install-recent-items ;; this function must mimic what happens in install-recent-items
;; it returns #t if all of the labels of menus are the same, or approximation to ;; it returns #t if all of the labels of menus are the same, or approximation to
@ -232,8 +235,12 @@
(send ed set-position start end)))))] (send ed set-position start end)))))]
[else [else
(preferences:set 'framework:recently-opened-files/pos (preferences:set 'framework:recently-opened-files/pos
(remove recent-list-item (remove* (list recent-list-item)
(preferences:get 'framework:recently-opened-files/pos))) (preferences:get 'framework:recently-opened-files/pos)
(λ (l1 l2)
(recently-opened-files-same-enough-path?
(car l1)
(car l2)))))
(message-box (string-constant error) (message-box (string-constant error)
(format (string-constant cannot-open-because-dne) (format (string-constant cannot-open-because-dne)
filename))]))) filename))])))

2
collects/framework/private/sig.rkt
View File

@ -256,6 +256,7 @@
(define-signature frame-class^ (define-signature frame-class^
(basic<%> (basic<%>
focus-table<%>
size-pref<%> size-pref<%>
register-group<%> register-group<%>
status-line<%> status-line<%>
@ -285,6 +286,7 @@
delegate% delegate%
pasteboard% pasteboard%
focus-table-mixin
basic-mixin basic-mixin
size-pref-mixin size-pref-mixin
register-group-mixin register-group-mixin

8
collects/framework/private/standard-menus-items.rkt
View File

@ -265,7 +265,9 @@
'(λ (item control) (when (can-close?) (on-close) (show #f)) #t) '(λ (item control) (when (can-close?) (on-close) (show #f)) #t)
#\w #\w
'(get-default-shortcut-prefix) '(get-default-shortcut-prefix)
'(string-constant close-menu-item) '(if (eq? (system-type) 'unix)
(string-constant close-menu-item)
(string-constant close-window-menu-item))
on-demand-do-nothing on-demand-do-nothing
#t) #t)
(make-between 'file-menu 'close 'quit 'nothing) (make-between 'file-menu 'close 'quit 'nothing)
@ -387,8 +389,8 @@
(make-an-item 'edit-menu 'replace (make-an-item 'edit-menu 'replace
'(string-constant replace-info) '(string-constant replace-info)
'(λ (item control) (void)) '(λ (item control) (void))
#\r #\f
'(get-default-shortcut-prefix) '(cons 'shift (get-default-shortcut-prefix))
'(string-constant replace-menu-item) '(string-constant replace-menu-item)
on-demand-do-nothing on-demand-do-nothing
#f) #f)

10
collects/framework/private/standard-menus.rkt
View File

@ -272,7 +272,11 @@
file-menu:close-callback file-menu:close-callback
(λ (item control) (when (can-close?) (on-close) (show #f)) #t)) (λ (item control) (when (can-close?) (on-close) (show #f)) #t))
(define/public (file-menu:get-close-item) file-menu:close-item) (define/public (file-menu:get-close-item) file-menu:close-item)
(define/public (file-menu:close-string) (string-constant close-menu-item)) (define/public
(file-menu:close-string)
(if (eq? (system-type) 'unix)
(string-constant close-menu-item)
(string-constant close-window-menu-item)))
(define/public (file-menu:close-help-string) (string-constant close-info)) (define/public (file-menu:close-help-string) (string-constant close-info))
(define/public file-menu:close-on-demand (λ (menu-item) (void))) (define/public file-menu:close-on-demand (λ (menu-item) (void)))
(define/public (file-menu:create-close?) #t) (define/public (file-menu:create-close?) #t)
@ -911,8 +915,8 @@
(let ((edit-menu:replace-callback (let ((edit-menu:replace-callback
(λ (item evt) (edit-menu:replace-callback item evt)))) (λ (item evt) (edit-menu:replace-callback item evt))))
edit-menu:replace-callback)) edit-menu:replace-callback))
(shortcut #\r) (shortcut #\f)
(shortcut-prefix (get-default-shortcut-prefix)) (shortcut-prefix (cons 'shift (get-default-shortcut-prefix)))
(help-string (edit-menu:replace-help-string)) (help-string (edit-menu:replace-help-string))
(demand-callback (demand-callback
(λ (menu-item) (edit-menu:replace-on-demand menu-item)))))) (λ (menu-item) (edit-menu:replace-on-demand menu-item))))))

68
collects/framework/test.rkt
View File

@ -1,10 +1,12 @@
#lang at-exp scheme/gui #lang at-exp scheme/gui
(require scribble/srcdoc) (require scribble/srcdoc
(require/doc scheme/base scribble/manual) (prefix-in :: framework/private/focus-table))
(require/doc scheme/base scribble/manual
(for-label framework))
(define (test:top-level-focus-window-has? pred) (define (test:top-level-focus-window-has? pred)
(let ([tlw (get-top-level-focus-window)]) (let ([tlw (test:get-active-top-level-window)])
(and tlw (and tlw
(let loop ([tlw tlw]) (let loop ([tlw tlw])
(or (pred tlw) (or (pred tlw)
@ -165,16 +167,30 @@
(define current-get-eventspaces (define current-get-eventspaces
(make-parameter (λ () (list (current-eventspace))))) (make-parameter (λ () (list (current-eventspace)))))
(define (get-active-frame) (define test:use-focus-table (make-parameter #f))
(define (test:get-active-top-level-window)
(ormap (λ (eventspace) (ormap (λ (eventspace)
(parameterize ([current-eventspace eventspace]) (parameterize ([current-eventspace eventspace])
(get-top-level-focus-window))) (cond
[(test:use-focus-table)
(define lst (::frame:lookup-focus-table))
(define focusd (and (not (null? lst)) (car lst)))
(when (eq? (test:use-focus-table) 'debug)
(define f2 (get-top-level-focus-window))
(unless (eq? focusd f2)
(eprintf "found mismatch focus-table: ~s vs get-top-level-focus-window: ~s\n"
(map (λ (x) (send x get-label)) lst)
(and f2 (list (send f2 get-label))))))
focusd]
[else
(get-top-level-focus-window)])))
((current-get-eventspaces)))) ((current-get-eventspaces))))
(define (get-focused-window) (define (get-focused-window)
(let ([f (get-active-frame)]) (let ([f (test:get-active-top-level-window)])
(and f (and f
(send f get-focus-window)))) (send f get-edit-target-window))))
(define time-stamp current-milliseconds) (define time-stamp current-milliseconds)
@ -200,14 +216,13 @@
;; get-parent returns () for no parent. ;; get-parent returns () for no parent.
;; ;;
(define in-active-frame? (define (in-active-frame? window)
(λ (window) (let ([frame (test:get-active-top-level-window)])
(let ([frame (get-active-frame)])
(let loop ([window window]) (let loop ([window window])
(cond [(not window) #f] (cond [(not window) #f]
[(null? window) #f] ;; is this test needed? [(null? window) #f] ;; is this test needed?
[(eq? window frame) #t] [(eq? window frame) #t]
[else (loop (send window get-parent))]))))) [else (loop (send window get-parent))]))))
;; ;;
;; Verify modifier list. ;; Verify modifier list.
@ -239,7 +254,7 @@
(cond (cond
[(or (string? b-desc) [(or (string? b-desc)
(procedure? b-desc)) (procedure? b-desc))
(let* ([active-frame (get-active-frame)] (let* ([active-frame (test:get-active-top-level-window)]
[_ (unless active-frame [_ (unless active-frame
(error object-tag (error object-tag
"could not find object: ~a, no active frame" "could not find object: ~a, no active frame"
@ -516,7 +531,7 @@
[else [else
(error (error
key-tag key-tag
"focused window is not a text-field% and does not have on-char")])] "focused window is not a text-field% and does not have on-char, ~e" window)])]
[(send (car l) on-subwindow-char window event) #f] [(send (car l) on-subwindow-char window event) #f]
[else (loop (cdr l))]))) [else (loop (cdr l))])))
@ -573,8 +588,7 @@
(define menu-tag 'test:menu-select) (define menu-tag 'test:menu-select)
(define menu-select (define (menu-select menu-name . item-names)
(λ (menu-name . item-names)
(cond (cond
[(not (string? menu-name)) [(not (string? menu-name))
(error menu-tag "expects string, given: ~e" menu-name)] (error menu-tag "expects string, given: ~e" menu-name)]
@ -583,11 +597,11 @@
[else [else
(run-one (run-one
(λ () (λ ()
(let* ([frame (get-active-frame)] (let* ([frame (test:get-active-top-level-window)]
[item (get-menu-item frame (cons menu-name item-names))] [item (get-menu-item frame (cons menu-name item-names))]
[evt (make-object control-event% 'menu)]) [evt (make-object control-event% 'menu)])
(send evt set-time-stamp (current-milliseconds)) (send evt set-time-stamp (current-milliseconds))
(send item command evt))))]))) (send item command evt))))]))
(define get-menu-item (define get-menu-item
(λ (frame item-names) (λ (frame item-names)
@ -1021,7 +1035,7 @@
test:top-level-focus-window-has? test:top-level-focus-window-has?
(-> (-> (is-a?/c area<%>) boolean?) boolean?) (-> (-> (is-a?/c area<%>) boolean?) boolean?)
(test) (test)
@{Calls @racket[test] for each child of the top-level-focus-frame @{Calls @racket[test] for each child of the @racket[test:get-active-top-level-window]
and returns @racket[#t] if @racket[test] ever does, otherwise and returns @racket[#t] if @racket[test] ever does, otherwise
returns @racket[#f]. If there returns @racket[#f]. If there
is no top-level-focus-window, returns @racket[#f].}) is no top-level-focus-window, returns @racket[#f].})
@ -1041,4 +1055,20 @@
test:run-one test:run-one
(-> (-> void?) void?) (-> (-> void?) void?)
(f) (f)
@{Runs the function @racket[f] as if it was a simulated event.})) @{Runs the function @racket[f] as if it was a simulated event.})
(parameter-doc
test:use-focus-table
(parameter/c (or/c boolean? 'debug))
use-focus-table?
@{If @racket[#t], then the test framework uses @racket[frame:lookup-focus-table] to determine
which is the focused frame. If @racket[#f], then it uses @racket[get-top-level-focus-window].
If @racket[test:use-focus-table]'s value is @racket['debug], then it still uses
@racket[frame:lookup-focus-table] but it also prints a message to the @racket[current-error-port]
when the two methods would give different results.})
(proc-doc/names
test:get-active-top-level-window
(-> (or/c (is-a?/c frame%) (is-a?/c dialog%) #f))
()
@{Returns the frontmost frame, based on @racket[test:use-focus-table].}))

5
collects/gui-debugger/annotator.rkt
View File

@ -203,9 +203,8 @@
] ]
[(define-syntaxes (var ...) expr) [(define-syntaxes (var ...) expr)
stx] stx]
[(define-values-for-syntax (var ...) expr) [(begin-for-syntax . exprs)
;; define-values-for-syntax's RHS is compile time, so treat it ;; compile time, so treat it like define-syntaxes
;; like define-syntaxes
stx] stx]
[(begin . top-level-exprs) [(begin . top-level-exprs)
(quasisyntax/loc stx (begin #,@(map (lambda (expr) (quasisyntax/loc stx (begin #,@(map (lambda (expr)

6
collects/gui-debugger/debug-tool.rkt
View File

@ -132,6 +132,10 @@
(> size (vector-length v))) (> size (vector-length v)))
'... '...
(truncate-value (vector-ref v i) size (sub1 depth)))))] (truncate-value (vector-ref v i) size (sub1 depth)))))]
[(bytes? v)
(if (> (bytes-length v) size)
(bytes-append (subbytes v 0 size) #"...")
v)]
[else v])) [else v]))
(define filename->defs (define filename->defs
@ -1141,7 +1145,7 @@
(for-each (for-each
(lambda (name/value) (lambda (name/value)
(let ([name (format "~a" (syntax-e (first name/value)))] (let ([name (format "~a" (syntax-e (first name/value)))]
[value (format " => ~s\n" (second name/value))]) [value (format " => ~s\n" (truncate-value (second name/value) 100 5))])
(send variables-text insert name) (send variables-text insert name)
(send variables-text change-style bold-sd (send variables-text change-style bold-sd
(- (send variables-text last-position) (string-length name)) (- (send variables-text last-position) (string-length name))

8
collects/honu/core/language.rkt
View File

@ -4,8 +4,16 @@
(provide honu-info) (provide honu-info)
(define (honu-info key default default-filter) (define (honu-info key default default-filter)
; (printf "get info for ~a\n" key)
(case key (case key
[(color-lexer) (dynamic-require 'honu/core/read [(color-lexer) (dynamic-require 'honu/core/read
'color-lexer)] 'color-lexer)]
[else [else
(default-filter key default)])) (default-filter key default)]))
(provide honu-language-info)
(define (honu-language-info data)
(lambda (key default)
(case key
[(configure-runtime) '(#(honu/core/runtime configure #f))]
[else default])))

7
collects/honu/core/main.rkt
View File

@ -2,13 +2,19 @@
(require "private/honu-typed-scheme.rkt" (require "private/honu-typed-scheme.rkt"
"private/honu2.rkt" "private/honu2.rkt"
"private/macro2.rkt"
(for-syntax (only-in "private/parse2.rkt" honu-expression))
(prefix-in literal: "private/literals.rkt")) (prefix-in literal: "private/literals.rkt"))
(provide #%top (provide #%top
#%datum #%datum
print printf true false print printf true false
(for-syntax (rename-out [honu-expression expression]))
(rename-out [#%dynamic-honu-module-begin #%module-begin] (rename-out [#%dynamic-honu-module-begin #%module-begin]
[honu-top-interaction #%top-interaction]
[honu-function function] [honu-function function]
[honu-macro macro]
[honu-syntax syntax]
[honu-var var] [honu-var var]
[honu-val val] [honu-val val]
[honu-for for] [honu-for for]
@ -21,6 +27,7 @@
[honu-> >] [honu-< <] [honu-> >] [honu-< <]
[honu->= >=] [honu-<= <=] [honu->= >=] [honu-<= <=]
[honu-= =] [honu-= =]
[honu-assignment :=]
[literal:honu-<- <-] [literal:honu-<- <-]
[honu-map map] [honu-map map]
[honu-flow \|] [honu-flow \|]

15
collects/honu/core/private/honu-typed-scheme.rkt
View File

@ -445,21 +445,26 @@ Then, in the pattern above for 'if', 'then' would be bound to the following synt
#'rest)]))) #'rest)])))
(define-for-syntax (honu-expand forms) (define-for-syntax (honu-expand forms)
(parse-all forms)) (parse-one forms))
(define-for-syntax (honu-compile forms) (define-for-syntax (honu-compile forms)
#'(void)) #'(void))
(define-syntax (honu-unparsed-begin stx) (define-syntax (honu-unparsed-begin stx)
(emit-remark "Honu unparsed begin!" stx) (emit-remark "Honu unparsed begin!" stx)
(debug "honu unparsed begin: ~a at phase ~a\n" (syntax->datum stx) (syntax-local-phase-level)) (debug "honu unparsed begin: ~a at phase ~a\n" (syntax->datum stx) (syntax-local-phase-level))
(syntax-parse stx (syntax-parse stx
[(_) #'(void)] [(_) #'(void)]
[(_ forms ...) [(_ forms ...)
(define expanded (honu-expand #'(forms ...))) (define-values (parsed unparsed) (honu-expand #'(forms ...)))
(debug "expanded ~a\n" (syntax->datum expanded)) (debug "expanded ~a unexpanded ~a\n"
expanded])) (syntax->datum parsed)
(syntax->datum unparsed))
(with-syntax ([parsed parsed]
[(unparsed ...) unparsed])
(if (null? (syntax->datum #'(unparsed ...)))
#'parsed
#'(begin parsed (honu-unparsed-begin unparsed ...))))]))
(define-syntax (#%dynamic-honu-module-begin stx) (define-syntax (#%dynamic-honu-module-begin stx)
(syntax-case stx () (syntax-case stx ()

14
collects/honu/core/private/honu2.rkt
View File

@ -3,6 +3,7 @@
(require "macro2.rkt" (require "macro2.rkt"
"operator.rkt" "operator.rkt"
"struct.rkt" "struct.rkt"
"honu-typed-scheme.rkt"
(only-in "literals.rkt" (only-in "literals.rkt"
honu-then honu-then
semicolon) semicolon)
@ -136,6 +137,13 @@
[right right]) [right right])
#'(right left)))) #'(right left))))
(provide honu-assignment)
(define-honu-operator/syntax honu-assignment 0.0001 'left
(lambda (left right)
(with-syntax ([left left]
[right right])
#'(set! left right))))
(define-binary-operator honu-+ 1 'left +) (define-binary-operator honu-+ 1 'left +)
(define-binary-operator honu-- 1 'left -) (define-binary-operator honu-- 1 'left -)
(define-binary-operator honu-* 2 'left *) (define-binary-operator honu-* 2 'left *)
@ -152,3 +160,9 @@
(define-binary-operator honu-map 0.09 'left map) (define-binary-operator honu-map 0.09 'left map)
(define-unary-operator honu-not 0.7 'left not) (define-unary-operator honu-not 0.7 'left not)
(provide honu-top-interaction)
(define-syntax (honu-top-interaction stx)
(syntax-case stx ()
[(_ rest ...)
#'(#%top-interaction . (honu-unparsed-begin rest ...))]))

47
collects/honu/core/private/macro2.rkt
View File

@ -3,6 +3,7 @@
(require (for-syntax "transformer.rkt" (require (for-syntax "transformer.rkt"
syntax/define syntax/define
syntax/parse syntax/parse
syntax/stx
"literals.rkt" "literals.rkt"
"parse2.rkt" "parse2.rkt"
"debug.rkt" "debug.rkt"
@ -17,30 +18,39 @@
(syntax/loc stx (syntax/loc stx
(define-syntax id (make-honu-transformer rhs)))))) (define-syntax id (make-honu-transformer rhs))))))
(define-for-syntax (convert-pattern pattern) (define-for-syntax (convert-pattern original-pattern)
(syntax-parse pattern (define-splicing-syntax-class pattern-type
[(name semicolon class) #:literal-sets (cruft)
#'(~var name class)])) [pattern (~seq name colon class)
#:with result #'(~var name class #:attr-name-separator "_")]
[pattern x #:with result #'x])
(syntax-parse original-pattern
[(thing:pattern-type ...)
#'(thing.result ...)]))
(provide macro) (provide honu-macro)
(define-honu-syntax macro (define-honu-syntax honu-macro
(lambda (code context) (lambda (code context)
(debug "Macroize ~a\n" code) (debug "Macroize ~a\n" code)
(syntax-parse code #:literal-sets (cruft) (syntax-parse code #:literal-sets (cruft)
[(_ name literals (#%braces pattern ...) (#%braces action ...) . rest) [(_ name literals (#%braces pattern ...) (#%braces action ...) . rest)
(debug "Pattern is ~a\n" #'(pattern ...)) (debug "Pattern is ~a\n" #'(pattern ...))
(values (values
(with-syntax ([syntax-parse-pattern (with-syntax ([(syntax-parse-pattern ...)
(convert-pattern #'(pattern ...))]) (convert-pattern #'(pattern ...))])
#'(define-honu-syntax name #'(define-honu-syntax name
(lambda (stx context-name) (lambda (stx context-name)
(syntax-parse stx (syntax-parse stx
[(_ syntax-parse-pattern . more) [(_ syntax-parse-pattern ... . more)
(values #'(let-syntax ([do-parse (lambda (stx) (values #'(let-syntax ([do-parse (lambda (stx)
(parse-all stx))]) (define what (parse-all (stx-cdr stx)))
(debug "Macro parse all ~a\n" what)
what)])
(do-parse action ...)) (do-parse action ...))
#'more)])))) #'more
#'rest)]))) #t)]))))
#'rest
#t)])))
(provide (rename-out [honu-with-syntax withSyntax])) (provide (rename-out [honu-with-syntax withSyntax]))
(define-honu-syntax honu-with-syntax (define-honu-syntax honu-with-syntax
@ -49,3 +59,18 @@
[(_ [#%brackets name:id data] [(_ [#%brackets name:id data]
(#%braces code ...)) (#%braces code ...))
#'(with-syntax ([name data]) code ...)]))) #'(with-syntax ([name data]) code ...)])))
(define-syntax (parse-stuff stx)
(syntax-parse stx
[(_ stuff ...)
(parse-all #'(stuff ...))]))
(provide honu-syntax)
(define-honu-syntax honu-syntax
(lambda (code context)
(syntax-parse code #:literal-sets (cruft)
[(_ (#%parens stuff ...) . rest)
(values
#'(parse-stuff stuff ...)
#'rest
#f)])))

16
collects/honu/core/private/parse2.rkt
View File

@ -120,6 +120,13 @@
(loop (cons parsed used) (loop (cons parsed used)
unparsed)))))) unparsed))))))
(define parsed-property (gensym 'honu-parsed))
(define (parsed-syntax syntax)
(syntax-property syntax parsed-property #t))
(define (parsed-syntax? syntax)
(syntax-property syntax parsed-property))
(define (stopper? what) (define (stopper? what)
(define-literal-set check (honu-comma semicolon colon)) (define-literal-set check (honu-comma semicolon colon))
(define is (and (identifier? what) (define is (and (identifier? what)
@ -178,6 +185,8 @@
#'rest) #'rest)
(do-parse #'rest precedence (do-parse #'rest precedence
left #'parsed)))))] left #'parsed)))))]
[(parsed-syntax? #'head)
(do-parse #'(rest ...) precedence left #'head)]
[(honu-operator? #'head) [(honu-operator? #'head)
(define new-precedence (transformer:honu-operator-ref (syntax-local-value #'head) 0)) (define new-precedence (transformer:honu-operator-ref (syntax-local-value #'head) 0))
(define association (transformer:honu-operator-ref (syntax-local-value #'head) 1)) (define association (transformer:honu-operator-ref (syntax-local-value #'head) 1))
@ -283,13 +292,20 @@
(error 'parse "function call")] (error 'parse "function call")]
[else (error 'what "dont know how to parse ~a" #'head)])])])])) [else (error 'what "dont know how to parse ~a" #'head)])])])]))
(define-values (parsed unparsed)
(do-parse input 0 (lambda (x) x) #f)) (do-parse input 0 (lambda (x) x) #f))
(values (parsed-syntax parsed)
unparsed))
(define (empty-syntax? what) (define (empty-syntax? what)
(syntax-parse what (syntax-parse what
[() #t] [() #t]
[else #f])) [else #f]))
(provide parse-one)
(define (parse-one code)
(parse (strip-stops code)))
(define (parse-all code) (define (parse-all code)
(let loop ([all '()] (let loop ([all '()]
[code code]) [code code])

1
collects/honu/core/private/util.rkt
View File

@ -2,7 +2,6 @@
(provide (except-out (all-defined-out) test-delimiter)) (provide (except-out (all-defined-out) test-delimiter))
(require "debug.rkt" (require "debug.rkt"
tests/eli-tester
racket/match racket/match
(for-syntax racket/base) (for-syntax racket/base)
syntax/stx syntax/stx

6
collects/honu/core/read.rkt
View File

@ -34,7 +34,7 @@
(:~ #\"))) (:~ #\")))
(define-lex-abbrev string (:: #\" (:* string-character) #\")) (define-lex-abbrev string (:: #\" (:* string-character) #\"))
(define-lex-abbrev operator (:or "+" "=" "*" "/" "-" "^" "||" "|" "&&" "<=" (define-lex-abbrev operator (:or "+" "=" "*" "/" "-" "^" "||" "|" "&&" "<="
">=" "<-" "<" ">" "!" "::")) ">=" "<-" "<" ">" "!" "::" ":="))
(define-lex-abbrev block-comment (:: "/*" (define-lex-abbrev block-comment (:: "/*"
(complement (:: any-string "*/" any-string)) (complement (:: any-string "*/" any-string))
"*/")) "*/"))
@ -42,7 +42,7 @@
(define-lex-abbrev line-comment (:: (:or "#" "//") (define-lex-abbrev line-comment (:: (:or "#" "//")
(:* (:~ "\n")) (:* (:~ "\n"))
;; we might hit eof before a \n ;; we might hit eof before a \n
(:? "\n"))) (:? "\n" "\r")))
(define (replace-escapes string) (define (replace-escapes string)
(define replacements '([#px"\\\\n" "\n"] (define replacements '([#px"\\\\n" "\n"]
@ -60,7 +60,7 @@
#; #;
[line-comment (token-whitespace)] [line-comment (token-whitespace)]
[(:or "#" "//") (token-end-of-line-comment)] [(:or "#" "//") (token-end-of-line-comment)]
["\n" (token-whitespace)] [(:? "\n" "\r") (token-whitespace)]
[number (token-number (string->number lexeme))] [number (token-number (string->number lexeme))]
#; #;
[block-comment (token-whitespace)] [block-comment (token-whitespace)]

7
collects/honu/core/runtime.rkt Normal file
View File

@ -0,0 +1,7 @@
#lang racket/base
(require "read.rkt")
(provide configure)
(define (configure . args)
(current-read-interaction honu-read-syntax))

1
collects/honu/lang/reader.rkt
View File

@ -6,6 +6,7 @@ honu
#:read-syntax honu-read-syntax #:read-syntax honu-read-syntax
#:whole-body-readers? #t #:whole-body-readers? #t
#:info honu-info #:info honu-info
#:language-info #(honu/core/language honu-language-info #f)
(require "../core/read.rkt" (require "../core/read.rkt"
"../core/language.rkt") "../core/language.rkt")

2
collects/honu/main.rkt
View File

@ -1,4 +1,4 @@
#lang racket/base #lang honu/private
(require (prefix-in racket: (combine-in racket/base racket/list))) (require (prefix-in racket: (combine-in racket/base racket/list)))

12
collects/honu/private/lang/reader.rkt Normal file
View File

@ -0,0 +1,12 @@
#lang s-exp syntax/module-reader
honu/private/main
;;#:read honu-read
;;#:read-syntax honu-read-syntax
;;#:whole-body-readers? #t
#:language-info #(honu/core/language honu-language-info #f)
; #:language-info #(honu/core/runtime configure 'dont-care)
(require honu/core/read
honu/core/language)

4
collects/honu/private/main.rkt Normal file
View File

@ -0,0 +1,4 @@
#lang racket/base
(require racket/base)
(provide (all-from-out racket/base))

Some files were not shown because too many files have changed in this diff Show More