101 lines
2.7 KiB
Scheme
101 lines
2.7 KiB
Scheme
(module misc mzscheme
|
|
(require (lib "class.ss")
|
|
(lib "file.ss")
|
|
(lib "process.ss")
|
|
(prefix wx: "kernel.ss"))
|
|
|
|
(provide file-creator-and-type
|
|
hide-cursor-until-moved
|
|
sleep/yield
|
|
play-sound
|
|
timer%)
|
|
|
|
;; Currently only used for PS print and preview
|
|
(wx:set-executer
|
|
(let ([orig-err (current-error-port)])
|
|
(lambda (prog . args)
|
|
(let ([cmd (string-append
|
|
prog
|
|
(let loop ([args args])
|
|
(if (null? args)
|
|
""
|
|
(format " ~s~a" (car args) (loop (cdr args))))))])
|
|
(let-values ([(in out pid err x) (apply values (process cmd))])
|
|
(close-output-port out)
|
|
(let ([echo (lambda (p)
|
|
(thread (lambda ()
|
|
(dynamic-wind
|
|
void
|
|
(lambda ()
|
|
(let loop ()
|
|
(let ([l (read-line p)])
|
|
(unless (eof-object? l)
|
|
(fprintf orig-err "~a~n" l)
|
|
(loop)))))
|
|
(lambda () (close-input-port p))))))])
|
|
(echo in)
|
|
(echo err)
|
|
(void)))))))
|
|
|
|
(define (sleep/yield secs)
|
|
(unless (and (real? secs) (not (negative? secs)))
|
|
(raise-type-error 'sleep/yield "non-negative real number" secs))
|
|
(wx:yield (alarm-evt (+ (current-inexact-milliseconds)
|
|
(* secs 1000))))
|
|
(void))
|
|
|
|
(define file-creator-and-type
|
|
(case-lambda
|
|
[(fn) (wx:file-creator-and-type fn)]
|
|
[(fn c t) (wx:file-creator-and-type fn c t)]))
|
|
|
|
(define (hide-cursor-until-moved)
|
|
(wx:hide-cursor))
|
|
|
|
(define (play-sound f async?)
|
|
(if (not (eq? (system-type) 'unix))
|
|
(wx:play-sound f async?)
|
|
(begin
|
|
(unless (string? f)
|
|
(raise-type-error 'play-sound "string" f))
|
|
(let* ([subpath (system-library-subpath)]
|
|
[make-pattern (lambda (s) (string-append ".*" s ".*"))]
|
|
[b (box
|
|
(cond
|
|
[(regexp-match (make-pattern "linux") subpath)
|
|
;; use play interface to sox
|
|
"play ~s"]
|
|
[(regexp-match (make-pattern "solaris") subpath)
|
|
"audioplay ~s"]
|
|
[else
|
|
(raise-mismatch-error
|
|
'play-sound
|
|
"not supported by default on this platform"
|
|
subpath)]))])
|
|
; see if user has overridden defaults
|
|
(let ([r (get-preference '|MrEd:playcmd| (lambda () #f))])
|
|
(when (and r (string? r))
|
|
(set-box! b r)))
|
|
((if async? (lambda (x) (process x) #t) system)
|
|
(format (unbox b) (expand-path f)))))))
|
|
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Timers:
|
|
|
|
(define timer%
|
|
(class wx:timer%
|
|
(init [notify-callback void]
|
|
[interval #f]
|
|
[just-once? #f])
|
|
|
|
(inherit start)
|
|
|
|
(define -notify-callback notify-callback)
|
|
|
|
(define/override (notify) (-notify-callback))
|
|
|
|
(super-make-object)
|
|
|
|
(when interval
|
|
(start interval just-once?)))))
|