.
original commit: 5a8d8a19c2846c95338cd979f3e2db27b338afe2
This commit is contained in:
Matthew Flatt
parent
24a6d79f0e
commit
61a3a41fcd
|
|
@ -5938,11 +5938,18 @@
|
|||
(define user-custodian (make-custodian))
|
||||
|
||||
(define user-output-port
|
||||
(let ([lock (make-semaphore 1)])
|
||||
(let ([leftover #""]
|
||||
[cvt (bytes-open-converter "UTF-8-permissive" "UTF-8")])
|
||||
(make-custom-output-port
|
||||
#f ; always ready for a non-blocking write
|
||||
(lambda (s start end flush?)
|
||||
(queue-output (lambda () (send repl-buffer output (substring s start end))))
|
||||
(queue-output (lambda ()
|
||||
;; s might end in the middle of a UTF-8 encoding.
|
||||
;; Get a complete prefix, and save the rest.
|
||||
(let ([s (bytes-append leftover (subbytes s start end))])
|
||||
(let-values ([(res used status) (bytes-convert cvt s)])
|
||||
(send repl-buffer output (bytes->string/utf-8 res))
|
||||
(set! leftover (subbytes s used))))))
|
||||
(- end start))
|
||||
void ; no flush action
|
||||
void))) ; no close action
|
||||
|
|
@ -6402,14 +6409,14 @@
|
|||
(define last-visted-directory #f)
|
||||
|
||||
(define (files->list s)
|
||||
(let ([s (open-input-string s)])
|
||||
(let ([s (open-input-bytes s)])
|
||||
(let loop ()
|
||||
(let ([n (read s)])
|
||||
(if (eof-object? n)
|
||||
null
|
||||
(begin
|
||||
(read-char s) ; drop space
|
||||
(cons (read-string n s)
|
||||
(read-byte s) ; drop space
|
||||
(cons (read-bytes n s)
|
||||
(loop))))))))
|
||||
|
||||
(define (mk-file-selector who put? multi? dir? force-unix?)
|
||||
|
|
@ -6420,7 +6427,7 @@
|
|||
|
||||
(check-label-string/false who message)
|
||||
(check-top-level-parent/false who parent)
|
||||
(check-string/false who directory) (check-string/false who filename) (check-string/false who extension)
|
||||
(check-path/false who directory) (check-path/false who filename) (check-string/false who extension)
|
||||
(check-style who #f (cond
|
||||
[put? null]
|
||||
[dir? '(enter-packages)]
|
||||
|
|
@ -6451,18 +6458,22 @@
|
|||
;; parent:
|
||||
(and parent (mred->wx parent)))])
|
||||
(if (and multi? s)
|
||||
(files->list s)
|
||||
(map bytes->path (files->list (path->bytes s)))
|
||||
s))
|
||||
(letrec ([ok? #f]
|
||||
[typed-name #f]
|
||||
[dir (or directory last-visted-directory (current-directory))]
|
||||
[dir (or (and directory (if (string? directory)
|
||||
(string->path directory)
|
||||
directory))
|
||||
last-visted-directory
|
||||
(current-directory))]
|
||||
[f (make-object dialog% (if dir? "Select Directory" (if put? "Save" "Open")) parent 500 300)]
|
||||
[__ (when message
|
||||
(let ([p (make-object vertical-pane% f)])
|
||||
(send p stretchable-height #f)
|
||||
(make-object message% (protect& message) p)))]
|
||||
[dir-pane (instantiate horizontal-pane% (f) (stretchable-height #f))]
|
||||
[m (make-object message% (protect& dir) dir-pane)]
|
||||
[m (make-object message% (protect& (path->string dir)) dir-pane)]
|
||||
[lp (make-object horizontal-pane% f)]
|
||||
[change-dir (lambda (d) (let ([sd (send d get-string-selection)])
|
||||
(set! dir (simplify-path (build-path dir sd)))
|
||||
|
|
@ -6485,11 +6496,13 @@
|
|||
(update-ok)
|
||||
(when (eq? (send e get-event-type) 'list-box-dclick)
|
||||
(change-dir d))))]
|
||||
[dir-paths null]
|
||||
[files (make-object list-box% #f null lp (lambda (d e)
|
||||
(update-ok)
|
||||
(when (eq? (send e get-event-type) 'list-box-dclick)
|
||||
(done)))
|
||||
(if multi? '(multiple) '(single)))]
|
||||
[file-paths null]
|
||||
[do-text-name (lambda ()
|
||||
(let ([v (send dir-text get-value)])
|
||||
(if (or dir? (directory-exists? v))
|
||||
|
|
@ -6515,7 +6528,7 @@
|
|||
(set! typed-name file)
|
||||
(done))
|
||||
(begin
|
||||
(set! dir v)
|
||||
(set! dir (string->path v))
|
||||
(reset-directory)))))))]
|
||||
[dir-text (make-object text-field% #f f (lambda (t e)
|
||||
(if (eq? (send e get-event-type) 'text-field-enter)
|
||||
|
|
@ -6558,33 +6571,40 @@
|
|||
(lambda (b e)
|
||||
(send f show #f)
|
||||
(done))))]
|
||||
[path-string-locale<? (lambda (p)
|
||||
(string-locale<? (path->string p)))]
|
||||
[reset-directory (lambda ()
|
||||
(wx:begin-busy-cursor)
|
||||
(let ([dir-exists? (directory-exists? dir)])
|
||||
(send m set-label (if dir-exists?
|
||||
(send m set-label (protect&
|
||||
(if dir-exists?
|
||||
(begin
|
||||
(unless directory
|
||||
(set! last-visted-directory dir))
|
||||
(protect& dir))
|
||||
(string-append "BAD DIRECTORY: " dir)))
|
||||
(path->string dir))
|
||||
(string-append "BAD DIRECTORY: " (path->string dir)))))
|
||||
(when select-this-dir
|
||||
(send select-this-dir enable dir-exists?))
|
||||
(when create-button
|
||||
(send create-button enable (not dir-exists?))))
|
||||
(send dir-text set-value dir)
|
||||
(send dir-text set-value (path->string dir))
|
||||
(let ([l (with-handlers ([void (lambda (x) null)])
|
||||
(directory-list dir))]
|
||||
[dot? (send dot-check get-value)])
|
||||
(let-values ([(ds fs)
|
||||
(let loop ([l l][ds null][fs null])
|
||||
(cond
|
||||
[(null? l) (values (cons ".." (quicksort ds string-locale<?))
|
||||
(quicksort fs string-locale<?))]
|
||||
[(and (not dot?) (char=? (string-ref (car l) 0) #\.)) (loop (cdr l) ds fs)]
|
||||
[(null? l) (values (cons ".." (quicksort ds path-string-locale<?))
|
||||
(quicksort fs path-string-locale<?))]
|
||||
[(and (not dot?)
|
||||
(char=? (string-ref (path->string (car l)) 0) #\.))
|
||||
(loop (cdr l) ds fs)]
|
||||
[(file-exists? (build-path dir (car l))) (loop (cdr l) ds (cons (car l) fs))]
|
||||
[else (loop (cdr l) (cons (car l) ds) fs)]))])
|
||||
(send dirs set ds)
|
||||
(send files set fs)
|
||||
(set! dir-paths ds)
|
||||
(send dirs set (map path->string ds))
|
||||
(set! file-paths ds)
|
||||
(send files set (map path->string fs))
|
||||
(send dirs enable #t)
|
||||
(unless dir?
|
||||
(send files enable #t))
|
||||
|
|
@ -6596,13 +6616,16 @@
|
|||
(let ([mk (lambda (f) (simplify-path (build-path dir f)))])
|
||||
(let ([l (map mk (if typed-name
|
||||
(list typed-name)
|
||||
(map (lambda (p) (send (if dir? dirs files) get-string p))
|
||||
(map (lambda (p) (list-ref (if dir? dir-paths file-paths) p))
|
||||
(send (if dir? dirs files) get-selections))))])
|
||||
(if multi? l (car l))))))]
|
||||
[done (lambda ()
|
||||
(let ([name (get-filename)])
|
||||
(unless (and put? (file-exists? name)
|
||||
(eq? (message-box "Warning" (format "Replace ~s?" name) f '(yes-no)) 'no)
|
||||
(eq? (message-box "Warning"
|
||||
(format "Replace ~s?" (path->string name) )
|
||||
f '(yes-no))
|
||||
'no)
|
||||
(set! typed-name #f))
|
||||
(set! ok? #t)
|
||||
(send f show #f))))])
|
||||
|
|
@ -6610,8 +6633,10 @@
|
|||
(send m stretchable-width #t)
|
||||
(reset-directory)
|
||||
(when filename
|
||||
(when (string? filename)
|
||||
(set! filename (string->path filename)))
|
||||
(let ([d (send dir-text get-value)])
|
||||
(send dir-text set-value (build-path d filename))
|
||||
(send dir-text set-value (path->string (build-path d filename)))
|
||||
(set! typed-name filename)
|
||||
(send ok-button enable #t)))
|
||||
(when put?
|
||||
|
|
@ -6746,15 +6771,19 @@
|
|||
[p (make-object horizontal-pane% f)]
|
||||
[face (make-object list-box% #f
|
||||
(let ([l (wx:get-face-list)]
|
||||
[re:ugly-start #rx"^[^a-zA-Z0-9\200-\377]"])
|
||||
[ugly? (lambda (a)
|
||||
(and (positive? (string-length a))
|
||||
(not (or (char-alphabetic? (string-ref a 0))
|
||||
(char-numeric? (string-ref a 0))
|
||||
(char=? #\- (string-ref a))))))])
|
||||
;; Sort space-starting first (for Xft), and
|
||||
;; otherwise push names that start with an
|
||||
;; ASCII non-letterdigit to the end
|
||||
;; ASCII non-letter/digit/hyphen to the end
|
||||
(quicksort l (lambda (a b)
|
||||
(let ([a-sp? (char=? #\space (string-ref a 0))]
|
||||
[b-sp? (char=? #\space (string-ref b 0))]
|
||||
[a-ugly? (and (regexp-match re:ugly-start a) #t)]
|
||||
[b-ugly? (and (regexp-match re:ugly-start b) #t)])
|
||||
[a-ugly? (ugly? a)]
|
||||
[b-ugly? (ugly? b)])
|
||||
(cond
|
||||
[(eq? a-sp? b-sp?)
|
||||
(cond
|
||||
|
|
@ -7121,7 +7150,7 @@
|
|||
|
||||
(define (label-string? s)
|
||||
(and (string? s)
|
||||
(let ([l (string-unicode-length s)])
|
||||
(let ([l (string-length s)])
|
||||
(and l
|
||||
(<= 0 l 200)))))
|
||||
|
||||
|
|
@ -7133,6 +7162,10 @@
|
|||
(unless (or (not str) (string? str))
|
||||
(raise-type-error (who->name who) "string or #f" str)))
|
||||
|
||||
(define (check-path/false who str)
|
||||
(unless (or (not str) (path-string? str))
|
||||
(raise-type-error (who->name who) "path, string, or #f" str)))
|
||||
|
||||
(define (check-string who str)
|
||||
(unless (string? str)
|
||||
(raise-type-error (who->name who) "string" str)))
|
||||
|
|
@ -7476,7 +7509,7 @@
|
|||
(set! next? #t)
|
||||
(let ([c (min (send-generic snip get-count-generic) (- end snip-start))])
|
||||
(display (send-generic snip get-text-generic 0 c) pipe-w)
|
||||
(read-string-avail!* to-str pipe-r))]
|
||||
(read-bytes-avail!* to-str pipe-r))]
|
||||
[else
|
||||
(set! next? #f)
|
||||
0]))
|
||||
|
|
@ -7524,7 +7557,7 @@
|
|||
[port (make-custom-input-port
|
||||
(lambda (s)
|
||||
(if (char-ready? pipe-r)
|
||||
(read-string-avail!* s pipe-r)
|
||||
(read-bytes-avail!* s pipe-r)
|
||||
(parameterize ([break-enabled #f])
|
||||
(if (semaphore-try-wait? lock-semaphore)
|
||||
;; If there's an error here, the
|
||||
|
|
@ -7552,10 +7585,8 @@
|
|||
[(text) (open-input-text-editor text 0 'end)]))
|
||||
|
||||
(define (text-editor-load-handler filename expected-module)
|
||||
(unless (and (string? filename)
|
||||
(or (relative-path? filename)
|
||||
(absolute-path? filename)))
|
||||
(raise-type-error 'text-editor-load-handler "path string" filename))
|
||||
(unless (path? filename)
|
||||
(raise-type-error 'text-editor-load-handler "path" filename))
|
||||
(let-values ([(in-port src) (build-input-port filename)])
|
||||
(dynamic-wind
|
||||
(lambda () (void))
|
||||
|
|
@ -7592,7 +7623,7 @@
|
|||
(let ([p (open-input-file filename)])
|
||||
(port-count-lines! p)
|
||||
(let ([p (cond
|
||||
[(regexp-match-peek #rx"^WXME01[0-9][0-9] ## " p)
|
||||
[(regexp-match-peek #rx#"^WXME01[0-9][0-9] ## " p)
|
||||
(let ([t (make-object text%)])
|
||||
(send t insert-file p 'standard)
|
||||
(close-input-port p)
|
||||
|
|
@ -7707,10 +7738,10 @@
|
|||
editor-snip-editor-admin<%>
|
||||
editor-stream-in%
|
||||
editor-stream-in-base%
|
||||
editor-stream-in-string-base%
|
||||
editor-stream-in-bytes-base%
|
||||
editor-stream-out%
|
||||
editor-stream-out-base%
|
||||
editor-stream-out-string-base%
|
||||
editor-stream-out-bytes-base%
|
||||
editor-wordbreak-map%
|
||||
mouse-event%
|
||||
mult-color<%>
|
||||
|
|
|
|||
|
|
@ -609,7 +609,6 @@
|
|||
(define-function end-busy-cursor)
|
||||
(define-function is-busy?)
|
||||
(define-function begin-busy-cursor)
|
||||
(define-function make-meta-file-placeable)
|
||||
(define-function get-display-depth)
|
||||
(define-function is-color-display?)
|
||||
(define-function file-selector)
|
||||
|
|
@ -767,7 +766,6 @@
|
|||
write-to-file
|
||||
read-from-file
|
||||
get-character
|
||||
get-unicode
|
||||
get-text
|
||||
get-snip-position
|
||||
get-snip-position-and-location
|
||||
|
|
@ -905,8 +903,8 @@
|
|||
bad?
|
||||
seek
|
||||
tell)
|
||||
(define-class editor-stream-in-string-base% editor-stream-in-base% #f)
|
||||
(define-class editor-stream-out-string-base% editor-stream-out-base% #f
|
||||
(define-class editor-stream-in-bytes-base% editor-stream-in-base% #f)
|
||||
(define-class editor-stream-out-bytes-base% editor-stream-out-base% #f
|
||||
get-string)
|
||||
(define-class editor-stream-in% object% #f
|
||||
ok?
|
||||
|
|
@ -915,17 +913,15 @@
|
|||
skip
|
||||
remove-boundary
|
||||
set-boundary
|
||||
>>
|
||||
get-inexact
|
||||
get-exact
|
||||
get-fixed
|
||||
get-string
|
||||
get-bytes
|
||||
get)
|
||||
(define-class editor-stream-out% object% #f
|
||||
ok?
|
||||
jump-to
|
||||
tell
|
||||
<<
|
||||
put-fixed
|
||||
put)
|
||||
(define-class timer% object% ()
|
||||
|
|
@ -937,8 +933,8 @@
|
|||
get-clipboard-bitmap
|
||||
set-clipboard-bitmap
|
||||
get-clipboard-data
|
||||
get-clipboard-string
|
||||
set-clipboard-string
|
||||
get-clipboard-bytes
|
||||
set-clipboard-bytes
|
||||
set-clipboard-client)
|
||||
(define-function get-the-clipboard)
|
||||
(define-class clipboard-client% object% ()
|
||||
|
|
@ -1156,6 +1152,7 @@
|
|||
on-event
|
||||
size-cache-invalid
|
||||
copy
|
||||
get-text!
|
||||
get-text
|
||||
merge-with
|
||||
split
|
||||
|
|
@ -1193,6 +1190,7 @@
|
|||
on-event
|
||||
size-cache-invalid
|
||||
copy
|
||||
get-text!
|
||||
get-text
|
||||
merge-with
|
||||
split
|
||||
|
|
@ -1217,6 +1215,7 @@
|
|||
on-event
|
||||
size-cache-invalid
|
||||
copy
|
||||
get-text!
|
||||
get-text
|
||||
merge-with
|
||||
split
|
||||
|
|
@ -1248,6 +1247,7 @@
|
|||
on-event
|
||||
size-cache-invalid
|
||||
copy
|
||||
get-text!
|
||||
get-text
|
||||
merge-with
|
||||
split
|
||||
|
|
@ -1290,6 +1290,7 @@
|
|||
on-event
|
||||
size-cache-invalid
|
||||
copy
|
||||
get-text!
|
||||
get-text
|
||||
merge-with
|
||||
split
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user