Complete refactoring for rktplayer, in order to make it play on DLNA renderers and also use UpNP media server resources.
This commit is contained in:
+248
@@ -0,0 +1,248 @@
|
||||
#lang racket/base
|
||||
|
||||
(require racket/gui
|
||||
racket/contract
|
||||
xml
|
||||
xml/xexpr
|
||||
simple-log
|
||||
)
|
||||
|
||||
(provide ww-connect
|
||||
make-delayed-reactor
|
||||
mktable
|
||||
simple-row-formatter
|
||||
while
|
||||
open-file-manager
|
||||
dbg-rktplayer
|
||||
err-rktplayer
|
||||
info-rktplayer
|
||||
warn-rktplayer
|
||||
fatal-rktplayer
|
||||
sync-log-rktplayer
|
||||
(all-from-out simple-log)
|
||||
list-drop!
|
||||
path-equal?
|
||||
make-select-list
|
||||
new-id
|
||||
check/c
|
||||
check/c*
|
||||
(all-from-out racket/contract)
|
||||
)
|
||||
|
||||
|
||||
(sl-def-log rktplayer)
|
||||
|
||||
(define-syntax check/c
|
||||
(syntax-rules ()
|
||||
((_ for-cl for-func name contract-expr)
|
||||
(unless (contract-first-order-passes? contract-expr name)
|
||||
(raise-argument-error
|
||||
(string->symbol (format "~a:~a" 'for-cl 'for-func))
|
||||
(format "~s" 'contract-expr)
|
||||
name)))
|
||||
((_ for-cl name contract-expr)
|
||||
(unless (contract-first-order-passes? contract-expr name)
|
||||
(raise-argument-error
|
||||
'for-cl
|
||||
(format "~s" 'contract-expr)
|
||||
name)))
|
||||
((_ name contract-expr)
|
||||
(unless (contract-first-order-passes? contract-expr name)
|
||||
(error
|
||||
(format "~a: expected ~a, got ~a"
|
||||
'name
|
||||
'contract-expr
|
||||
name))))))
|
||||
|
||||
(define-syntax check/c*-internal
|
||||
(syntax-rules ()
|
||||
((_ for-cl (for-func name type?))
|
||||
(check/c for-cl for-func name type?))
|
||||
((_ for-cl (name type?))
|
||||
(check/c for-cl name type?))))
|
||||
|
||||
(define-syntax check/c*-internal-func
|
||||
(syntax-rules ()
|
||||
((_ for-cl for-func (name type?))
|
||||
(check/c for-cl for-func name type?))))
|
||||
|
||||
(define-syntax check/c*
|
||||
(syntax-rules ()
|
||||
((_ (for-cl for-func) check ...)
|
||||
(begin
|
||||
(check/c*-internal-func for-cl for-func check)
|
||||
...))
|
||||
((_ for-cl check ...)
|
||||
(begin
|
||||
(check/c*-internal for-cl check)
|
||||
...))))
|
||||
|
||||
(define-syntax while
|
||||
(syntax-rules ()
|
||||
((_ cond body ...)
|
||||
(letrec ((while-f (lambda (last-result)
|
||||
(if cond
|
||||
(let ((last-result (begin
|
||||
body
|
||||
...)))
|
||||
(while-f last-result))
|
||||
last-result))))
|
||||
(while-f #f))
|
||||
)
|
||||
))
|
||||
|
||||
(define-syntax ww-connect
|
||||
(syntax-rules (this)
|
||||
((_ id method)
|
||||
(begin
|
||||
(send this bind! id 'click
|
||||
(λ (el evt data)
|
||||
(send this method)))
|
||||
(send this element id))
|
||||
)
|
||||
)
|
||||
)
|
||||
|
||||
(define (list-drop! l idx)
|
||||
(if (null? l)
|
||||
l
|
||||
(if (= idx 0)
|
||||
(cdr l)
|
||||
(cons (car l) (list-drop! (cdr l) (- idx 1))))))
|
||||
|
||||
(define (make-delayed-reactor seconds closure)
|
||||
(let* ((last-val #f)
|
||||
(last-time -1)
|
||||
(interval-ms (* seconds 1000))
|
||||
(timeout-check (λ ()
|
||||
(let ((ms (current-milliseconds)))
|
||||
(unless (= last-time -1)
|
||||
(when (> ms (+ last-time interval-ms))
|
||||
(set! last-time -1)
|
||||
(closure last-val))))))
|
||||
(timer (new timer% [notify-callback timeout-check] [interval 100]))
|
||||
)
|
||||
(λ (val)
|
||||
(dbg-rktplayer "delayed reactor: ~a" val)
|
||||
(set! last-val val)
|
||||
(set! last-time (current-milliseconds))
|
||||
)))
|
||||
|
||||
|
||||
(define (simple-row-formatter row)
|
||||
(map (λ (e) (list 'td (format "~a" e))) row))
|
||||
|
||||
(define (mktable l table-class row-formatter)
|
||||
(xexpr->string
|
||||
(append
|
||||
(list 'table (list (list 'class (format "~a" table-class))))
|
||||
(map (λ (row)
|
||||
(let ((row-id (car row)))
|
||||
(append (list 'tr (list (list 'id (format "~a" row-id))))
|
||||
(row-formatter (cdr row)))))
|
||||
l)
|
||||
; Add one empty tr
|
||||
(list (list 'tr (list (list 'class "unresponsive"))))
|
||||
)
|
||||
)
|
||||
)
|
||||
|
||||
(define (open-file-manager path*)
|
||||
(let* ((path (normal-case-path path*))
|
||||
(folder (if (path? path) (path->string path) path))
|
||||
(do-open (λ (prg arg)
|
||||
(let ((exe (find-executable-path prg)))
|
||||
(dbg-rktplayer "(process* ~a ~a)" exe arg)
|
||||
(process* exe arg))))
|
||||
)
|
||||
(dbg-rktplayer "open-file-manager ~a" folder)
|
||||
(case (system-type 'os)
|
||||
[(windows) (do-open "explorer.exe" folder)]
|
||||
[(macosx) (do-open "open" folder)]
|
||||
[else (do-open "xdg-open" folder)]))
|
||||
)
|
||||
|
||||
(define (path-equal? p1 p2)
|
||||
(let ((p1* (build-path p1))
|
||||
(p2* (build-path p2))
|
||||
)
|
||||
(let ((e1 (explode-path (normal-case-path p1)))
|
||||
(e2 (explode-path (normal-case-path p2))))
|
||||
(if (= (length e1) (length e2))
|
||||
(letrec ((f (λ (l1 l2)
|
||||
(if (null? l1)
|
||||
#t
|
||||
(if (string=? (format "~a" (car l1)) (format "~a" (car l2)))
|
||||
(f (cdr l1) (cdr l2))
|
||||
#f)))))
|
||||
(f e1 e2))
|
||||
#f)
|
||||
)
|
||||
)
|
||||
)
|
||||
|
||||
(define (make-select-list id items selected)
|
||||
(let ((slct (list 'select (list (list 'id (format "~a" id))))))
|
||||
(for-each
|
||||
(λ (item)
|
||||
(let ((value (car item))
|
||||
(label (cadr item)))
|
||||
(set! slct
|
||||
(append slct
|
||||
(list
|
||||
(if (equal? value selected)
|
||||
(list 'option
|
||||
(list (list 'value (format "~a" value)) (list 'selected "selected"))
|
||||
label)
|
||||
(list 'option
|
||||
(list (list 'value (format "~a" value)))
|
||||
label))))))
|
||||
)
|
||||
items)
|
||||
slct))
|
||||
|
||||
|
||||
(define (new-id)
|
||||
(let* ((s (current-milliseconds))
|
||||
(r (random 1000000))
|
||||
(id (string->symbol (format "id-~a-~a" s r))))
|
||||
id))
|
||||
|
||||
(module+ test
|
||||
(require rackunit)
|
||||
|
||||
(define (multiply a b c)
|
||||
(check/c* (my-class multiply)
|
||||
(a number?)
|
||||
(b number?)
|
||||
(c symbol?))
|
||||
(format "symbol ~a = ~a" c (* a b)))
|
||||
|
||||
(check-equal? (multiply 2 3 'answer)
|
||||
"symbol answer = 6")
|
||||
|
||||
(check-not-exn
|
||||
(lambda ()
|
||||
(define value 1)
|
||||
(check/c my-class value number?)))
|
||||
|
||||
(check-exn
|
||||
exn:fail:contract?
|
||||
(lambda ()
|
||||
(multiply 2 "3" 'answer)))
|
||||
|
||||
(check-exn
|
||||
#rx"my-class:multiply"
|
||||
(lambda ()
|
||||
(multiply 2 3 "answer")))
|
||||
|
||||
(check-not-exn
|
||||
(lambda ()
|
||||
(define value "root")
|
||||
(check/c value (or/c path? string?))))
|
||||
|
||||
(check-exn
|
||||
#rx"or/c"
|
||||
(lambda ()
|
||||
(define value 42)
|
||||
(check/c my-class value (or/c path? string?)))))
|
||||
Reference in New Issue
Block a user