460 lines
15 KiB
Racket
460 lines
15 KiB
Racket
#lang racket/base
|
|
|
|
(require "racket-webview.rkt"
|
|
racket/class
|
|
simple-ini/class
|
|
"wv-element.rkt"
|
|
"wv-input.rkt"
|
|
"wv-settings.rkt"
|
|
"rgba.rkt"
|
|
net/url
|
|
net/sendurl
|
|
racket/string
|
|
)
|
|
|
|
(provide wv-window%
|
|
(all-from-out "wv-element.rkt")
|
|
(all-from-out "wv-input.rkt")
|
|
(all-from-out "rgba.rkt")
|
|
(all-from-out "wv-settings.rkt")
|
|
webview-version
|
|
root-file-not-found-handler
|
|
)
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Administration
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define default-x (let ((dx 100))
|
|
(λ ()
|
|
(set! dx (+ dx 25))
|
|
dx)))
|
|
(define default-y (let ((dy 100))
|
|
(λ ()
|
|
(set! dy (+ dy 25))
|
|
dy)))
|
|
|
|
(define default-w (λ () 800))
|
|
(define default-h (λ () 600))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Classes
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
|
|
(define wv-window%
|
|
(class object%
|
|
|
|
(init-field [parent #f]
|
|
[wv-context (if (eq? parent #f)
|
|
(error "wv context is mandatory")
|
|
(get-field wv-context parent))]
|
|
[html-path (error "html path is mandatory")]
|
|
[settings (send wv-context settings (string->symbol (format "~a" html-path)))]
|
|
[title "Racket Webview Window"]
|
|
[width #f]
|
|
[height #f]
|
|
[x #f]
|
|
[y #f]
|
|
[wv #f]
|
|
)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Administration
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define/public (context)
|
|
wv-context)
|
|
|
|
(define/public (win-context)
|
|
(string->symbol (format "~a" html-path)))
|
|
|
|
(define element-hash (make-weak-hash))
|
|
|
|
(define/public (info)
|
|
(let ((h (make-hash)))
|
|
(hash-set! h 'wv-context (context))
|
|
(hash-set! h 'wv wv)
|
|
(hash-set! h 'html-path html-path)
|
|
(hash-set! h 'elements element-hash)
|
|
h))
|
|
|
|
(define/public (element id . type*)
|
|
(let ((elem (hash-ref element-hash id #f))
|
|
(type (if (null? type*) #f (car type*))))
|
|
(when (eq? elem #f)
|
|
(when (eq? type #f)
|
|
(let ((js-type (webview-call-js wv
|
|
(format
|
|
(string-append
|
|
"{ let el = document.getElementById('~a');\n"
|
|
" let a = el.getAttribute('type');\n"
|
|
" if (a === null) {\n"
|
|
" return false;\n"
|
|
" } else {\n"
|
|
" return a;\n"
|
|
" }\n"
|
|
"}")
|
|
id))))
|
|
(set! type (if (eq? js-type #f)
|
|
#f
|
|
(string->symbol (string-downcase js-type))))
|
|
)
|
|
)
|
|
(let ((cl (cond
|
|
((eq? type 'text) wv-input/text%)
|
|
((eq? type 'date) wv-input/date%)
|
|
((eq? type 'time) wv-input/time%)
|
|
((eq? type 'datetime-local) wv-input/datetime%)
|
|
((eq? type 'range) wv-input/range%)
|
|
((eq? type 'number) wv-input/number%)
|
|
((eq? type 'checkbox) wv-input/check%)
|
|
((eq? type 'radio) wv-input/radio%)
|
|
((eq? type 'color) wv-input/color%)
|
|
(else wv-element%)
|
|
)))
|
|
(set! elem (new cl [window this] [element-id id]))
|
|
(hash-set! element-hash id elem))
|
|
)
|
|
elem
|
|
)
|
|
)
|
|
|
|
(define (connect! id type event callback)
|
|
(let ((elem (element id type)))
|
|
(send elem add-event-callback! event callback)
|
|
)
|
|
)
|
|
|
|
(define (disconnect! id event)
|
|
(let ((elem (hash-ref element-hash id #f)))
|
|
(unless (eq? elem #f)
|
|
(send elem remove-event-callback! event)
|
|
(when (= (send elem event-callback-count) 0)
|
|
(hash-remove! element-hash id))
|
|
)
|
|
)
|
|
)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Events
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define (event-handler wv evt)
|
|
(let ((event (hash-ref evt 'event 'unknown-event))
|
|
)
|
|
(cond
|
|
((eq? event 'resize)
|
|
(send this resized (hash-ref evt 'w) (hash-ref evt 'h)))
|
|
((eq? event 'move)
|
|
(send this moved (hash-ref evt 'x) (hash-ref evt 'y)))
|
|
((eq? event 'page-loaded)
|
|
(send this page-loaded (hash-ref evt 'oke)))
|
|
((or (eq? event 'show) (eq? event 'hide) (eq? event 'maximize))
|
|
(send this window-state-changed (webview-window-state wv)))
|
|
((eq? event 'can-close?)
|
|
(when (send this can-close?)
|
|
(send this close)))
|
|
((eq? event 'closed)
|
|
(send this closed))
|
|
((eq? event 'js-evt)
|
|
(let* ((je (hash-copy (hash-ref evt 'js-evt)))
|
|
(e (make-hash)))
|
|
(hash-set! e 'evt (string->symbol (hash-ref je 'evt)))
|
|
(hash-set! e 'id (string->symbol (hash-ref je 'id #f)))
|
|
(hash-set! e 'data (hash-ref je 'js_evt (make-hash)))
|
|
(hash-set! e 'event 'js-evt)
|
|
(when (eq? (send this js-event e) 'wv-unhandled-js-event)
|
|
(displayln (format "Unhandled javascript event: ~a" e)))
|
|
))
|
|
((eq? event 'navigation-request)
|
|
(let ((type (string->symbol (hash-ref evt 'type)))
|
|
(url (string->url (hash-ref evt 'url))))
|
|
(send this navigation-request type url)))
|
|
((or (eq? event 'file-save-ok)
|
|
(eq? event 'file-open-ok)
|
|
(eq? event 'choose-dir-ok))
|
|
(let ((file (hash-ref evt 'choosen))
|
|
(dir (hash-ref evt 'dir))
|
|
(filter (webview-filter->exts (hash-ref evt 'filter))))
|
|
(send this file-dialog-done 'ok file dir filter)))
|
|
((or (eq? event 'file-save-cancel)
|
|
(eq? event 'file-open-cancel)
|
|
(eq? event 'choose-dir-cancel))
|
|
(send this file-dialog-done 'canceled #f #f #f))
|
|
((or (eq? event 'msgbox-ok)
|
|
(eq? event 'msgbox-cancel)
|
|
(eq? event 'msgbox-yes)
|
|
(eq? event 'msgbox-no))
|
|
(send this message-done event))
|
|
(else
|
|
(displayln (format "Unhandled event: ~a (~a)" event evt)))
|
|
))
|
|
)
|
|
|
|
(define/public (moved xx yy)
|
|
(set! x xx)
|
|
(set! y yy)
|
|
(send settings set! 'x x)
|
|
(send settings set! 'y y)
|
|
)
|
|
|
|
(define/public (resized w h)
|
|
(set! width w)
|
|
(set! height h)
|
|
(send settings set! 'width w)
|
|
(send settings set! 'height h)
|
|
)
|
|
|
|
(define/public (window-state-changed st)
|
|
#t
|
|
)
|
|
|
|
(define/public (page-loaded oke)
|
|
#t)
|
|
|
|
(define/public (can-close?)
|
|
#t)
|
|
|
|
(define/public (closed)
|
|
#t)
|
|
|
|
(define/public (js-event js-event)
|
|
(let* ((evt (hash-ref js-event 'evt))
|
|
(id (hash-ref js-event 'id))
|
|
(el (hash-ref element-hash id #f))
|
|
)
|
|
(if (eq? el #f)
|
|
'wv-unhandled-js-event
|
|
(send el dispatch-event evt (hash-ref js-event 'data (make-hash))))
|
|
)
|
|
)
|
|
|
|
(define/public (navigation-request type url)
|
|
(let ((u (url->string url)))
|
|
(if (string-prefix? u (send wv-context base-url))
|
|
(begin
|
|
(webview-set-url! wv url)
|
|
'internal)
|
|
(begin
|
|
(send-url u)
|
|
'external)
|
|
)
|
|
)
|
|
)
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Commands
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define/public (add-class! selector-or-id cl)
|
|
(webview-add-class! wv selector-or-id cl)
|
|
this)
|
|
|
|
(define/public (remove-class! selector-or-id cl)
|
|
(webview-remove-class! wv selector-or-id cl)
|
|
this)
|
|
|
|
(define/public (devtools)
|
|
(webview-devtools wv)
|
|
this)
|
|
|
|
(define/public (move x y)
|
|
(webview-move wv x y)
|
|
this)
|
|
|
|
(define/public (resize w h)
|
|
(webview-resize wv w h)
|
|
this)
|
|
|
|
(define/public (close)
|
|
(webview-close wv)
|
|
this)
|
|
|
|
(define/public (bind! selector events callback)
|
|
(let ((items (webview-bind! wv selector events))
|
|
(events* (if (symbol? events) (list events) events)))
|
|
(map (λ (item)
|
|
(let ((id (car item))
|
|
(type (string->symbol (string-downcase (caddr item))))
|
|
)
|
|
(for-each (λ (evt)
|
|
(connect! id type evt callback))
|
|
events*)
|
|
(hash-ref element-hash id)
|
|
))
|
|
items)
|
|
)
|
|
)
|
|
|
|
(define/public (unbind! selector events)
|
|
(let ((items (webview-unbind! wv selector events))
|
|
(events* (if (symbol? events) (list events) events))
|
|
)
|
|
(for-each (λ (item)
|
|
(let ((id (car item)))
|
|
(for-each (λ (evt)
|
|
(send this disconnect! id evt))
|
|
events*)
|
|
))
|
|
items)
|
|
items
|
|
)
|
|
)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Files / Directories
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define __file_dialog_cc__ #f)
|
|
|
|
(define/public (file-dialog-done flag file dir filter)
|
|
(__file_dialog_cc__ (list flag file dir filter))
|
|
)
|
|
|
|
(define/public (choose-dir title base-dir)
|
|
(unless (eq? __file_dialog_cc__ #f)
|
|
(error "Cannot display more than one file/directory dialog"))
|
|
(let* ((bd (if (eq? base-dir #f) (find-system-path 'home-dir) base-dir))
|
|
(r (webview-choose-dir wv title bd)))
|
|
(if (eq? r 'oke)
|
|
(let ((r (call/cc (λ (c) (set! __file_dialog_cc__ c)))))
|
|
(if (void? r)
|
|
'showing
|
|
(begin
|
|
(set! __file_dialog_cc__ #f)
|
|
(if (eq? (car r ) 'ok)
|
|
(cadr r)
|
|
#f))))
|
|
#f)
|
|
)
|
|
)
|
|
|
|
(define/public (file-open title base-dir filters)
|
|
(unless (eq? __file_dialog_cc__ #f)
|
|
(error "Cannot display more than one file/directory dialog"))
|
|
(let* ((bd (if (eq? base-dir #f) (find-system-path 'home-dir) base-dir))
|
|
(r (webview-file-open wv title bd filters)))
|
|
(if (eq? r 'oke)
|
|
(let ((r (call/cc (λ (c) (set! __file_dialog_cc__ c)))))
|
|
(if (void? r)
|
|
'showing
|
|
(begin
|
|
(set! __file_dialog_cc__ #f)
|
|
(if (eq? (car r) 'ok)
|
|
(cdr r)
|
|
#f))
|
|
)
|
|
)
|
|
#f)
|
|
)
|
|
)
|
|
|
|
(define/public (file-save title base-dir filters)
|
|
(unless (eq? __file_dialog_cc__ #f)
|
|
(error "Cannot display more than one file/directory dialog"))
|
|
(let* ((bd (if (eq? base-dir #f) (find-system-path 'home-dir) base-dir))
|
|
(r (webview-file-save wv title bd filters)))
|
|
(if (eq? r 'oke)
|
|
(let ((r (call/cc (λ (c) (set! __file_dialog_cc__ c)))))
|
|
(if (void? r)
|
|
'showing
|
|
(begin
|
|
(set! __file_dialog_cc__ #f)
|
|
(if (eq? (car r) 'ok)
|
|
(cdr r)
|
|
#f))
|
|
)
|
|
)
|
|
#f)
|
|
)
|
|
)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Messagebox
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define __msg_box_cc__ #f)
|
|
|
|
(define/public (message-done evt)
|
|
(__msg_box_cc__ evt)
|
|
)
|
|
|
|
(define/public (message type title message #:sub [submessage ""])
|
|
(unless (eq? __msg_box_cc__ #f)
|
|
(error "Cannot display more than one message box"))
|
|
(let ((r (webview-messagebox wv type title message #:sub submessage)))
|
|
(if (eq? r 'oke)
|
|
(let ((r (call/cc (λ (c) (set! __msg_box_cc__ c)))))
|
|
(if (void? r)
|
|
'showing
|
|
(begin
|
|
(set! __msg_box_cc__ #f)
|
|
r)))
|
|
#f)
|
|
)
|
|
)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Construction
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define/public (init-size)
|
|
(let ((x* (send settings get 'x (if (eq? x #f) (default-x) x)))
|
|
(y* (send settings get 'y (if (eq? y #f) (default-y) y)))
|
|
(w* (send settings get 'width (if (eq? width #f) (default-w) width)))
|
|
(h* (send settings get 'height (if (eq? height #f) (default-h) height)))
|
|
)
|
|
(send this move x* y*)
|
|
(send this resize w* h*)
|
|
)
|
|
)
|
|
|
|
(super-new)
|
|
|
|
(begin
|
|
;; Create window
|
|
(write (list wv-context html-path event-handler parent))
|
|
(newline)
|
|
(set! wv (webview-create
|
|
(send wv-context context)
|
|
html-path
|
|
event-handler
|
|
#:parent (if (eq? parent #f)
|
|
#f
|
|
(get-field wv parent))))
|
|
|
|
;; Move and resize window to settings
|
|
(send this init-size)
|
|
)
|
|
)
|
|
)
|
|
|
|
|
|
|
|
(define (root-file-not-found-handler standard-file . not-found-handler)
|
|
(letrec ((handler
|
|
(λ (file base-path path)
|
|
(if (string=? file "/")
|
|
(handler standard-file base-path (build-path base-path standard-file))
|
|
(if (string=? file "/index.html")
|
|
(if (file-exists? path)
|
|
path
|
|
(handler standard-file base-path (build-path base-path standard-file)))
|
|
(if (file-exists? path)
|
|
path
|
|
(if (null? not-found-handler)
|
|
path
|
|
((car not-found-handler) file base-path path)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
))
|
|
handler)
|
|
)
|
|
|
|
|