module "/pliant/language/compiler.pli"
module "/pliant/language/stream.pli"
module "/pliant/util/pml/io.pli"
module "/pliant/graphic/color/gamut.pli"
module "/pliant/graphic/color/rgb888.pli"
module "/pliant/graphic/image/prototype.pli"
module "/pliant/graphic/layout/prototype.pli"
module "/pliant/graphic/layout/text1.pli"
module "/pliant/graphic/console/prototype.pli"
public
type BrowserRedraw
field Int x0 y0 x1 y1
type BrowserSpace
field Int x0 y0 x1 y1 ; field LayoutColor color
type BrowserWindowHistory
field Str name
field Int scroll_x scroll_y
type BrowserHistory
field Str url ; field Dictionary context
field List:BrowserWindowHistory windows
type BrowserWindow
field Str name
field Address session_address
field Link:LayoutPrototype root overlay
field LayoutArea bbox
field Int scroll_x scroll_y <- 0
field Int x0 y0 x1 y1 <- undefined # visible area in the window or on the screen
field CBool refresh
field CBool orefresh
field List:BrowserRedraw redraw
# styling
field Int antialiasing <- 4
field Float fraction <- 0.25
field Int padding_size <- 5
field LayoutColor padding_color <- (color rgb 255 255 255)
type BrowserFocusHistory
field Pointer:BrowserWindow window
field Link:LayoutPrototype target
field Int index
type BrowserEvent
field Str id event key ; field Int buttons ; field Float x y ; field Str options ; field Pointer:BrowserWindow window
type BrowserSession
field Dictionary namespace
# windows
field Address console_address
field List:BrowserWindow windows
field Int position <- 4
# control
field Str url ; field Dictionary context
field Link:Stream connection
field (List Link:Stream) extra_connections
field List:BrowserHistory history
# focus
field Pointer:BrowserWindow focus_window
field Link:LayoutPrototype focus_target
field Int focus_index
field Str focus_value
field Int focus_scroll_stage
field Int focus_scroll_x focus_scroll_y
field List:BrowserFocusHistory focus_history
field Pointer:BrowserWindow over_window
field Link:LayoutPrototype over_target
# shortcuts
field (Dictionary Str Link:LayoutPrototype) keys
# styling
field Int border_size <- 1
|
field LayoutColor border_color <- (color rgb 192 192 192) ; field LayoutColor border_active_color <- (color rgb 128 128 128)
|
field LayoutColor border_color <- (color rgb 192 192 192)
field LayoutColor border_active_color <- (color rgb 128 128 128)
|
type BrowserLogin
field Str user password ; field CBool secured <- false
type BrowserConsole
field Link:ConsolePrototype console
field (Array BrowserSession 12) session
field Array:Int zorder
field Int size_x size_y # screen or OS window size
field Float unit_x unit_y # pixel size is mm
field Float middle_x middle_y <- 0.5
field Link:ColorGamut gamut
field CBool brefresh <- true
field List:BrowserSpace spaces
field Sem sem
field Int hurry_count <- 0
field CBool cancelable <- false
field DateTime last_full_cycle
field Float force_after <- 15 # seconds
field Link:LayoutStyle default_style
field Dictionary fonts
field Str font_server
field Link:Stream font_stream
field (Dictionary Str BrowserLogin) login
field Str clipboard_text
field Link:LayoutPrototype clipboard_target
field Int clipboard_index <- undefined
|
field CBool lazy_display_mark <- false
|
method w session -> s
arg BrowserWindow w ; arg_C BrowserSession s
s :> w:session_address map BrowserSession
method s console -> c
arg BrowserSession s ; arg_C BrowserConsole c
c :> s:console_address map BrowserConsole
function build c
arg_w BrowserConsole c
for (var Int i) 0 11
var Pointer:BrowserSession s :> c:session i
s console_address := addressof c
var BrowserWindow w ; w session_address := addressof s
w name := "main" ; w padding_color := color rgb 248 248 248 ; s windows += w
w name := "top" ; w padding_color := color rgb 240 240 240 ; s windows += w
w name := "bottom" ; w padding_color := color rgb 240 240 240 ; s windows += w
w name := "left" ; w padding_color := color rgb 240 240 240 ; s windows += w
w name := "right" ; w padding_color := color rgb 224 224 224 ; s windows += w
c zorder += i
method s window name -> w
arg BrowserSession s ; arg Str name ; arg_C BrowserWindow w
each ww s:windows
if ww:name=name
w :> ww
return
w :> null map BrowserWindow
method pc window -> w
arg LayoutPC pc ; arg_C Pointer:BrowserWindow w
w :>> (addressof pc:window_address) map Pointer:BrowserWindow
method c canceled -> canceled
arg BrowserConsole c ; arg CBool canceled
canceled := c:hurry_count>0 and c:cancelable
method pc canceled -> c
arg LayoutPC pc ; arg CBool c
c := pc:window:session:console canceled
method dc window -> w
arg LayoutDC dc ; arg_C Pointer:BrowserWindow w
w :>> (addressof dc:window_address) map Pointer:BrowserWindow
method dc canceled -> c
arg LayoutDC dc ; arg CBool c
c := dc:window:session:console canceled
method ec window -> w
arg LayoutEC ec ; arg_C Pointer:BrowserWindow w
w :>> (addressof ec:window_address) map Pointer:BrowserWindow
method c request_sem
arg_rw BrowserConsole c
var CBool cancel := true # c:last_full_cycle=defined and datetime:seconds-c:last_full_cycle:seconds<c:force_after
if cancel
atomic_add c:hurry_count 1
c:sem request
if cancel
atomic_add c:hurry_count -1
method w redraw_hurry
arg_rw BrowserWindow w
w:session:console last_full_cycle := undefined
export '. window' '. canceled' '. request_sem' '. redraw_hurry'
#-------------------------------------------------------------------------------
public
type BrowserClientContext
field Link:Stream connection
field Pointer:BrowserSession session
field CBool eos
field CBool extra_thread <- false
#
field Pointer:LayoutPrototype parent
field (Pointer Link:LayoutPrototype) chain
field Pointer:LayoutPrototype current
function build c
arg_w BrowserClientContext c
c chain :>> null map Link:LayoutPrototype
c parent :> null map LayoutPrototype
c current :> null map LayoutPrototype
#-------------------------------------------------------------------------------
gvar Dictionary browser_client_instructions
named_expression browser_client_instruction_prototype
function 'pliant browser client instruction function' context
arg_rw BrowserClientContext context
implicit context
body
meta browser_client_instruction e
if e:size>=2 and e:0:is_pure_ident and (e e:size-1):ident="{}"
var Address mark := e:module mark
var Link:Expression ee :> expression duplicate browser_client_instruction_prototype substitute parameters (e 1 e:size-2) substitute body (e e:size-1) substitute instruction (expression constant e:0:ident near e:0) near e
error_push_record (var ErrorRecord er) error_filter_all
ee compile
if er:id<>error_id_noerror
console er:message eol
er id := error_id_noerror
e suckup_error ee
error_pull_record er
var Link:Function f :> (pliant_general_dictionary first "pliant browser client instruction function") map Function
e:module rewind mark
if exists:f
browser_client_instructions insert e:0:ident true addressof:f
e set_void_result
export browser_client_instruction browser_client_instructions
#-------------------------------------------------------------------------------
constant trace true
constant trace2 false
function browser_client_instruction_prototype context fun
arg_rw BrowserClientContext context ; arg Function fun
indirect
method c lazy_display fun
arg_rw BrowserConsole c ; arg Function fun
indirect
gvar Link:Function real_lazy_display_function
method c process_instruction lock
arg_rw BrowserClientContext c ; arg CBool lock
if not (c:connection ipick open (var Ident instruction))
if trace and not c:extra_thread
console "broken connection" eol
c:connection error "corrupted connection"
return
var Pointer:Arrow pfun :> browser_client_instructions first (cast instruction Str)
if pfun=null
if trace
console "unsupported instruction '" (cast instruction Str) "'" eol
c:connection error "unsupported instruction '"+(cast instruction Str)+"'"
return
if trace2
console "process instruction " (cast instruction Str) eol
if lock
c:session:console request_sem
# console "begin " (cast instruction Str) eol
browser_client_instruction_prototype c (pfun map Function)
# console "end " (cast instruction Str) eol
if lock
|
var Pointer:BrowserConsole bc :> c:session console
thread
bc lazy_display real_lazy_display_function
bc:sem release
|
if c:eos
c:session:console:sem release
else
var Pointer:BrowserConsole bc :> c:session console
thread
bc lazy_display real_lazy_display_function
bc:sem release
|
if trace and c:connection=failure
console "corrupted instruction '" (cast instruction Str) "'" eol
method c ierror msg
arg_rw BrowserClientContext c ; arg Str msg
if c:connection=success
if trace
console msg eol
c:connection error msg
method s history_push
arg_rw BrowserSession s
var BrowserHistory h
h url := s url
h context := s context
each w s:windows
var BrowserWindowHistory wh
wh name := w name
wh scroll_x := w scroll_x
wh scroll_y := w scroll_y
h windows += wh
s history += h
method s history_pull
arg_rw BrowserSession s
var Pointer:BrowserHistory h :> s:history last
if not exists:h
return
s url := h url
s context := h context
each wh h:windows
var Pointer:BrowserWindow w :> s window wh:name
w scroll_x := wh scroll_x
w scroll_y := wh scroll_y
s:history remove h
export '. process_instruction'
export '. ierror'
export '. history_push' '. history_pull'
export real_lazy_display_function
|