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

Eliminated flashing shell prompt under windows.

Browse Source 
original commit: f642e5abc98afb79702a62214f039a8a6dacc9a6
This commit is contained in:
Paul Graunke 2002-04-05 17:32:36 +00:00
parent 426582117c
commit 2f956ee531
1 changed files with 71 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

78
collects/net/sendurl.ss
View File

@ -1,4 +1,3 @@
(module sendurl mzscheme (module sendurl mzscheme
(require (lib "process.ss") (require (lib "process.ss")
(lib "file.ss") (lib "file.ss")
@ -27,12 +26,10 @@
(let ([b (box "")]) (let ([b (box "")])
(unless (get-res "HKEY_CLASSES_ROOT" "htmlfile\\shell\\open\\command" b) (unless (get-res "HKEY_CLASSES_ROOT" "htmlfile\\shell\\open\\command" b)
(error 'send-url "couldn't find URL opener in the registry")) (error 'send-url "couldn't find URL opener in the registry"))
(let-values ([(out in id err status) (apply (apply
values process*/close-ports
(process (format "~a ~a" (unbox b) str)))]) (append (parse-command.com (open-input-string (unbox b)))
(close-output-port in) (list str))))
(close-input-port out)
(close-input-port err)))
(error 'send-url "don't know how to open URL in Windows without MrEd")))] (error 'send-url "don't know how to open URL in Windows without MrEd")))]
[(unix) [(unix)
(let ([preferred (get-preference 'external-browser (lambda () #f))]) (let ([preferred (get-preference 'external-browser (lambda () #f))])
@ -107,4 +104,69 @@
(apply values (apply process*/ports #f #f #f args))]) (apply values (apply process*/ports #f #f #f args))])
(close-input-port out) (close-input-port out)
(close-output-port in) (close-output-port in)
(close-input-port err))))) (close-input-port err))))
; parse-command : iport -> (listof str)
(define (parse-command.com in)
(let parse ()
(cond
[(eof-object? (skip-space-tab in)) null]
[else (cons (list->string (parse-one #t in)) (parse))])))
; parse-one : bool iport -> (listof char)
(define (parse-one unquoted in)
(let parse-1 ([unquoted unquoted])
(let ([c (read-char in)])
(cond
[(eof-object? c) null]
[(eq? c #\\) (parse-backslashes 1 unquoted in)]
[(eq? c #\") (parse-1 (not unquoted))]
[(and unquoted (or (eq? #\space c) (eq? #\tab c))) null]
[else (cons c (parse-1 unquoted))]))))
; parse-backslashes : nat bool iport -> (listof char)
(define (parse-backslashes n unquoted in)
(let more ([n n])
(let ([c (read-char in)])
(cond
[(eq? c #\\) (more (add1 n))]
[(eq? c #\")
(if (even? n)
(cons-n-backslashes (/ n 2) (parse-one (not unquoted) in))
(cons-n-backslashes (/ (sub1 n) 2) (cons #\" (parse-one unquoted in))))]
[(and unquoted (or (eq? #\space c) (eq? #\tab c))) null]
[else (cons-n-backslashes n (cons c (parse-one unquoted in)))]))))
; cons-n-backslashes : nat (listof char) -> (listof char)
(define (cons-n-backslashes n l)
(cond
[(zero? n) l]
[else (cons-n-backslashes (sub1 n) (cons #\\ l))]))
; skip-space-tab : iport -> (U char eof)
; to skip spaces and tabs
(define (skip-space-tab in)
(let loop ()
(let ([c (peek-char in)])
(cond
[(or (eq? #\space c) (eq? #\tab c))
(read-char in)
(loop)]
[else c]))))
; test-parse-command.com : -> bool
; all but one of these tests is taken from MS's documentation
; http://www.cygwin.com/ml/cygwin/1999-08/msg00701.html
(define (test-parse-command.com)
(and (equal? (parse-command.com (open-input-string "\"a b c\" d e"))
'("a b c" "d" "e"))
(equal? (parse-command.com (open-input-string "\"ab\\\"c\" \"\\\\\" d"))
'("ab\"c" "\\" "d"))
(equal? (parse-command.com (open-input-string "a\\\\\\b d\"e f\"g h"))
'("a\\\\\\b" "de fg" "h"))
(equal? (parse-command.com (open-input-string "a\\\"b c d"))
'("a\"b" "c" "d"))
(equal? (parse-command.com (open-input-string "a\\\\\\\"b c d"))
'("a\\\"b" "c" "d"))
(equal? (parse-command.com (open-input-string "a\\\\\\\\\"b c\" d e"))
'("a\\\\b c" "d" "e")))))