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

io: fix some test failures

Browse Source
This commit is contained in:
Matthew Flatt 2018-11-14 19:33:30 -07:00
parent 1e726581ef
commit 4068b9097d
11 changed files with 32 additions and 73 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

58
pkgs/racket-test-core/tests/racket/thrport.rktl
View File

@ -1,58 +0,0 @@
(load-relative "loadtest.rktl")
(Section 'multi-threaded-ports)
; Read from file with 3 threads, all writing to the same pipe
; read from pipe with 3 threads, all writing to the same output string
; compare resulting character content to the original file
(test 0 'threaded-ports
(let*-values ([(f-in) (open-input-file
(path->complete-path "testing.rktl"
(current-load-relative-directory)))]
[(p-in p-out) (make-pipe)]
[(s-out) (open-output-string)]
[(in->out) (lambda (in out)
(lambda ()
(let loop ()
(let ([c (read-char in)]
[dummy (lambda () 'hi)])
(unless (eof-object? c)
(write-char c out)
(loop))))))]
[(f->p) (in->out f-in p-out)]
[(p->s) (in->out p-in s-out)]
[(sthread) (lambda (thunk)
(let ([t (thread (lambda () (sleep) (thunk)))])
(thread-weight t 101)
t))])
(thread
(lambda ()
(for-each thread-wait
(list (sthread f->p)
(sthread f->p)
(sthread f->p)))
(close-output-port p-out)))
(for-each thread-wait
(list (sthread p->s)
(sthread p->s)
(sthread p->s)))
(let ([s (get-output-string s-out)]
[hits (make-vector 256 0)])
(for-each (lambda (c)
(let ([n (char->integer c)])
(vector-set! hits n (add1 (vector-ref hits n)))))
(string->list s))
(file-position f-in 0)
(let loop ()
(let ([c (read-char f-in)])
(unless (eof-object? c)
(let ([n (char->integer c)])
(vector-set! hits n (sub1 (vector-ref hits n))))
(loop))))
(let loop ([i 0][total 0])
(if (= i 256)
total
(loop (add1 i) (+ total (abs (vector-ref hits i)))))))))
(report-errs)

10
racket/src/io/file/main.rkt
View File

@ -342,7 +342,7 @@
"")
(host-> path-host)))))
(define/who (resolve-path p)
(define (do-resolve-path p who)
(check who path-string? p)
(define host-path (->host (path->path-without-trailing-separator (->path p)) who '(exists)))
(start-atomic)
@ -363,6 +363,14 @@
[else new-path])]
[else (host-> r)]))
(define/who (resolve-path p)
(do-resolve-path p who))
(module+ for-simplify
(provide resolve-path-for-simplify)
(define (resolve-path-for-simplify p)
(do-resolve-path p 'simplify-path)))
(define/who (expand-user-path p)
(check who path-string? p)
(define path (->path p))

2
racket/src/io/network/tcp-connect.rkt
View File

@ -45,7 +45,7 @@
(if port-no
(format "\n port number: ~a" port-no)
""))))
(security-guard-check-network who hostname port-no #t)
(security-guard-check-network who hostname port-no 'client)
(atomically
(call-with-resolved-address
hostname port-no

2
racket/src/io/network/tcp-listen.rkt
View File

@ -33,7 +33,7 @@
(format "\n hostname: ~a" hostname)
"")
(format "\n port number: ~a" port-no))))
(security-guard-check-network who hostname port-no #f)
(security-guard-check-network who hostname port-no 'server)
(let loop ([family RKTIO_FAMILY_ANY])
((atomically
;; Result is a thunk that might call `loop`

2
racket/src/io/network/udp-send.rkt
View File

@ -76,7 +76,7 @@
(check who string? hostname)
(check who port-number? port-no)
(check-bstr who bstr start end)
(security-guard-check-network who hostname port-no #t))
(security-guard-check-network who hostname port-no 'client))
;; ----------------------------------------

6
racket/src/io/network/udp-socket.rkt
View File

@ -32,7 +32,7 @@
(define/who (udp-open-socket [family-hostname #f] [family-port-no #f])
(check who string? #:or-false family-hostname)
(check who port-number? #:or-false family-port-no)
(security-guard-check-network who family-hostname family-port-no #f)
(security-guard-check-network who family-hostname family-port-no 'server)
(atomically
(call-with-resolved-address
#:who who
@ -65,7 +65,7 @@
(check who udp? u)
(check who string? #:or-false hostname)
(check who listen-port-number? port-no)
(security-guard-check-network who hostname port-no #f)
(security-guard-check-network who hostname port-no 'server)
(atomically
(call-with-resolved-address
#:who who
@ -96,7 +96,7 @@
"last second and third arguments must be both #f or both non-#f"
"second argument" hostname
"third argument" port-no))
(security-guard-check-network who hostname port-no #t)
(security-guard-check-network who hostname port-no 'client)
(atomically
(cond
[(not hostname)

5
racket/src/io/path/api.rkt
View File

@ -22,7 +22,7 @@
[(p)
;; Supplying `current-directory` (as opposed to `raw:current-directory`)
;; triggers an appropriate security-guard check if needed:
(raw:path->complete-path p current-directory #:wrt-given? #f)]
(raw:path->complete-path p current-directory-for-path->complete-path #:wrt-given? #f)]
[(p wrt) (raw:path->complete-path p wrt #:wrt-given? #t)]))
(define/who (current-drive)
@ -46,6 +46,9 @@
(define/who current-directory
(chaperone-procedure raw:current-directory (make-guard-paths who)))
(define/who current-directory-for-path->complete-path
(chaperone-procedure raw:current-directory (make-guard-paths 'path->complete-path)))
(define/who current-directory-for-user
(chaperone-procedure raw:current-directory-for-user (make-guard-paths who)))

3
racket/src/io/path/simplify.rkt
View File

@ -1,5 +1,6 @@
#lang racket/base
(require "../file/main.rkt"
(submod "../file/main.rkt" for-simplify)
"path.rkt"
"check.rkt"
"check-path.rkt"
@ -55,7 +56,7 @@
(loop (cdr l) base accum seen)]
[(eq? 'up (car l))
(define new-base (combine base accum))
(define target (resolve-path new-base))
(define target (resolve-path-for-simplify new-base))
(define-values (from-base new-seen)
(cond
[(eq? target new-base) (values new-base seen)]

4
racket/src/io/print/char.rkt
View File

@ -34,7 +34,7 @@
(cond
[(n . <= . #xFFFF)
(let ([max-length (write-string/max "#\\u" o max-length)])
(write-string/max (pad 4 (number->string n 16)) o max-length))]
(write-string/max (pad 4 (string-upcase (number->string n 16))) o max-length))]
[else
(let ([max-length (write-string/max "#\\U" o max-length)])
(write-string/max (pad 8 (number->string n 16)) o max-length))])]))
(write-string/max (pad 8 (string-upcase (number->string n 16))) o max-length))])]))

4
racket/src/io/print/string.rkt
View File

@ -50,9 +50,9 @@
(cond
[(n . <= . #xFFFF)
(let ([max-length (write-bytes/max #"\\u" o max-length)])
(write-string/max (pad 4 (number->string n 16)) o max-length))]
(write-string/max (pad 4 (string-upcase (number->string n 16))) o max-length))]
[else
(let ([max-length (write-bytes/max #"\\U" o max-length)])
(write-string/max (pad 8 (number->string n 16)) o max-length))])]
(write-string/max (pad 8 (string-upcase (number->string n 16))) o max-length))])]
[i (add1 i)])
(loop i i max-length))])]))))

9
racket/src/io/security/main.rkt
View File

@ -78,12 +78,17 @@
((security-guard-link-guard sg) check-who path dest)
(loop (security-guard-parent sg)))))
(define/who (security-guard-check-network check-who given-host port client?)
(define/who (security-guard-check-network check-who given-host port mode)
(check who symbol? check-who)
(check who string? #:or-false given-host)
(check who listen-port-number? #:or-false port)
(check who (lambda (s)
(or (eq? s 'client)
(eq? s 'server)))
#:contract "(or/c 'client 'server)"
mode)
(define host (and given-host (string->immutable-string given-host)))
(let loop ([sg (current-security-guard)])
(when sg
((security-guard-network-guard sg) check-who host port (if client? 'client 'server))
((security-guard-network-guard sg) check-who host port mode)
(loop (security-guard-parent sg)))))