@@ -193,19 +193,15 @@
|
||||
(super-new)
|
||||
|
||||
(begin
|
||||
(displayln (format "win-id: ~a, id: ~a" (send this get-win-id) (send this get-id)))
|
||||
(inp-set! val (ww-get-value (send this get-win-id)
|
||||
(send this get-id)))
|
||||
(displayln (format "got value '~a'" val))
|
||||
(send this connect 'input (λ (data)
|
||||
(ww-debug data)
|
||||
(let ((js-evt (hash-ref data 'js-evt #f)))
|
||||
(unless (eq? js-evt #f)
|
||||
(when (hash-has-key? js-evt 'value)
|
||||
(inp-set! val (hash-ref js-evt 'value)))))))
|
||||
(displayln "connected")
|
||||
(send (send this win) bind 'input (format "#~a" (send this get-id)))
|
||||
(displayln "bind of input?")
|
||||
)
|
||||
))
|
||||
|
||||
@@ -392,7 +388,6 @@
|
||||
(ww-debug (format "call to bind ~a ~a ~a" event selector forced-cl))
|
||||
(let ((infos (ww-bind win-id event selector)))
|
||||
(for-each (λ (info)
|
||||
(displayln (format "info = ~a" info))
|
||||
(let* ((id (car info))
|
||||
(tag (cadr info))
|
||||
(type (caddr info)))
|
||||
@@ -548,18 +543,11 @@
|
||||
|
||||
(define/public (choose-dir caption base-dir)
|
||||
(let ((r (ww-choose-dir win-id caption base-dir)))
|
||||
(if (eq? (car r) #f)
|
||||
(ww-debug (format "choose-dir: ~a" r))
|
||||
(if (eq? r 'cmd-nok)
|
||||
#f
|
||||
(let ((m (regexp-match re-choose-dir (cdr r))))
|
||||
(if (eq? m #f)
|
||||
#f
|
||||
(let ((dir (caddr m)))
|
||||
(ww-from-string dir))
|
||||
)
|
||||
)
|
||||
)
|
||||
)
|
||||
)
|
||||
r)))
|
||||
|
||||
|
||||
; Supers first
|
||||
(super-new)
|
||||
|
||||
@@ -9,7 +9,7 @@
|
||||
"../utils/utils.rkt"
|
||||
"css.rkt"
|
||||
"menu.rkt"
|
||||
;"webui-wire-ffi.rkt"
|
||||
"webui-wire-ffi.rkt"
|
||||
"webui-wire-ipc.rkt"
|
||||
"webui-wire-download.rkt"
|
||||
)
|
||||
@@ -21,6 +21,8 @@
|
||||
ww-debug
|
||||
ww-error
|
||||
ww-display-log
|
||||
ww-tail-log
|
||||
ww-set-log-lines!
|
||||
|
||||
ww-cmd
|
||||
ww-cmd-nok?
|
||||
@@ -113,21 +115,21 @@
|
||||
;; web-wire handling (interaction with the library)
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define _ww-debug #f)
|
||||
(define _ww-debug #t)
|
||||
|
||||
(define (ww-set-debug yn) (set! _ww-debug yn))
|
||||
|
||||
(define (do-debug str . var)
|
||||
(when _ww-debug
|
||||
(if (null? var)
|
||||
(displayln (format "Debug: ~a" str))
|
||||
(displayln (format "Debug: ~a: ~a" (car var) str))
|
||||
(process-log 'WW-DEBUG (format "~a" str))
|
||||
(process-log 'WW-DEBUG (format "~a: ~a" (car var) str))
|
||||
)))
|
||||
|
||||
(define (err str . var)
|
||||
(if (null? var)
|
||||
(displayln (format "Error: ~a" str))
|
||||
(displayln (format "Error: ~a: ~a" var str))
|
||||
(process-log 'WW-ERROR (format "~a" str))
|
||||
(process-log 'WW-ERROR (format "~a: ~a" var str))
|
||||
))
|
||||
|
||||
(define-syntax debug
|
||||
@@ -155,7 +157,6 @@
|
||||
))
|
||||
|
||||
(define re-kind #px"([A-Z]+)[(]([0-9]+)[)][:]")
|
||||
;(define re-event #px"([^:]+)[:]([0-9]+)([:](.*))?")
|
||||
(define re-js-event #px"^([^:]+)([:](.*))?")
|
||||
(define re-js-result #px"([0-9]+)[:]([^:]+)[:](.*)")
|
||||
(define re-js-handle #px"([^:]+)[:]([0-9]+)[:]([0-9]+)([:](.*))?")
|
||||
@@ -171,6 +172,7 @@
|
||||
[event-thread #:mutable]
|
||||
[stop-thread #:mutable]
|
||||
[reader-thread #:mutable]
|
||||
[type #:mutable]
|
||||
)
|
||||
)
|
||||
|
||||
@@ -179,18 +181,27 @@
|
||||
(define evt-sem (make-semaphore))
|
||||
(define evt-fifo (make-queue))
|
||||
(define log-fifo (make-queue))
|
||||
(define log-fifo-max 100)
|
||||
(define log-fifo-max 2500)
|
||||
|
||||
(define (ww-set-log-lines! n)
|
||||
(set! log-fifo-max (if (< n 10) 10
|
||||
(if (> n 10000) 10000 n)))
|
||||
(ensure-fifo)
|
||||
)
|
||||
|
||||
(define re-event #px"^([^:]+)([:]([^:]+))?")
|
||||
|
||||
|
||||
(define (event-queuer evt)
|
||||
(define (event-queuer-ipc evt)
|
||||
(enqueue! evt-fifo evt)
|
||||
(semaphore-post evt-sem))
|
||||
|
||||
(define (process-event h evt*)
|
||||
(let* ((evt evt*) ;(bytes->string/utf-8 evt*))
|
||||
(m (regexp-match re-event evt)))
|
||||
(define (event-queuer-ffi evt)
|
||||
(let ((evt* (bytes->string/utf-8 evt)))
|
||||
(enqueue! evt-fifo evt*)
|
||||
(semaphore-post evt-sem)))
|
||||
|
||||
(define (process-event h evt)
|
||||
(let* ((m (regexp-match re-event evt)))
|
||||
(ww-debug evt)
|
||||
(let* ((e (string->symbol (string-downcase (list-ref m 1))))
|
||||
(win-id (if (eq? (list-ref m 3) #f) #f (string->number (list-ref m 3))))
|
||||
@@ -203,7 +214,6 @@
|
||||
(if (eq? evt-handler #f)
|
||||
(ww-error (format "no event handler to handle event ~a" evt))
|
||||
(queue-callback (lambda () (evt-handler e payload))))
|
||||
; (evt-handler e payload))
|
||||
)
|
||||
)
|
||||
)
|
||||
@@ -220,48 +230,136 @@
|
||||
(f))))))
|
||||
|
||||
|
||||
(define (process-log kind* msg*)
|
||||
(define (ensure-fifo)
|
||||
(if (> (queue-length log-fifo) log-fifo-max)
|
||||
(begin
|
||||
(dequeue! log-fifo)
|
||||
(ensure-fifo))
|
||||
(queue-length log-fifo)))
|
||||
(let ((kind kind*) ;(bytes->string/utf-8 kind*))
|
||||
(msg msg*)) ;(bytes->string/utf-8 msg*)))
|
||||
|
||||
(define tail-handler #f)
|
||||
|
||||
(define (put-in-fifo kind msg)
|
||||
(enqueue! log-fifo (cons kind msg))
|
||||
(when tail-handler
|
||||
(tail-handler kind msg))
|
||||
)
|
||||
|
||||
(define (process-log-ipc kind msg)
|
||||
(put-in-fifo kind msg)
|
||||
(ensure-fifo))
|
||||
|
||||
(define process-log process-log-ipc)
|
||||
|
||||
(define (process-log-ffi kind* msg*)
|
||||
(let ((kind (bytes->string/utf-8 kind*))
|
||||
(msg (bytes->string/utf-8 msg*)))
|
||||
(put-in-fifo kind msg)
|
||||
(ensure-fifo)))
|
||||
|
||||
(define (ww-display-log)
|
||||
(define (ww-do-display item filter)
|
||||
(let ((displ #f))
|
||||
(when (eq? filter #f)
|
||||
(set! displ #t))
|
||||
(when (symbol? filter)
|
||||
(set! displ (eq? (car item) filter)))
|
||||
(when (regexp? filter)
|
||||
(when (or (regexp-match filter (cdr item))
|
||||
(regexp-match filter (symbol->string (car item))))
|
||||
(set! displ #t)))
|
||||
(when displ
|
||||
(displayln (format "~a - ~a" (car item) (cdr item)))))
|
||||
)
|
||||
|
||||
(define (ww-display-log . filter*)
|
||||
(let ((filter (if (null? filter*) #f (car filter*))))
|
||||
(when (string? filter)
|
||||
(set! filter (pregexp (string-append "(?i:" filter ")"))))
|
||||
(when (list? filter)
|
||||
(set! filter (pregexp (string-append "(?i:(" (string-join filter "|") "))"))))
|
||||
(for-each (λ (item)
|
||||
(displayln (format "~a - ~a" (car item) (cdr item))))
|
||||
(ww-do-display item filter))
|
||||
(queue->list log-fifo)))
|
||||
)
|
||||
|
||||
(define (ww-tail-log . args)
|
||||
(let ((last-n 3)
|
||||
(filter #f)
|
||||
(stop-tail #f)
|
||||
)
|
||||
(let ((f (λ ()
|
||||
(let ((arg (if (null? args) #f (car args))))
|
||||
(unless (null? args)
|
||||
(when (boolean? arg)
|
||||
(when (eq? arg #f)
|
||||
(set! stop-tail #t)))
|
||||
(when (number? arg)
|
||||
(set! last-n (if (< arg 0) 0 arg)))
|
||||
(when (or (symbol? arg) (regexp? arg) (string? arg) (list? arg))
|
||||
(set! filter arg)))
|
||||
(set! args (if (null? args) '() (cdr args)))))))
|
||||
(f)(f))
|
||||
(ww-debug (format "tail log: ~a ~a ~a" last-n filter stop-tail))
|
||||
(if stop-tail
|
||||
(set! tail-handler #f)
|
||||
(let* ((l (queue->list log-fifo))
|
||||
(len (length l)))
|
||||
(let ((nl (take-right l (if (<= last-n len) last-n len))))
|
||||
(when (string? filter)
|
||||
(set! filter (pregexp (string-append "(?i:" filter ")"))))
|
||||
(when (list? filter)
|
||||
(set! filter (pregexp (string-append "(?i:(" (string-join filter "|") "))"))))
|
||||
(for-each (λ (item)
|
||||
(ww-do-display item filter))
|
||||
nl))
|
||||
(set! tail-handler (λ (kind msg)
|
||||
(ww-do-display (cons kind msg) filter))))
|
||||
)
|
||||
)
|
||||
)
|
||||
|
||||
(define (ww-start . args)
|
||||
(define (ww-start* type args)
|
||||
(when (eq? ww-current-handle #f)
|
||||
(let* ((h (make-web-rkt (webui-ipc event-queuer process-log)
|
||||
(let ((h (make-web-rkt (if (eq? type 'ipc)
|
||||
(webui-ipc event-queuer-ipc process-log-ipc)
|
||||
(let ((existing-h (webwire-current)))
|
||||
(if (eq? existing-h #f)
|
||||
(webwire-new)
|
||||
existing-h)))
|
||||
#f
|
||||
#f
|
||||
#f))
|
||||
(thrd (event-handler h)))
|
||||
#f
|
||||
type)))
|
||||
(when (eq? type 'ffi)
|
||||
(unless (eq? (webwire-status (web-rkt-handle h)) 'valid)
|
||||
(error (format "Invalid handle, cannot start webui-wire ffi, reason: ~a"
|
||||
(webwire-status->string (webwire-status (web-rkt-handle h)))))))
|
||||
(let ((thrd (event-handler h)))
|
||||
(when (eq? type 'ffi)
|
||||
(webwire-handlers! (web-rkt-handle h) event-queuer-ffi process-log-ffi))
|
||||
(set-web-rkt-event-thread! h thrd)
|
||||
(set! ww-current-handle h)))
|
||||
(set! ww-current-handle h))
|
||||
))
|
||||
(unless (null? args)
|
||||
(ww-log-level (car args)))
|
||||
ww-current-handle)
|
||||
|
||||
(define (ww-start . args)
|
||||
(ww-start* 'ipc args))
|
||||
|
||||
(define (ww-stop)
|
||||
(unless (eq? ww-current-handle #f)
|
||||
(let ((thr (web-rkt-event-thread ww-current-handle)))
|
||||
(kill-thread thr))
|
||||
;; inform event handlers of destroying of windows.
|
||||
(let ((keys (hash-keys windows-evt-handlers)))
|
||||
(for-each (λ (win-id)
|
||||
(let ((handler (hash-ref windows-evt-handlers win-id)))
|
||||
(handler 'destroyed #f)))
|
||||
keys))
|
||||
((web-rkt-handle ww-current-handle) "exit")
|
||||
(ww-cmd "exit")
|
||||
(let ((thr (web-rkt-event-thread ww-current-handle)))
|
||||
(kill-thread thr))
|
||||
(when (eq? (web-rkt-type ww-current-handle) 'ffi)
|
||||
(webwire-destroy (web-rkt-handle ww-current-handle)))
|
||||
(set! ww-current-handle #f)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
@@ -328,7 +426,11 @@
|
||||
(begin
|
||||
(ww-stop)
|
||||
#t)
|
||||
(let ((result ((web-rkt-handle ww-current-handle) cmd)))
|
||||
(let* ((type (web-rkt-type ww-current-handle))
|
||||
(result (if (eq? type 'ipc)
|
||||
((web-rkt-handle ww-current-handle) cmd)
|
||||
(webwire-command (web-rkt-handle ww-current-handle) cmd)))
|
||||
)
|
||||
(let ((r (convert-result result)))
|
||||
(check-nok cmd r)
|
||||
r))))
|
||||
@@ -877,26 +979,49 @@
|
||||
-> symbol)
|
||||
|
||||
;; Files and directories
|
||||
(define (ww-file-open win-id title dir file-filters)
|
||||
(let ((cmd (format "file-open ~a ~a ~a ~a" win-id
|
||||
(as-string title)
|
||||
(as-string dir)
|
||||
(as-string file-filters))))
|
||||
(ww-cmd cmd)))
|
||||
;(define (ww-file-open win-id title dir file-filters)
|
||||
; (let ((cmd (format "file-open ~a ~a ~a ~a" win-id
|
||||
; (as-string title)
|
||||
; (as-string dir)
|
||||
; (as-string file-filters))))
|
||||
; (ww-cmd cmd)))
|
||||
|
||||
(define (ww-file-save win-id title dir file-filters overwrite)
|
||||
(let ((cmd (format "file-save ~a ~a ~a ~a ~a" win-id
|
||||
(as-string title)
|
||||
(as-string dir)
|
||||
(as-string file-filters)
|
||||
(if overwrite 1 0))))
|
||||
(ww-cmd cmd)))
|
||||
(def-cmd ww-file-open
|
||||
file-open ((win-id ww-win?)
|
||||
(caption string?)
|
||||
(dir string?)
|
||||
(file-filters string?)) ()
|
||||
-> string)
|
||||
|
||||
(define (ww-choose-dir win-id title dir)
|
||||
(let ((cmd (format "choose-dir ~a ~a ~a" win-id
|
||||
(as-string title)
|
||||
(as-string dir))))
|
||||
(ww-cmd cmd)))
|
||||
(def-cmd ww-file-save
|
||||
file-save ((win-id ww-win?)
|
||||
(caption string?)
|
||||
(dir string?)
|
||||
(file-filters string?)
|
||||
(overwrite boolean?)
|
||||
) ()
|
||||
-> string)
|
||||
|
||||
;(define (ww-file-save win-id title dir file-filters overwrite)
|
||||
; (let ((cmd (format "file-save ~a ~a ~a ~a ~a" win-id
|
||||
; (as-string title)
|
||||
; (as-string dir)
|
||||
; (as-string file-filters)
|
||||
; (if overwrite 1 0))))
|
||||
; (ww-cmd cmd)))
|
||||
|
||||
(def-cmd ww-choose-dir
|
||||
choose-dir ((win-id ww-win?)
|
||||
(caption string?)
|
||||
(dir string?)
|
||||
) ()
|
||||
-> string)
|
||||
|
||||
;(define (ww-choose-dir win-id title dir)
|
||||
; (let ((cmd (format "choose-dir ~a ~a ~a" win-id
|
||||
; (as-string title)
|
||||
; (as-string dir))))
|
||||
; (ww-cmd cmd)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Finalizing stuff
|
||||
|
||||
@@ -14,9 +14,11 @@
|
||||
ww-webui-wire
|
||||
)
|
||||
|
||||
;(define (current-release os)
|
||||
|
||||
(define (ww-webui-wire)
|
||||
"/home/hans/src/racket/webui-wire/build/Debug/webui-wire"
|
||||
(list "/home/hans/src/racket/webui-wire/build/Release/webui-wire")
|
||||
;(list "/usr/bin/flatpak" "run" "nl.dijkewijk.webui-wire")
|
||||
)
|
||||
|
||||
(define ww-current-win-release "https://github.com/hdijkema/web-wire/releases/download/0.1/web-wire-0.1-win64.zip")
|
||||
|
||||
@@ -73,21 +73,26 @@
|
||||
(will-register webwire-will
|
||||
handle (λ (handle)
|
||||
(webwire-destroy handle))))
|
||||
(start-gui-processing)
|
||||
handle))
|
||||
#:c-id webwire_new)
|
||||
|
||||
|
||||
(define-libwebui-wire webwire-current
|
||||
(_fun -> (handle : _webui-handle/null)
|
||||
-> (begin
|
||||
(unless (eq? handle #f)
|
||||
(will-register webwire-will
|
||||
handle (λ (handle)
|
||||
(webwire-destroy handle))))
|
||||
(webwire-destroy handle)))
|
||||
(start-gui-processing)
|
||||
)
|
||||
handle))
|
||||
#:c-id webwire_current)
|
||||
|
||||
(define-libwebui-wire webwire-destroy
|
||||
(_fun _webui-handle/null -> _void)
|
||||
(_fun _webui-handle/null -> _void
|
||||
-> (stop-gui-processing))
|
||||
#:c-id webwire_destroy)
|
||||
|
||||
(define-libwebui-wire webwire-command
|
||||
@@ -149,7 +154,7 @@
|
||||
#:c-id webwire_status_string)
|
||||
|
||||
(define-libwebui-wire webwire-process-gui
|
||||
(_fun _webui-handle/null -> _void)
|
||||
(_fun _webui-handle/null -> _bool)
|
||||
#:c-id webwire_process_gui)
|
||||
|
||||
|
||||
@@ -263,13 +268,32 @@
|
||||
|
||||
|
||||
; Make sure GUI Events are processed (e.g. for linux - gtk main loop)
|
||||
(void (thread (λ ()
|
||||
(let loop ()
|
||||
|
||||
(define gui-processing-thread #f)
|
||||
(define gui-processing-go-on #f)
|
||||
|
||||
(define (start-gui-processing)
|
||||
(when (eq? gui-processing-thread #f)
|
||||
(set! gui-processing-go-on #t)
|
||||
(set! gui-processing-thread (thread (λ ()
|
||||
(begin
|
||||
(displayln "gui processing starts")
|
||||
(letrec ((loop (λ ()
|
||||
(sleep 0.05)
|
||||
(webwire-process-gui #f)
|
||||
;(displayln 'process-gui-ok)
|
||||
(loop)))
|
||||
)
|
||||
(let ((processed (webwire-process-gui #f)))
|
||||
(when (or gui-processing-go-on processed)
|
||||
(loop))))))
|
||||
(loop))
|
||||
(displayln "gui processing stops")
|
||||
(set! gui-processing-thread #f)))))
|
||||
)
|
||||
)
|
||||
|
||||
(define (stop-gui-processing)
|
||||
(void (thread (λ ()
|
||||
(display "waiting 5 seconds")
|
||||
(sleep 5)
|
||||
(displayln "stopping gui processing")
|
||||
(set! gui-processing-go-on #f)))))
|
||||
|
||||
|
||||
@@ -1,11 +1,19 @@
|
||||
(module webui-wire-ipc racket/base
|
||||
|
||||
(require "webui-wire-download.rkt")
|
||||
(require "webui-wire-download.rkt"
|
||||
racket/string
|
||||
)
|
||||
|
||||
(provide webui-ipc)
|
||||
|
||||
(define re-kind #px"^([^:]+)[:]")
|
||||
|
||||
(define (is-int? str)
|
||||
(let ((re-num #px"^[0-9]+$"))
|
||||
(if (regexp-match re-num str)
|
||||
#t
|
||||
#f)))
|
||||
|
||||
(define (read-eol port)
|
||||
(read-string 1 port))
|
||||
|
||||
@@ -19,10 +27,8 @@
|
||||
(log-processor 'stderr-reader "webui-wire executable exited")
|
||||
'process-ended)
|
||||
(begin
|
||||
(unless (and
|
||||
(string? colon)
|
||||
(string=? colon ":"))
|
||||
(error "Unexpected input from webui-wire standard error"))
|
||||
(if (and (string? colon) (string=? colon ":") (is-int? str-length))
|
||||
; process line
|
||||
(let* ((length (string->number str-length))
|
||||
(input (read-string length process-stderr))
|
||||
(m (regexp-match re-kind input))
|
||||
@@ -38,6 +44,11 @@
|
||||
(event-queuer line)
|
||||
(log-processor kind line))))
|
||||
)
|
||||
; otherwise skip line
|
||||
(let* ((line (read-line process-stderr))
|
||||
(msg (string-trim (string-append str-length colon line))))
|
||||
(log-processor 'stderr-reader msg))
|
||||
)
|
||||
(reader)
|
||||
)
|
||||
))
|
||||
@@ -48,12 +59,12 @@
|
||||
)
|
||||
|
||||
(define (webui-ipc event-queuer log-processor)
|
||||
(let ((webui-wire-exe (ww-webui-wire)))
|
||||
(displayln webui-wire-exe)
|
||||
(let* ((webui-wire-exe (ww-webui-wire))
|
||||
(proc-args (append (list #f #f #f) webui-wire-exe))
|
||||
)
|
||||
(call-with-values
|
||||
(λ () (subprocess #f #f #f webui-wire-exe))
|
||||
(λ () (apply subprocess proc-args))
|
||||
(λ (pid process-stdout process-stdin process-stderr)
|
||||
;(displayln (format "~a ~a ~a ~a" pid process-stdout process-stdin process-stderr))
|
||||
(let ((reader-thrd (process-stderr-reader process-stderr event-queuer log-processor)))
|
||||
(λ (cmd)
|
||||
(displayln cmd process-stdin)
|
||||
|
||||
Reference in New Issue
Block a user