Consistently cull cargo culting
Why was “;;” used? Once upon a time i saw double semi being used consistently by a coder who i, still, think is rather excellent - monkey see monkey do. I can relate to Daniel de Rauglaudre’s desire for a revised syntax.
This commit is contained in:
malc
parent
68d47a7544
commit
6c2c1c481c
177
config.ml
177
config.ml
|
|
@ -1,16 +1,14 @@
|
|||
open Utils;;
|
||||
open Utils
|
||||
|
||||
let irect_of_string s =
|
||||
Scanf.sscanf s "%d/%d/%d/%d" (fun x0 y0 x1 y1 -> (x0,y0,x1,y1))
|
||||
;;
|
||||
|
||||
let irect_to_string (x0,y0,x1,y1) = Printf.sprintf "%d/%d/%d/%d" x0 y0 x1 y1;;
|
||||
let irect_to_string (x0,y0,x1,y1) = Printf.sprintf "%d/%d/%d/%d" x0 y0 x1 y1
|
||||
|
||||
let multicolumns_to_string (n, a, b) =
|
||||
if a = 0 && b = 0
|
||||
then Printf.sprintf "%d" n
|
||||
else Printf.sprintf "%d,%d,%d" n a b;
|
||||
;;
|
||||
else Printf.sprintf "%d,%d,%d" n a b
|
||||
|
||||
let multicolumns_of_string s =
|
||||
try
|
||||
|
|
@ -20,10 +18,9 @@ let multicolumns_of_string s =
|
|||
if a > 1 || b > 1
|
||||
then error "subtly broken";
|
||||
(n, a, b)
|
||||
);
|
||||
;;
|
||||
)
|
||||
|
||||
include Confstruct;;
|
||||
include Confstruct
|
||||
|
||||
type angle = int
|
||||
and opaque = Opaque.t
|
||||
|
|
@ -77,14 +74,12 @@ and fontstate =
|
|||
; mutable wwidth : float
|
||||
; mutable maxrows : int
|
||||
}
|
||||
;;
|
||||
|
||||
let fstate =
|
||||
{ fontsize = Wsi.fontsizescale 20
|
||||
; wwidth = nan
|
||||
; maxrows = -1
|
||||
}
|
||||
;;
|
||||
|
||||
class type uioh =
|
||||
object
|
||||
|
|
@ -102,19 +97,19 @@ class type uioh =
|
|||
method alwaysscrolly : bool
|
||||
method scroll : int -> int -> uioh
|
||||
method zoom : float -> int -> int -> unit
|
||||
end;;
|
||||
end
|
||||
|
||||
module type TextEnumType = sig
|
||||
type t
|
||||
val name : string
|
||||
val names : string array
|
||||
end;;
|
||||
end
|
||||
|
||||
module TextEnumMake (Ten : TextEnumType) = struct
|
||||
let names = Ten.names;;
|
||||
let to_int (t : Ten.t) = Obj.magic t;;
|
||||
let to_string t = names.(to_int t);;
|
||||
let of_int n : Ten.t = Obj.magic n;;
|
||||
let names = Ten.names
|
||||
let to_int (t : Ten.t) = Obj.magic t
|
||||
let to_string t = names.(to_int t)
|
||||
let of_int n : Ten.t = Obj.magic n
|
||||
let of_string s =
|
||||
let rec find i =
|
||||
if i = Array.length names
|
||||
|
|
@ -124,26 +119,26 @@ module TextEnumMake (Ten : TextEnumType) = struct
|
|||
then of_int i
|
||||
else find (i+1)
|
||||
)
|
||||
in find 0;;
|
||||
end;;
|
||||
in find 0
|
||||
end
|
||||
|
||||
module CSTE = TextEnumMake (struct
|
||||
type t = colorspace;;
|
||||
let name = "colorspace";;
|
||||
let names = [|"rgb"; "gray"|];;
|
||||
end);;
|
||||
type t = colorspace
|
||||
let name = "colorspace"
|
||||
let names = [|"rgb"; "gray"|]
|
||||
end)
|
||||
|
||||
module MTE = TextEnumMake (struct
|
||||
type t = mark;;
|
||||
let name = "mark";;
|
||||
let names = [|"page"; "block"; "line"; "word"|];;
|
||||
end);;
|
||||
type t = mark
|
||||
let name = "mark"
|
||||
let names = [|"page"; "block"; "line"; "word"|]
|
||||
end)
|
||||
|
||||
module FMTE = TextEnumMake (struct
|
||||
type t = fitmodel;;
|
||||
let name = "fitmodel";;
|
||||
let names = [|"width"; "proportional"; "page"|];;
|
||||
end);;
|
||||
type t = fitmodel
|
||||
let name = "fitmodel"
|
||||
let names = [|"width"; "proportional"; "page"|]
|
||||
end)
|
||||
|
||||
type outlinekind =
|
||||
| Onone
|
||||
|
|
@ -155,7 +150,6 @@ type outlinekind =
|
|||
| Ohistory of (filename * conf * outline list * x * anchor * filename)
|
||||
and outline = (caption * outlinelevel * outlinekind)
|
||||
and outlinelevel = int
|
||||
;;
|
||||
|
||||
type page =
|
||||
{ pageno : int
|
||||
|
|
@ -170,7 +164,6 @@ type page =
|
|||
; pagedispy : int
|
||||
; pagecol : int
|
||||
}
|
||||
;;
|
||||
|
||||
type tile = opaque * pixmapsize * elapsed
|
||||
and elapsed = float
|
||||
|
|
@ -232,7 +225,6 @@ and 'a nav =
|
|||
{ past : 'a list
|
||||
; future : 'a list
|
||||
}
|
||||
;;
|
||||
|
||||
type state =
|
||||
{ mutable ss : Unix.file_descr
|
||||
|
|
@ -295,12 +287,11 @@ and hists =
|
|||
; pag : string circbuf
|
||||
; sel : string circbuf
|
||||
}
|
||||
;;
|
||||
|
||||
let emptyanchor = (0, 0.0, 0.0);;
|
||||
let emptykeyhash = Hashtbl.create 0;;
|
||||
let noreprf () = ();;
|
||||
let noroam () = ();;
|
||||
let emptyanchor = (0, 0.0, 0.0)
|
||||
let emptykeyhash = Hashtbl.create 0
|
||||
let noreprf () = ()
|
||||
let noroam () = ()
|
||||
|
||||
let nouioh : uioh =
|
||||
object (self)
|
||||
|
|
@ -318,9 +309,9 @@ let nouioh : uioh =
|
|||
method alwaysscrolly = false
|
||||
method scroll _ _ = self
|
||||
method zoom _ _ _ = ()
|
||||
end;;
|
||||
end
|
||||
|
||||
let conf = { defconf with keyhashes = copykeyhashes defconf };;
|
||||
let conf = { defconf with keyhashes = copykeyhashes defconf }
|
||||
|
||||
let cbnew n v =
|
||||
{ store = Array.make n v
|
||||
|
|
@ -328,9 +319,8 @@ let cbnew n v =
|
|||
; wc = 0
|
||||
; len = 0
|
||||
}
|
||||
;;
|
||||
|
||||
let cbcap b = Array.length b.store;;
|
||||
let cbcap b = Array.length b.store
|
||||
|
||||
let cbput ?(update_rc=true) b v =
|
||||
let cap = cbcap b in
|
||||
|
|
@ -338,12 +328,11 @@ let cbput ?(update_rc=true) b v =
|
|||
b.wc <- (b.wc + 1) mod cap;
|
||||
if update_rc
|
||||
then b.rc <- b.wc;
|
||||
b.len <- min (b.len + 1) cap;
|
||||
;;
|
||||
b.len <- min (b.len + 1) cap
|
||||
|
||||
let cbput_dont_update_rc b v = cbput ~update_rc:false b v;;
|
||||
let cbput_dont_update_rc b v = cbput ~update_rc:false b v
|
||||
|
||||
let cbempty b = b.len = 0;;
|
||||
let cbempty b = b.len = 0
|
||||
|
||||
let cbgetg b circular dir =
|
||||
if cbempty b
|
||||
|
|
@ -364,11 +353,10 @@ let cbgetg b circular dir =
|
|||
else bound rc 0 (b.len-1)
|
||||
in
|
||||
b.rc <- rc;
|
||||
b.store.(rc);
|
||||
;;
|
||||
b.store.(rc)
|
||||
|
||||
let cbget b = cbgetg b false;;
|
||||
let cbgetc b = cbgetg b true;;
|
||||
let cbget b = cbgetg b false
|
||||
let cbgetc b = cbgetg b true
|
||||
|
||||
let state =
|
||||
{ ss = Unix.stdin
|
||||
|
|
@ -427,12 +415,10 @@ let state =
|
|||
; reload = None
|
||||
; nav = { past = []; future = []; }
|
||||
}
|
||||
;;
|
||||
|
||||
let calcips h =
|
||||
let d = state.winh - h in
|
||||
max conf.interpagespace ((d + 1) / 2)
|
||||
;;
|
||||
|
||||
let rowyh (c, coverA, coverB) b n =
|
||||
if c = 1 || (n < coverA || n >= state.pagecount - coverB)
|
||||
|
|
@ -454,7 +440,6 @@ let rowyh (c, coverA, coverB) b n =
|
|||
findminmax (m+1) miny maxh
|
||||
in
|
||||
findminmax s max_int 0
|
||||
;;
|
||||
|
||||
let page_of_y y =
|
||||
let ((c, coverA, coverB) as cl), b =
|
||||
|
|
@ -505,8 +490,7 @@ let page_of_y y =
|
|||
else bsearch nmin (n-1)
|
||||
)
|
||||
in
|
||||
bsearch 0 (state.pagecount-1);
|
||||
;;
|
||||
bsearch 0 (state.pagecount-1)
|
||||
|
||||
let calcheight () =
|
||||
match conf.columns with
|
||||
|
|
@ -528,7 +512,6 @@ let calcheight () =
|
|||
let (_, _, y, (_, _, h, _)) = b.(Array.length b - 1) in
|
||||
y + h
|
||||
else 0
|
||||
;;
|
||||
|
||||
let getpageywh pageno =
|
||||
let pageno = bound pageno 0 (state.pagecount-1) in
|
||||
|
|
@ -563,12 +546,10 @@ let getpageywh pageno =
|
|||
let n = pageno*c in
|
||||
let (_, _, y, (_, w, h, _)) = b.(n) in
|
||||
y, w / c, h
|
||||
;;
|
||||
|
||||
let getpageyh pageno =
|
||||
let y,_,h = getpageywh pageno in
|
||||
y, h;
|
||||
;;
|
||||
y, h
|
||||
|
||||
let getpagedim pageno =
|
||||
let rec f ppdim l =
|
||||
|
|
@ -580,7 +561,6 @@ let getpagedim pageno =
|
|||
| [] -> ppdim
|
||||
in
|
||||
f (-1, -1, -1, -1) state.pdims
|
||||
;;
|
||||
|
||||
let getpdimno pageno =
|
||||
let rec f p l =
|
||||
|
|
@ -593,9 +573,8 @@ let getpdimno pageno =
|
|||
| [] -> p
|
||||
in
|
||||
f ~-1 state.pdims
|
||||
;;
|
||||
|
||||
let getpagey pageno = fst (getpageyh pageno);;
|
||||
let getpagey pageno = fst (getpageyh pageno)
|
||||
|
||||
let getanchor1 l =
|
||||
let top =
|
||||
|
|
@ -612,7 +591,6 @@ let getanchor1 l =
|
|||
)
|
||||
in
|
||||
(l.pageno, top, dtop)
|
||||
;;
|
||||
|
||||
let getanchor () =
|
||||
match state.layout with
|
||||
|
|
@ -632,28 +610,25 @@ let getanchor () =
|
|||
else float dy /. float conf.interpagespace
|
||||
in
|
||||
(n, 0.0, dtop)
|
||||
;;
|
||||
|
||||
let fontpath = ref E.s;;
|
||||
let fontpath = ref E.s
|
||||
|
||||
type historder = [ `lastvisit | `title | `path | `file ];;
|
||||
type historder = [ `lastvisit | `title | `path | `file ]
|
||||
|
||||
module KeyMap =
|
||||
Map.Make (struct type t = (int * int) let compare = compare end);;
|
||||
Map.Make (struct type t = (int * int) let compare = compare end)
|
||||
|
||||
let unentS s =
|
||||
let l = String.length s in
|
||||
let b = Buffer.create l in
|
||||
Parser.unent b s 0 l;
|
||||
Buffer.contents b;
|
||||
;;
|
||||
Buffer.contents b
|
||||
|
||||
let home =
|
||||
try Sys.getenv "HOME"
|
||||
with exn ->
|
||||
dolog "cannot determine home directory location: %s" @@ exntos exn;
|
||||
E.s
|
||||
;;
|
||||
|
||||
let modifier_of_string = function
|
||||
| "alt" -> Wsi.altmask
|
||||
|
|
@ -661,7 +636,6 @@ let modifier_of_string = function
|
|||
| "ctrl" | "control" -> Wsi.ctrlmask
|
||||
| "meta" -> Wsi.metamask
|
||||
| _ -> 0
|
||||
;;
|
||||
|
||||
let keys_of_string s =
|
||||
let key_of_string r s =
|
||||
|
|
@ -687,7 +661,6 @@ let keys_of_string s =
|
|||
in
|
||||
let elems = Str.split Utils.Re.whitespace s in
|
||||
List.map (key_of_string (Str.regexp "-")) elems
|
||||
;;
|
||||
|
||||
let validatehcs v =
|
||||
let l = String.length v in
|
||||
|
|
@ -703,7 +676,6 @@ let validatehcs v =
|
|||
else check (S.add e s) (i+1)
|
||||
in
|
||||
check (S.singleton (String.get v 0)) 1
|
||||
;;
|
||||
|
||||
let config_of c attrs =
|
||||
let maxv ?(f=int_of_string) u s = max u @@ f s in
|
||||
|
|
@ -808,15 +780,13 @@ let config_of c attrs =
|
|||
let c = apply c k v in
|
||||
fold c rest
|
||||
in
|
||||
fold { c with keyhashes = copykeyhashes c } attrs;
|
||||
;;
|
||||
fold { c with keyhashes = copykeyhashes c } attrs
|
||||
|
||||
let fromstring f pos n v d =
|
||||
try f v
|
||||
with exn ->
|
||||
dolog "error processing attribute (%S=%S) at %d\n%s" n v pos @@ exntos exn;
|
||||
d
|
||||
;;
|
||||
|
||||
let bookmark_of attrs =
|
||||
let rec fold title page rely visy = function
|
||||
|
|
@ -828,7 +798,6 @@ let bookmark_of attrs =
|
|||
| [] -> title, page, rely, visy
|
||||
in
|
||||
fold "invalid" "0" "0" "0" attrs
|
||||
;;
|
||||
|
||||
let doc_of attrs =
|
||||
let rec fold path key page rely pan visy origin dcf = function
|
||||
|
|
@ -844,7 +813,6 @@ let doc_of attrs =
|
|||
| [] -> path, key, page, rely, pan, visy, origin, dcf
|
||||
in
|
||||
fold E.s E.s "0" "0" "0" "0" E.s E.s attrs
|
||||
;;
|
||||
|
||||
let map_of attrs =
|
||||
let rec fold rs ls = function
|
||||
|
|
@ -854,12 +822,10 @@ let map_of attrs =
|
|||
| [] -> ls, rs
|
||||
in
|
||||
fold E.s E.s attrs
|
||||
;;
|
||||
|
||||
let findkeyhash c name =
|
||||
try List.assoc name c.keyhashes
|
||||
with Not_found -> error "invalid mode name `%s'" name
|
||||
;;
|
||||
|
||||
let get s =
|
||||
let open Parser in
|
||||
|
|
@ -1072,8 +1038,7 @@ let get s =
|
|||
else parse_error ("unexpected close in skipped " ^ tag) s spos
|
||||
in
|
||||
parse { f = toplevel; accu = () } s;
|
||||
h, dc;
|
||||
;;
|
||||
h, dc
|
||||
|
||||
let do_load f contents =
|
||||
try f contents
|
||||
|
|
@ -1083,7 +1048,6 @@ let do_load f contents =
|
|||
Utils.error "parse error: %s: at %d [..%S..]" msg pos subs
|
||||
|
||||
| exn -> Utils.error "parse error: %s" @@ exntos exn
|
||||
;;
|
||||
|
||||
let defconfpath =
|
||||
let dir =
|
||||
|
|
@ -1091,9 +1055,8 @@ let defconfpath =
|
|||
if Sys.is_directory dir then dir else home
|
||||
in
|
||||
Filename.concat dir "llpp.conf"
|
||||
;;
|
||||
|
||||
let confpath = ref defconfpath;;
|
||||
let confpath = ref defconfpath
|
||||
|
||||
let load2 f default =
|
||||
match filecontents !confpath with
|
||||
|
|
@ -1103,9 +1066,8 @@ let load2 f default =
|
|||
| exception exn ->
|
||||
dolog "error loading configuration from `%S': %s" !confpath @@ exntos exn;
|
||||
default
|
||||
;;
|
||||
|
||||
let load1 f = load2 f false;;
|
||||
let load1 f = load2 f false
|
||||
|
||||
let load openlast =
|
||||
let f (h, dc) =
|
||||
|
|
@ -1157,7 +1119,6 @@ let load openlast =
|
|||
true
|
||||
in
|
||||
load1 f
|
||||
;;
|
||||
|
||||
let gethist () =
|
||||
let f (h, _) =
|
||||
|
|
@ -1166,7 +1127,6 @@ let gethist () =
|
|||
h [];
|
||||
in
|
||||
load2 f []
|
||||
;;
|
||||
|
||||
let add_attrs bb always dc c time =
|
||||
let o' fmt s =
|
||||
|
|
@ -1270,8 +1230,7 @@ let add_attrs bb always dc c time =
|
|||
ob "use-document-css" c.usedoccss dc.usedoccss;
|
||||
os "dcf" c.dcf dc.dcf;
|
||||
os "hint-charset" c.hcs dc.hcs;
|
||||
ob "remap-htns" c.remaphtns dc.remaphtns;
|
||||
;;
|
||||
ob "remap-htns" c.remaphtns dc.remaphtns
|
||||
|
||||
let keymapsbuf always dc c =
|
||||
let open Buffer in
|
||||
|
|
@ -1324,8 +1283,7 @@ let keymapsbuf always dc c =
|
|||
loop rest
|
||||
in
|
||||
loop c.keyhashes;
|
||||
bb;
|
||||
;;
|
||||
bb
|
||||
|
||||
let keystostrlist c =
|
||||
let rec loop accu = function
|
||||
|
|
@ -1373,18 +1331,19 @@ let keystostrlist c =
|
|||
loop accu rest
|
||||
in
|
||||
loop [] c.keyhashes
|
||||
;;
|
||||
|
||||
let save1 bb leavebirdseye x h dc =
|
||||
let uifontsize = fstate.fontsize in
|
||||
Buffer.add_string bb "<llppconfig>\n";
|
||||
if nonemptystr !fontpath
|
||||
then Printf.bprintf bb "<ui-font size='%d'><![CDATA[%s]]></ui-font>\n"
|
||||
uifontsize !fontpath
|
||||
else
|
||||
then (
|
||||
Printf.bprintf bb "<ui-font size='%d'><![CDATA[%s]]></ui-font>\n"
|
||||
uifontsize !fontpath
|
||||
)
|
||||
else (
|
||||
if uifontsize <> 14
|
||||
then Printf.bprintf bb "<ui-font size='%d'/>\n" uifontsize
|
||||
;
|
||||
);
|
||||
|
||||
Buffer.add_string bb "<defaults";
|
||||
add_attrs bb true dc dc nan;
|
||||
|
|
@ -1404,11 +1363,15 @@ let save1 bb leavebirdseye x h dc =
|
|||
(Parser.enent path 0 (String.length path));
|
||||
|
||||
if nonemptystr c.key
|
||||
then Printf.bprintf bb "\n key='%s'" c.key;
|
||||
then (
|
||||
Printf.bprintf bb "\n key='%s'" c.key;
|
||||
);
|
||||
|
||||
if nonemptystr origin
|
||||
then Printf.bprintf bb "\n origin='%s'"
|
||||
(Parser.enent origin 0 (String.length origin));
|
||||
then (
|
||||
Printf.bprintf bb "\n origin='%s'"
|
||||
(Parser.enent origin 0 (String.length origin));
|
||||
);
|
||||
|
||||
if anchor <> emptyanchor
|
||||
then (
|
||||
|
|
@ -1468,8 +1431,8 @@ let save1 bb leavebirdseye x h dc =
|
|||
Buffer.add_string bb "\n";
|
||||
Buffer.add_buffer bb kb;
|
||||
);
|
||||
Buffer.add_string bb "\n</doc>\n";
|
||||
end;
|
||||
Buffer.add_string bb "\n</doc>\n"
|
||||
end
|
||||
)
|
||||
in
|
||||
|
||||
|
|
@ -1523,8 +1486,7 @@ let save1 bb leavebirdseye x h dc =
|
|||
then adddoc path x anchor c bookmarks c.lastvisit origin
|
||||
) h;
|
||||
Buffer.add_string bb "</llppconfig>\n";
|
||||
true;
|
||||
;;
|
||||
true
|
||||
|
||||
let save leavebirdseye =
|
||||
let relx = float state.x /. float state.winw in
|
||||
|
|
@ -1552,7 +1514,6 @@ let save leavebirdseye =
|
|||
close_out oc;
|
||||
Unix.rename tmp !confpath;
|
||||
with exn -> dolog "error saving configuration: %s" @@ exntos exn
|
||||
;;
|
||||
|
||||
let gc () =
|
||||
let href = ref @@ Hashtbl.create 0 in
|
||||
|
|
@ -1579,8 +1540,7 @@ let gc () =
|
|||
close_out oc;
|
||||
Unix.rename tmp !confpath;
|
||||
with exn -> dolog "error saving configuration: %s" @@ exntos exn
|
||||
);
|
||||
;;
|
||||
)
|
||||
|
||||
let logcurrently = function
|
||||
| Idle -> dolog "Idle"
|
||||
|
|
@ -1595,4 +1555,3 @@ let logcurrently = function
|
|||
tilew tileh
|
||||
conf.tilew conf.tileh
|
||||
| Outlining _ -> dolog "outlining"
|
||||
;;
|
||||
|
|
|
|||
90
ffi.ml
90
ffi.ml
|
|
@ -1,62 +1,62 @@
|
|||
open Config;;
|
||||
open Config
|
||||
|
||||
type initparams = (angle * fitmodel * trimparams * texcount * sliceheight *
|
||||
memsize * colorspace * fontpath * dupstderr)
|
||||
and xoff = int and yoff = int and noff = int
|
||||
and li = (noff * string * hintfontsize * hintchars)
|
||||
and hlmask = int and hintchars = string and hintfontsize = int;;
|
||||
and hlmask = int and hintchars = string and hintfontsize = int
|
||||
|
||||
external init : Unix.file_descr -> initparams -> Unix.file_descr = "ml_init";;
|
||||
external seltext : opaque -> (int * int * int * int) -> unit = "ml_seltext";;
|
||||
external hassel : opaque -> bool = "ml_hassel";;
|
||||
external getpdimrect : int -> float array = "ml_getpdimrect";;
|
||||
external whatsunder : opaque -> x -> y -> under = "ml_whatsunder";;
|
||||
external markunder : opaque -> x -> y -> mark -> bool = "ml_markunder";;
|
||||
external clearmark : opaque -> unit = "ml_clearmark";;
|
||||
external zoomforh : int -> int -> int -> int -> float = "ml_zoom_for_height";;
|
||||
external getmaxw : unit -> float = "ml_getmaxw";;
|
||||
external init : Unix.file_descr -> initparams -> Unix.file_descr = "ml_init"
|
||||
external seltext : opaque -> (int * int * int * int) -> unit = "ml_seltext"
|
||||
external hassel : opaque -> bool = "ml_hassel"
|
||||
external getpdimrect : int -> float array = "ml_getpdimrect"
|
||||
external whatsunder : opaque -> x -> y -> under = "ml_whatsunder"
|
||||
external markunder : opaque -> x -> y -> mark -> bool = "ml_markunder"
|
||||
external clearmark : opaque -> unit = "ml_clearmark"
|
||||
external zoomforh : int -> int -> int -> int -> float = "ml_zoom_for_height"
|
||||
external getmaxw : unit -> float = "ml_getmaxw"
|
||||
external postprocess : opaque -> hlmask -> xoff -> yoff -> li -> noff
|
||||
= "ml_postprocess";;
|
||||
external setdcf : string -> unit = "ml_setdcf";;
|
||||
external pagebbox : opaque -> irect = "ml_getpagebox";;
|
||||
external setaalevel : int -> unit = "ml_setaalevel";;
|
||||
external setpapercolor : rgba -> unit = "ml_setpapercolor";;
|
||||
external realloctexts : int -> bool = "ml_realloctexts";;
|
||||
external findlink : opaque -> linkdir -> link = "ml_findlink";;
|
||||
external getlink : opaque -> int -> under = "ml_getlink";;
|
||||
external getlinkn : opaque -> string -> string -> int -> int = "ml_getlinkn";;
|
||||
external getlinkrect : opaque -> int -> irect = "ml_getlinkrect";;
|
||||
external findpwl : int -> int -> pagewithlinks = "ml_find_page_with_links";;
|
||||
= "ml_postprocess"
|
||||
external setdcf : string -> unit = "ml_setdcf"
|
||||
external pagebbox : opaque -> irect = "ml_getpagebox"
|
||||
external setaalevel : int -> unit = "ml_setaalevel"
|
||||
external setpapercolor : rgba -> unit = "ml_setpapercolor"
|
||||
external realloctexts : int -> bool = "ml_realloctexts"
|
||||
external findlink : opaque -> linkdir -> link = "ml_findlink"
|
||||
external getlink : opaque -> int -> under = "ml_getlink"
|
||||
external getlinkn : opaque -> string -> string -> int -> int = "ml_getlinkn"
|
||||
external getlinkrect : opaque -> int -> irect = "ml_getlinkrect"
|
||||
external findpwl : int -> int -> pagewithlinks = "ml_find_page_with_links"
|
||||
external unproject : opaque -> int -> int -> (int * int) option
|
||||
= "ml_unproject";;
|
||||
= "ml_unproject"
|
||||
external project : opaque -> int -> int -> float -> float -> (float * float)
|
||||
= "ml_project";;
|
||||
external drawtile : tileparams -> opaque -> unit = "ml_drawtile";;
|
||||
= "ml_project"
|
||||
external drawtile : tileparams -> opaque -> unit = "ml_drawtile"
|
||||
external rectofblock : opaque -> int -> int -> float array option
|
||||
= "ml_rectofblock";;
|
||||
external begintiles : unit -> unit = "ml_begintiles";;
|
||||
external endtiles : unit -> unit = "ml_endtiles";;
|
||||
external addannot : opaque -> int -> int -> string -> unit = "ml_addannot";;
|
||||
external modannot : opaque -> slinkindex -> string -> unit = "ml_modannot";;
|
||||
external delannot : opaque -> slinkindex -> unit = "ml_delannot";;
|
||||
external hasunsavedchanges : unit -> bool = "ml_hasunsavedchanges";;
|
||||
external savedoc : string -> unit = "ml_savedoc";;
|
||||
= "ml_rectofblock"
|
||||
external begintiles : unit -> unit = "ml_begintiles"
|
||||
external endtiles : unit -> unit = "ml_endtiles"
|
||||
external addannot : opaque -> int -> int -> string -> unit = "ml_addannot"
|
||||
external modannot : opaque -> slinkindex -> string -> unit = "ml_modannot"
|
||||
external delannot : opaque -> slinkindex -> unit = "ml_delannot"
|
||||
external hasunsavedchanges : unit -> bool = "ml_hasunsavedchanges"
|
||||
external savedoc : string -> unit = "ml_savedoc"
|
||||
external getannotcontents : opaque -> slinkindex -> string
|
||||
= "ml_getannotcontents";;
|
||||
external wcmd : Unix.file_descr -> bytes -> int -> unit = "ml_wcmd";;
|
||||
external rcmd : Unix.file_descr -> string = "ml_rcmd";;
|
||||
= "ml_getannotcontents"
|
||||
external wcmd : Unix.file_descr -> bytes -> int -> unit = "ml_wcmd"
|
||||
external rcmd : Unix.file_descr -> string = "ml_rcmd"
|
||||
external uritolocation : string -> (pageno * float * float)
|
||||
= "ml_uritolocation";;
|
||||
external isexternallink : string -> bool = "ml_isexternallink";;
|
||||
= "ml_uritolocation"
|
||||
external isexternallink : string -> bool = "ml_isexternallink"
|
||||
|
||||
(* copysel _will_ close the supplied descriptor *)
|
||||
external copysel : Unix.file_descr -> opaque -> unit = "ml_copysel";;
|
||||
external copysel : Unix.file_descr -> opaque -> unit = "ml_copysel"
|
||||
|
||||
external drawstr : int -> int -> int -> string -> float = "ml_draw_string";;
|
||||
external drawstr : int -> int -> int -> string -> float = "ml_draw_string"
|
||||
|
||||
external fz_version : unit -> string = "ml_fz_version";;
|
||||
external llpp_version : unit -> string = "ml_llpp_version";;
|
||||
external fz_version : unit -> string = "ml_fz_version"
|
||||
external llpp_version : unit -> string = "ml_llpp_version"
|
||||
|
||||
external measurestr : int -> string -> float = "ml_measure_string";;
|
||||
external toutf8 : int -> string = "ml_keysymtoutf8";;
|
||||
external mbtoutf8 : string -> string = "ml_mbtoutf8";;
|
||||
external measurestr : int -> string -> float = "ml_measure_string"
|
||||
external toutf8 : int -> string = "ml_keysymtoutf8"
|
||||
external mbtoutf8 : string -> string = "ml_mbtoutf8"
|
||||
|
|
|
|||
|
|
@ -33,8 +33,8 @@ and x = int and y = int and leftx = int
|
|||
and covercount = int
|
||||
and width = int and height = int
|
||||
and memsize = int and texcount = int
|
||||
and sliceheight = int;;
|
||||
let scrollbvv = 1 and scrollbhv = 2;;
|
||||
and sliceheight = int
|
||||
let scrollbvv = 1 and scrollbhv = 2
|
||||
EOF
|
||||
|
||||
init=
|
||||
|
|
@ -133,8 +133,8 @@ s hcs "{|aoeuidhtns|}"
|
|||
b remaphtns false
|
||||
|
||||
cat <<EOF
|
||||
};;
|
||||
let copykeyhashes c = List.map (fun (k, v) -> k, Hashtbl.copy v) c.keyhashes;;
|
||||
let defconf = {$init};;
|
||||
}
|
||||
let copykeyhashes c = List.map (fun (k, v) -> k, Hashtbl.copy v) c.keyhashes
|
||||
let defconf = {$init}
|
||||
let setconf dst src = $assi;
|
||||
EOF
|
||||
|
|
|
|||
23
glutils.ml
23
glutils.ml
|
|
@ -1,26 +1,23 @@
|
|||
let vraw = Raw.create_static `float ~len:8;;
|
||||
let vraw = Raw.create_static `float ~len:8
|
||||
|
||||
let filledrect2 x0 y0 x1 y1 x2 y2 x3 y3 =
|
||||
Raw.sets_float vraw ~pos:0 [| x0; y0; x1; y1; x2; y2; x3; y3 |];
|
||||
GlArray.vertex `two vraw;
|
||||
GlArray.draw_arrays `triangle_strip ~first:0 ~count:4;
|
||||
;;
|
||||
GlArray.draw_arrays `triangle_strip ~first:0 ~count:4
|
||||
|
||||
let filledrect1 x0 y0 x1 y1 = filledrect2 x0 y0 x0 y1 x1 y0 x1 y1;;
|
||||
let filledrect1 x0 y0 x1 y1 = filledrect2 x0 y0 x0 y1 x1 y0 x1 y1
|
||||
|
||||
let filledrect x0 y0 x1 y1 =
|
||||
GlArray.disable `texture_coord;
|
||||
filledrect1 x0 y0 x1 y1;
|
||||
GlArray.enable `texture_coord;
|
||||
;;
|
||||
GlArray.enable `texture_coord
|
||||
|
||||
let linerect x0 y0 x1 y1 =
|
||||
GlArray.disable `texture_coord;
|
||||
Raw.sets_float vraw ~pos:0 [| x0; y0; x0; y1; x1; y1; x1; y0 |];
|
||||
GlArray.vertex `two vraw;
|
||||
GlArray.draw_arrays `line_loop ~first:0 ~count:4;
|
||||
GlArray.enable `texture_coord;
|
||||
;;
|
||||
GlArray.enable `texture_coord
|
||||
|
||||
let drawstring size x y s =
|
||||
Gl.enable `blend;
|
||||
|
|
@ -28,12 +25,10 @@ let drawstring size x y s =
|
|||
GlFunc.blend_func ~src:`src_alpha ~dst:`one_minus_src_alpha;
|
||||
ignore (Ffi.drawstr size x y s);
|
||||
Gl.disable `blend;
|
||||
Gl.disable `texture_2d;
|
||||
;;
|
||||
Gl.disable `texture_2d
|
||||
|
||||
let drawstringf size x y = Printf.kprintf (drawstring size (x+1) (y+size+1));;
|
||||
let redisplay = ref false;;
|
||||
let drawstringf size x y = Printf.kprintf (drawstring size (x+1) (y+size+1))
|
||||
let redisplay = ref false
|
||||
let postRedisplay who =
|
||||
Utils.vlog "redisplay for [%S]" who;
|
||||
redisplay := true;
|
||||
;;
|
||||
redisplay := true
|
||||
|
|
|
|||
9
help.ml
9
help.ml
|
|
@ -169,15 +169,14 @@ selection command otherwise
|
|||
|
||||
-----Caveat emptor-----
|
||||
o Text selection is limited to a single page
|
||||
o Text searching is very naive|};;
|
||||
o Text searching is very naive|}
|
||||
|
||||
open Utils;;
|
||||
open Utils
|
||||
|
||||
let gotourl launcher url =
|
||||
let command = Str.global_replace Utils.Re.percent url launcher in
|
||||
try ignore @@ spawn command []
|
||||
with exn -> dolog "failed to execute `%s': %s" command @@ exntos exn
|
||||
;;
|
||||
|
||||
let gotouri launcher uri =
|
||||
if emptystr launcher
|
||||
|
|
@ -186,18 +185,15 @@ let gotouri launcher uri =
|
|||
if nonemptystr @@ geturl uri
|
||||
then gotourl launcher uri
|
||||
else dolog "obtained empty url from uri %S" uri
|
||||
;;
|
||||
|
||||
let version () =
|
||||
Printf.sprintf "llpp %s, ocaml %s (%d bit), fitz %s"
|
||||
(Ffi.llpp_version ()) Sys.ocaml_version Sys.word_size (Ffi.fz_version ())
|
||||
;;
|
||||
|
||||
let fixup s = Str.(let gr = global_replace in
|
||||
let dash = regexp {|\([^ ]*\) +- +\(.*\)|}
|
||||
and head = regexp {|-----\(.*\)-----|} in
|
||||
gr dash "\\1\t\\2" @@ gr head "\xc2\xb7\\1" s)
|
||||
;;
|
||||
|
||||
let makehelp launcher =
|
||||
version ()
|
||||
|
|
@ -209,4 +205,3 @@ let makehelp launcher =
|
|||
| "" -> (s, 0, Config.Noaction)
|
||||
| url -> (s, 0, Config.Action (fun uioh -> gotourl launcher url; uioh))
|
||||
)
|
||||
;;
|
||||
|
|
|
|||
8
help.mli
8
help.mli
|
|
@ -1,4 +1,4 @@
|
|||
val gotouri : string -> string -> unit;;
|
||||
val gotourl : string -> string -> unit;;
|
||||
val makehelp : string -> (string * int * Config.action) list;;
|
||||
val version : unit -> string;;
|
||||
val gotouri : string -> string -> unit
|
||||
val gotourl : string -> string -> unit
|
||||
val makehelp : string -> (string * int * Config.action) list
|
||||
val version : unit -> string
|
||||
|
|
|
|||
2
keys.ml
2
keys.ml
|
|
@ -2,7 +2,6 @@ type t =
|
|||
| Ascii of char | Code of int | Ctrl of int | Fn of int
|
||||
| Backspace | Delete | Escape | Insert | Enter
|
||||
| Up | Down | Left | Right | Next | Prior | Home | End
|
||||
;;
|
||||
|
||||
let to_string = function
|
||||
| Ascii c -> Printf.sprintf "'%c'" c
|
||||
|
|
@ -22,4 +21,3 @@ let to_string = function
|
|||
| Prior -> "prior"
|
||||
| Home -> "home"
|
||||
| End -> "end"
|
||||
;;
|
||||
|
|
|
|||
14
parser.ml
14
parser.ml
|
|
@ -3,18 +3,16 @@
|
|||
let iswhite = function
|
||||
| '\r' | '\n' | '\t' | ' ' -> true
|
||||
| _ -> false
|
||||
;;
|
||||
|
||||
let isname = function
|
||||
| '.' | '-' | '_' | ':' -> true
|
||||
| c -> (c >= '0' && c <= '9')
|
||||
|| (c >= 'a' && c <= 'z')
|
||||
|| (c >= 'A' && c <= 'Z')
|
||||
;;
|
||||
|
||||
exception Parse_error of string * string * int;;
|
||||
exception Parse_error of string * string * int
|
||||
|
||||
let parse_error msg s pos = raise (Parse_error (msg, s, pos));;
|
||||
let parse_error msg s pos = raise (Parse_error (msg, s, pos))
|
||||
|
||||
let enent s pos len =
|
||||
let b = Buffer.create len in
|
||||
|
|
@ -42,7 +40,6 @@ let enent s pos len =
|
|||
)
|
||||
in
|
||||
loop pos
|
||||
;;
|
||||
|
||||
let unent b s pos len =
|
||||
let rec loop i =
|
||||
|
|
@ -98,7 +95,6 @@ let unent b s pos len =
|
|||
)
|
||||
in
|
||||
loop pos
|
||||
;;
|
||||
|
||||
let subs s pos =
|
||||
let len = String.length s in
|
||||
|
|
@ -108,7 +104,6 @@ let subs s pos =
|
|||
else
|
||||
let len = min left 10 in
|
||||
String.sub s pos len
|
||||
;;
|
||||
|
||||
let ts = function
|
||||
| `text -> "text"
|
||||
|
|
@ -119,7 +114,6 @@ let ts = function
|
|||
| `doctype -> "doctype"
|
||||
| `comment -> "comment"
|
||||
| `tag -> "tag"
|
||||
;;
|
||||
|
||||
type attr = string * string
|
||||
and attrs = attr list
|
||||
|
|
@ -130,7 +124,6 @@ type attr = string * string
|
|||
| Vclose of string
|
||||
| Vend
|
||||
and 'a v = { f : 'a v -> vp -> int -> int -> 'a v; accu : 'a }
|
||||
;;
|
||||
|
||||
let parse v s =
|
||||
let r_comment_terminator = Str.regexp "-->"
|
||||
|
|
@ -330,5 +323,4 @@ let parse v s =
|
|||
f [] pos
|
||||
in
|
||||
let _, _ = collect v 0 `text in
|
||||
v.accu;
|
||||
;;
|
||||
v.accu
|
||||
|
|
|
|||
28
uiutils.ml
28
uiutils.ml
|
|
@ -1,6 +1,6 @@
|
|||
open Utils;;
|
||||
open Glutils;;
|
||||
open Config;;
|
||||
open Utils
|
||||
open Glutils
|
||||
open Config
|
||||
|
||||
let scrollph y maxy =
|
||||
let sh = float (maxy + state.winh) /. float state.winh in
|
||||
|
|
@ -15,37 +15,31 @@ let scrollph y maxy =
|
|||
then float state.winh -. sh
|
||||
else position
|
||||
in
|
||||
position, sh;
|
||||
;;
|
||||
position, sh
|
||||
|
||||
let isbirdseye = function
|
||||
| Birdseye _ -> true
|
||||
| Textentry _ | View | LinkNav _ -> false
|
||||
;;
|
||||
|
||||
let istextentry = function
|
||||
| Textentry _ -> true
|
||||
| Birdseye _ | View | LinkNav _ -> false
|
||||
;;
|
||||
|
||||
let vscrollw () =
|
||||
if state.uioh#alwaysscrolly || ((conf.scrollb land scrollbvv != 0)
|
||||
&& (state.maxy > state.winh))
|
||||
then conf.scrollbw
|
||||
else 0
|
||||
;;
|
||||
|
||||
let vscrollhit x =
|
||||
if conf.leftscroll
|
||||
then x < vscrollw ()
|
||||
else x > state.winw - vscrollw ()
|
||||
;;
|
||||
|
||||
let firstof first active =
|
||||
if first > active || abs (first - active) > fstate.maxrows - 1
|
||||
then max 0 (active - (fstate.maxrows/2))
|
||||
else first
|
||||
;;
|
||||
|
||||
let calcfirst first active =
|
||||
if active > first
|
||||
|
|
@ -53,7 +47,6 @@ let calcfirst first active =
|
|||
let rows = active - first in
|
||||
if rows > fstate.maxrows then active - fstate.maxrows else first
|
||||
else active
|
||||
;;
|
||||
|
||||
let enttext () =
|
||||
let len = String.length state.text in
|
||||
|
|
@ -117,7 +110,6 @@ let enttext () =
|
|||
in
|
||||
if nonemptystr s
|
||||
then drawstring s
|
||||
;;
|
||||
|
||||
let textentrykeyboard
|
||||
key mask ((c, text, opthist, onkey, ondone, cancelonempty), onleave) =
|
||||
|
|
@ -196,7 +188,6 @@ let textentrykeyboard
|
|||
postRedisplay "textentrykeyboard switch";
|
||||
end
|
||||
| _ -> vlog "unhandled key"
|
||||
;;
|
||||
|
||||
class type lvsource =
|
||||
object
|
||||
|
|
@ -213,7 +204,7 @@ class type lvsource =
|
|||
method getfirst : int
|
||||
method getpan : int
|
||||
method getminfo : (int * int) array
|
||||
end;;
|
||||
end
|
||||
|
||||
class virtual lvsourcebase =
|
||||
object
|
||||
|
|
@ -224,15 +215,14 @@ class virtual lvsourcebase =
|
|||
method getfirst = m_first
|
||||
method getpan = m_pan
|
||||
method getminfo : (int * int) array = E.a
|
||||
end;;
|
||||
end
|
||||
|
||||
let coe s = (s :> uioh);;
|
||||
let setuioh uioh = state.uioh <- coe uioh;;
|
||||
let coe s = (s :> uioh)
|
||||
let setuioh uioh = state.uioh <- coe uioh
|
||||
|
||||
let changetitle uioh =
|
||||
let title = uioh#title in
|
||||
Wsi.settitle @@ if emptystr title then "llpp" else title ^ " - llpp";
|
||||
;;
|
||||
|
||||
class listview ~zebra ~helpmode ~(source:lvsource) ~trusted ~modehash =
|
||||
object (self)
|
||||
|
|
@ -803,4 +793,4 @@ object (self)
|
|||
coe self
|
||||
|
||||
method zoom _ _ _ = ()
|
||||
end;;
|
||||
end
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
let ellipsis = "\xe2\x80\xa6";;
|
||||
let radical = "\xe2\x88\x9a";;
|
||||
let lguillemet = "\xc2\xab";;
|
||||
let rguillemet = "\xc2\xbb";;
|
||||
let ellipsis = "\xe2\x80\xa6"
|
||||
let radical = "\xe2\x88\x9a"
|
||||
let lguillemet = "\xc2\xab"
|
||||
let rguillemet = "\xc2\xbb"
|
||||
|
|
|
|||
103
utils.ml
103
utils.ml
|
|
@ -1,38 +1,36 @@
|
|||
exception Quit;;
|
||||
exception Quit
|
||||
|
||||
module E = struct
|
||||
let s = "";;
|
||||
let b = Bytes.empty;;
|
||||
let a = [||];;
|
||||
end;;
|
||||
let s = ""
|
||||
let b = Bytes.empty
|
||||
let a = [||]
|
||||
end
|
||||
|
||||
let tempfailureretry f a =
|
||||
let rec g () =
|
||||
try f a with Unix.Unix_error (Unix.EINTR, _, _) -> g ()
|
||||
in g ()
|
||||
;;
|
||||
|
||||
external spawn : string -> (Unix.file_descr * int) list -> int = "ml_spawn";;
|
||||
external hasdata : Unix.file_descr -> bool = "ml_hasdata";;
|
||||
external spawn : string -> (Unix.file_descr * int) list -> int = "ml_spawn"
|
||||
external hasdata : Unix.file_descr -> bool = "ml_hasdata"
|
||||
|
||||
let now = Unix.gettimeofday;;
|
||||
let dologf = ref prerr_endline;;
|
||||
let dolog fmt = Format.ksprintf !dologf fmt;;
|
||||
let dolog1 fmt = Format.ksprintf (fun s -> print_endline s; flush stdout) fmt;;
|
||||
let now = Unix.gettimeofday
|
||||
let dologf = ref prerr_endline
|
||||
let dolog fmt = Format.ksprintf !dologf fmt
|
||||
let dolog1 fmt = Format.ksprintf (fun s -> print_endline s; flush stdout) fmt
|
||||
|
||||
let exntos = function
|
||||
| Unix.Unix_error (e, s, a) ->
|
||||
Printf.sprintf "%s(%s) : %s (%d)" s a (Unix.error_message e) (Obj.magic e)
|
||||
| exn -> Printexc.to_string exn
|
||||
;;
|
||||
|
||||
let error fmt = Printf.kprintf failwith fmt;;
|
||||
let error fmt = Printf.kprintf failwith fmt
|
||||
|
||||
module IntSet = Set.Make (struct type t = int let compare = (-) end);;
|
||||
module IntSet = Set.Make (struct type t = int let compare = (-) end)
|
||||
|
||||
let emptystr s = String.length s = 0;;
|
||||
let nonemptystr s = String.length s > 0;;
|
||||
let bound v minv maxv = max minv (min maxv v);;
|
||||
let emptystr s = String.length s = 0
|
||||
let nonemptystr s = String.length s > 0
|
||||
let bound v minv maxv = max minv (min maxv v)
|
||||
|
||||
module Opaque : sig
|
||||
type t = private string
|
||||
|
|
@ -42,10 +40,10 @@ end = struct
|
|||
type t = string
|
||||
let of_string s = s
|
||||
let to_string t = t
|
||||
end;;
|
||||
end
|
||||
|
||||
let (~<) = Opaque.of_string;;
|
||||
let (~>) = Opaque.to_string;;
|
||||
let (~<) = Opaque.of_string
|
||||
let (~>) = Opaque.to_string
|
||||
|
||||
let int_of_string_with_suffix s =
|
||||
let l = String.length s in
|
||||
|
|
@ -65,7 +63,6 @@ let int_of_string_with_suffix s =
|
|||
if m < 0 || m < n
|
||||
then error "value too large"
|
||||
else m
|
||||
;;
|
||||
|
||||
let string_with_suffix_of_int n =
|
||||
let rec find = function
|
||||
|
|
@ -76,27 +73,23 @@ let string_with_suffix_of_int n =
|
|||
else find rest
|
||||
in
|
||||
if n = 0 then "0" else find [(30, 'G'); (20, 'M'); (10, 'K')]
|
||||
;;
|
||||
|
||||
let color_of_string s =
|
||||
Scanf.sscanf s "%d/%d/%d" (fun r g b ->
|
||||
(float r /. 255.0, float g /. 255.0, float b /. 255.0)
|
||||
)
|
||||
;;
|
||||
|
||||
let rgba_of_string s =
|
||||
Scanf.sscanf
|
||||
s "%d/%d/%d/%d" (fun r g b a ->
|
||||
(float r /. 255.0, float g /. 255.0, float b /. 255.0, float a /. 255.0)
|
||||
)
|
||||
;;
|
||||
|
||||
let color_to_string (r, g, b) =
|
||||
let r = truncate (r *. 255.0)
|
||||
and g = truncate (g *. 255.0)
|
||||
and b = truncate (b *. 255.0) in
|
||||
Printf.sprintf "%d/%d/%d" r g b
|
||||
;;
|
||||
|
||||
let rgba_to_string (r, g, b, a) =
|
||||
let r = truncate (r *. 255.0)
|
||||
|
|
@ -104,7 +97,6 @@ let rgba_to_string (r, g, b, a) =
|
|||
and b = truncate (b *. 255.0)
|
||||
and a = truncate (a *. 255.0) in
|
||||
Printf.sprintf "%d/%d/%d/%d" r g b a
|
||||
;;
|
||||
|
||||
let abspath path =
|
||||
if Filename.is_relative path
|
||||
|
|
@ -114,53 +106,46 @@ let abspath path =
|
|||
then Filename.concat cwd path
|
||||
else Filename.concat cwd (Filename.basename path)
|
||||
else path
|
||||
;;
|
||||
|
||||
module Ne = struct
|
||||
let index s c = try String.index s c with Not_found -> -1;;
|
||||
let index s c = try String.index s c with Not_found -> -1
|
||||
let clo fd f =
|
||||
try tempfailureretry Unix.close fd
|
||||
with exn -> f @@ exntos exn
|
||||
;;
|
||||
end;;
|
||||
end
|
||||
|
||||
let getoptdef def = function
|
||||
| Some a -> a
|
||||
| None -> def
|
||||
;;
|
||||
|
||||
let getenvdef name def =
|
||||
match Sys.getenv name with
|
||||
| env -> env
|
||||
| exception Not_found -> def
|
||||
;;
|
||||
|
||||
module Re = struct
|
||||
let crlf = Str.regexp "[\r\n]";;
|
||||
let percent = Str.regexp "%s";;
|
||||
let whitespace = Str.regexp "[ \t]";;
|
||||
end;;
|
||||
let crlf = Str.regexp "[\r\n]"
|
||||
let percent = Str.regexp "%s"
|
||||
let whitespace = Str.regexp "[ \t]"
|
||||
end
|
||||
|
||||
let addchar s c =
|
||||
let b = Buffer.create (String.length s + 1) in
|
||||
Buffer.add_string b s;
|
||||
Buffer.add_char b c;
|
||||
Buffer.contents b;
|
||||
;;
|
||||
Buffer.contents b
|
||||
|
||||
let btod b = if b then 1 else 0;;
|
||||
let btod b = if b then 1 else 0
|
||||
|
||||
let splitatchar s c = let open String in
|
||||
match index s c with
|
||||
| pos -> sub s 0 pos, sub s (pos+1) (length s - pos - 1)
|
||||
| exception Not_found -> s, E.s
|
||||
;;
|
||||
|
||||
let boundastep h step =
|
||||
if step < 0
|
||||
then bound step ~-h 0
|
||||
else bound step 0 h
|
||||
;;
|
||||
|
||||
let withoutlastutf8 s =
|
||||
let len = String.length s in
|
||||
|
|
@ -181,8 +166,7 @@ let withoutlastutf8 s =
|
|||
then len-1
|
||||
else find (len-1)
|
||||
in
|
||||
String.sub s 0 first;
|
||||
;;
|
||||
String.sub s 0 first
|
||||
|
||||
let fdcontents fd =
|
||||
let l = 4096 in
|
||||
|
|
@ -198,7 +182,6 @@ let fdcontents fd =
|
|||
)
|
||||
in
|
||||
loop ()
|
||||
;;
|
||||
|
||||
let filecontents path =
|
||||
let fd = Unix.openfile path [Unix.O_RDONLY] 0o0 in
|
||||
|
|
@ -208,7 +191,6 @@ let filecontents path =
|
|||
| s ->
|
||||
Ne.clo fd @@ error "failed to close descriptor for %s: %s" path;
|
||||
s
|
||||
;;
|
||||
|
||||
let getcmdoutput errfun cmd =
|
||||
let reperror fmt = Printf.kprintf errfun fmt in
|
||||
|
|
@ -253,14 +235,12 @@ let getcmdoutput errfun cmd =
|
|||
in
|
||||
Ne.clo r @@ clofail "read end of the pipe";
|
||||
s
|
||||
;;
|
||||
|
||||
let geturl =
|
||||
let re = Str.regexp {|.*\(\(https?\|ftp\|mailto\|file\)://[^ ]+\).*|} in
|
||||
fun s -> if Str.string_match re s 0
|
||||
then Str.matched_group 1 s
|
||||
else E.s
|
||||
;;
|
||||
|
||||
let substratis s pos subs =
|
||||
let subslen = String.length subs in
|
||||
|
|
@ -269,19 +249,18 @@ let substratis s pos subs =
|
|||
let rec cmp i = i = subslen || (s.[pos+i] = subs.[i]) && cmp (i+1)
|
||||
in cmp 0
|
||||
else false
|
||||
;;
|
||||
|
||||
let w8 = Bytes.set_uint8;;
|
||||
let r8 = Bytes.get_uint8;;1
|
||||
let w16 = Bytes.set_uint16_le;;
|
||||
let r16 = Bytes.get_uint16_le;;
|
||||
let r16s = Bytes.get_int16_le;;
|
||||
let w32 s pos i = w16 s pos i; w16 s (pos+2) (i lsr 16);;
|
||||
let r32 s pos = ((r16 s (pos+2)) lsl 16) lor (r16 s pos);;
|
||||
let r32s s pos = Bytes.get_int32_le s pos |> Int32.to_int;;
|
||||
let w8 = Bytes.set_uint8
|
||||
let r8 = Bytes.get_uint8
|
||||
let w16 = Bytes.set_uint16_le
|
||||
let r16 = Bytes.get_uint16_le
|
||||
let r16s = Bytes.get_int16_le
|
||||
let w32 s pos i = w16 s pos i; w16 s (pos+2) (i lsr 16)
|
||||
let r32 s pos = ((r16 s (pos+2)) lsl 16) lor (r16 s pos)
|
||||
let r32s s pos = Bytes.get_int32_le s pos |> Int32.to_int
|
||||
|
||||
let vlogf = ref ignore;;
|
||||
let vlog fmt = Printf.kprintf !vlogf fmt;;
|
||||
let vlogf = ref ignore
|
||||
let vlog fmt = Printf.kprintf !vlogf fmt
|
||||
|
||||
let pipef ?(closew=true) cap f cmd =
|
||||
match Unix.pipe () with
|
||||
|
|
@ -292,8 +271,7 @@ let pipef ?(closew=true) cap f cmd =
|
|||
| _pid -> f w
|
||||
end;
|
||||
Ne.clo r (dolog "%s failed to close r: %s" cap);
|
||||
if closew then Ne.clo w (dolog "%s failed to close w: %s" cap);
|
||||
;;
|
||||
if closew then Ne.clo w (dolog "%s failed to close w: %s" cap)
|
||||
|
||||
let selstring selcmd s =
|
||||
pipef "selstring" (fun w ->
|
||||
|
|
@ -305,6 +283,5 @@ let selstring selcmd s =
|
|||
then dolog "failed to write %d characters to sel pipe, wrote %d" l n;
|
||||
with exn -> dolog "failed to write to sel pipe: %s" @@ exntos exn
|
||||
) selcmd
|
||||
;;
|
||||
|
||||
let cloexec = Unix.set_close_on_exec;;
|
||||
let cloexec = Unix.set_close_on_exec
|
||||
|
|
|
|||
53
wsi.mli
53
wsi.mli
|
|
@ -4,19 +4,16 @@ type cursor =
|
|||
| CURSOR_CYCLE
|
||||
| CURSOR_FLEUR
|
||||
| CURSOR_TEXT
|
||||
;;
|
||||
|
||||
type winstate =
|
||||
| MaxVert
|
||||
| MaxHorz
|
||||
| Fullscreen
|
||||
;;
|
||||
|
||||
type visiblestate =
|
||||
| Unobscured
|
||||
| PartiallyObscured
|
||||
| FullyObscured
|
||||
;;
|
||||
|
||||
class type t =
|
||||
object
|
||||
|
|
@ -36,29 +33,29 @@ class type t =
|
|||
method scroll : int -> int -> unit
|
||||
method zoom : float -> int -> int -> unit
|
||||
method opendoc : string -> unit
|
||||
end;;
|
||||
end
|
||||
|
||||
type keycode = int;;
|
||||
val setcursor : cursor -> unit;;
|
||||
val settitle : string -> unit;;
|
||||
val setmapc : (keycode -> keycode) -> unit;;
|
||||
val swapb : unit -> unit;;
|
||||
val readresp : Unix.file_descr -> unit;;
|
||||
val init : t -> int -> int -> Unix.file_descr * int * int;;
|
||||
val fullscreen : unit -> unit;;
|
||||
val reshape : int -> int -> unit;;
|
||||
val activatewin : unit -> unit;;
|
||||
val mapwin : unit -> unit;;
|
||||
val withalt : int -> bool;;
|
||||
val withctrl : int -> bool;;
|
||||
val withshift : int -> bool;;
|
||||
val withmeta : int -> bool;;
|
||||
val withnone : int -> bool;;
|
||||
val metamask : int;;
|
||||
val altmask : int;;
|
||||
val shiftmask : int;;
|
||||
val ctrlmask : int;;
|
||||
val keyname : int -> string;;
|
||||
val namekey : string -> int;;
|
||||
val fontsizescale : int -> int;;
|
||||
val ks2kt : int -> Keys.t;;
|
||||
type keycode = int
|
||||
val setcursor : cursor -> unit
|
||||
val settitle : string -> unit
|
||||
val setmapc : (keycode -> keycode) -> unit
|
||||
val swapb : unit -> unit
|
||||
val readresp : Unix.file_descr -> unit
|
||||
val init : t -> int -> int -> Unix.file_descr * int * int
|
||||
val fullscreen : unit -> unit
|
||||
val reshape : int -> int -> unit
|
||||
val activatewin : unit -> unit
|
||||
val mapwin : unit -> unit
|
||||
val withalt : int -> bool
|
||||
val withctrl : int -> bool
|
||||
val withshift : int -> bool
|
||||
val withmeta : int -> bool
|
||||
val withnone : int -> bool
|
||||
val metamask : int
|
||||
val altmask : int
|
||||
val shiftmask : int
|
||||
val ctrlmask : int
|
||||
val keyname : int -> string
|
||||
val namekey : string -> int
|
||||
val fontsizescale : int -> int
|
||||
val ks2kt : int -> Keys.t
|
||||
|
|
|
|||
166
wsi/x11/wsi.ml
166
wsi/x11/wsi.ml
|
|
@ -1,6 +1,6 @@
|
|||
open Utils;;
|
||||
open Utils
|
||||
|
||||
let (~>) = Bytes.unsafe_of_string;;
|
||||
let (~>) = Bytes.unsafe_of_string
|
||||
|
||||
type cursor =
|
||||
| CURSOR_INHERIT
|
||||
|
|
@ -8,26 +8,23 @@ type cursor =
|
|||
| CURSOR_CYCLE
|
||||
| CURSOR_FLEUR
|
||||
| CURSOR_TEXT
|
||||
;;
|
||||
|
||||
type winstate =
|
||||
| MaxVert
|
||||
| MaxHorz
|
||||
| Fullscreen
|
||||
;;
|
||||
|
||||
type visiblestate =
|
||||
| Unobscured
|
||||
| PartiallyObscured
|
||||
| FullyObscured
|
||||
;;
|
||||
|
||||
type wid = int and screenno = int and vid = int and atom = int;;
|
||||
type wid = int and screenno = int and vid = int and atom = int
|
||||
|
||||
external glxinit : string -> wid -> screenno -> vid = "ml_glxinit";;
|
||||
external glxcompleteinit : unit -> unit = "ml_glxcompleteinit";;
|
||||
external swapb : unit -> unit = "ml_swapb";;
|
||||
external setcursor : cursor -> unit = "ml_setcursor";;
|
||||
external glxinit : string -> wid -> screenno -> vid = "ml_glxinit"
|
||||
external glxcompleteinit : unit -> unit = "ml_glxcompleteinit"
|
||||
external swapb : unit -> unit = "ml_swapb"
|
||||
external setcursor : cursor -> unit = "ml_setcursor"
|
||||
|
||||
let onot = object
|
||||
method display = ()
|
||||
|
|
@ -46,7 +43,7 @@ let onot = object
|
|||
method scroll _ _ = ()
|
||||
method zoom _ _ _ = ()
|
||||
method opendoc _ = ()
|
||||
end;;
|
||||
end
|
||||
|
||||
class type t =
|
||||
object
|
||||
|
|
@ -66,7 +63,7 @@ class type t =
|
|||
method scroll : int -> int -> unit
|
||||
method zoom : float -> int -> int -> unit
|
||||
method opendoc : string -> unit
|
||||
end;;
|
||||
end
|
||||
|
||||
type state =
|
||||
{ mutable mink : int
|
||||
|
|
@ -106,7 +103,7 @@ type state =
|
|||
and fs =
|
||||
| NoFs
|
||||
| Fs of (int * int * int * int)
|
||||
and keycode = int;;
|
||||
and keycode = int
|
||||
|
||||
let state =
|
||||
{ mink = max_int
|
||||
|
|
@ -143,31 +140,29 @@ let state =
|
|||
; fscale = 1.0
|
||||
; mapc = Fun.id
|
||||
}
|
||||
;;
|
||||
|
||||
let settitle s = state.setwmname (~> s);;
|
||||
let fullscreen () = state.fullscreen state.wid;;
|
||||
let fontsizescale n = float n *. state.fscale |> truncate;;
|
||||
let setmapc f = state.mapc <- f;;
|
||||
let settitle s = state.setwmname (~> s)
|
||||
let fullscreen () = state.fullscreen state.wid
|
||||
let fontsizescale n = float n *. state.fscale |> truncate
|
||||
let setmapc f = state.mapc <- f
|
||||
|
||||
let ordermagic = 'l';;
|
||||
let metamask = 0x40;;
|
||||
let altmask = 8;;
|
||||
let shiftmask = 1;;
|
||||
let ctrlmask = 4;;
|
||||
let ordermagic = 'l'
|
||||
let metamask = 0x40
|
||||
let altmask = 8
|
||||
let shiftmask = 1
|
||||
let ctrlmask = 4
|
||||
|
||||
let withalt mask = mask land altmask != 0;;
|
||||
let withctrl mask = mask land ctrlmask != 0;;
|
||||
let withshift mask = mask land shiftmask != 0;;
|
||||
let withmeta mask = mask land metamask != 0;;
|
||||
let withnone mask = mask land (altmask + ctrlmask + shiftmask + metamask) = 0;;
|
||||
let withalt mask = mask land altmask != 0
|
||||
let withctrl mask = mask land ctrlmask != 0
|
||||
let withshift mask = mask land shiftmask != 0
|
||||
let withmeta mask = mask land metamask != 0
|
||||
let withnone mask = mask land (altmask + ctrlmask + shiftmask + metamask) = 0
|
||||
|
||||
let makereq opcode len reqlen =
|
||||
let s = Bytes.create len in
|
||||
w8 s 0 opcode;
|
||||
w16 s 2 reqlen;
|
||||
s;
|
||||
;;
|
||||
s
|
||||
|
||||
let readstr sock n =
|
||||
let s = Bytes.create n in
|
||||
|
|
@ -182,8 +177,7 @@ let readstr sock n =
|
|||
)
|
||||
in
|
||||
loop 0 n;
|
||||
s;
|
||||
;;
|
||||
s
|
||||
|
||||
let sendstr1 s pos len sock =
|
||||
let s = Bytes.unsafe_to_string s in
|
||||
|
|
@ -191,8 +185,7 @@ let sendstr1 s pos len sock =
|
|||
state.seq <- state.seq + 1;
|
||||
let n = tempfailureretry (Unix.write_substring sock s pos) len in
|
||||
if n != len
|
||||
then error "send %d returned %d" len n;
|
||||
;;
|
||||
then error "send %d returned %d" len n
|
||||
|
||||
let updkmap sock resp =
|
||||
let syms = r8 resp 1 in
|
||||
|
|
@ -218,8 +211,7 @@ let updkmap sock resp =
|
|||
loop2 k 0;
|
||||
loop (i+1);
|
||||
in
|
||||
loop 0;
|
||||
;;
|
||||
loop 0
|
||||
|
||||
let updmodmap sock resp =
|
||||
let n = r8 resp 1 in
|
||||
|
|
@ -282,13 +274,11 @@ let updmodmap sock resp =
|
|||
loop1 0;
|
||||
loop (l+1)
|
||||
in
|
||||
loop 0;
|
||||
;;
|
||||
loop 0
|
||||
|
||||
let sendwithrep sock s f =
|
||||
Queue.push f state.fifo;
|
||||
sendstr1 s 0 (Bytes.length s) sock;
|
||||
;;
|
||||
sendstr1 s 0 (Bytes.length s) sock
|
||||
|
||||
let padcat b1 b2 =
|
||||
let l1 = Bytes.length b1 and l2 = Bytes.length b2 in
|
||||
|
|
@ -297,8 +287,7 @@ let padcat b1 b2 =
|
|||
let b = Bytes.create (l1 + l2 + pl) in
|
||||
Bytes.blit b1 0 b 0 l1;
|
||||
Bytes.blit b2 0 b l1 l2;
|
||||
b;
|
||||
;;
|
||||
b
|
||||
|
||||
let internreq name onlyifexists =
|
||||
let s = makereq 16 8 8 in
|
||||
|
|
@ -306,13 +295,11 @@ let internreq name onlyifexists =
|
|||
w8 s 1 (if onlyifexists then 1 else 0);
|
||||
w16 s 2 (Bytes.length s / 4);
|
||||
w16 s 4 (Bytes.length name);
|
||||
s;
|
||||
;;
|
||||
s
|
||||
|
||||
let sendintern sock s onlyifexists f =
|
||||
let s = internreq s onlyifexists in
|
||||
sendwithrep sock s f;
|
||||
;;
|
||||
sendwithrep sock s f
|
||||
|
||||
let createwindowreq wid parent x y w h bw eventmask vid depth mid =
|
||||
let s = makereq 1 44 11 in
|
||||
|
|
@ -333,8 +320,7 @@ let createwindowreq wid parent x y w h bw eventmask vid depth mid =
|
|||
w32 s 32 0; (* border pixel*)
|
||||
w32 s 36 eventmask;
|
||||
w32 s 40 mid;
|
||||
s;
|
||||
;;
|
||||
s
|
||||
|
||||
let createcolormapreq mid wid vid =
|
||||
let s = makereq 78 16 4 in
|
||||
|
|
@ -342,27 +328,23 @@ let createcolormapreq mid wid vid =
|
|||
w32 s 4 mid;
|
||||
w32 s 8 wid;
|
||||
w32 s 12 vid;
|
||||
s;
|
||||
;;
|
||||
s
|
||||
|
||||
let getgeometryreq wid =
|
||||
let s = makereq 14 8 2 in
|
||||
w32 s 4 wid;
|
||||
s;
|
||||
;;
|
||||
s
|
||||
|
||||
let mapreq wid =
|
||||
let s = makereq 8 8 2 in
|
||||
w32 s 4 wid;
|
||||
s;
|
||||
;;
|
||||
s
|
||||
|
||||
let getkeymapreq first count =
|
||||
let s = makereq 101 8 2 in
|
||||
w8 s 4 first;
|
||||
w8 s 5 count;
|
||||
s;
|
||||
;;
|
||||
s
|
||||
|
||||
let changepropreq wid prop typ format props =
|
||||
let s = makereq 18 24 0 in
|
||||
|
|
@ -380,8 +362,7 @@ let changepropreq wid prop typ format props =
|
|||
| n -> error "no idea what %d means" n)
|
||||
in
|
||||
w32 s 20 ful;
|
||||
s;
|
||||
;;
|
||||
s
|
||||
|
||||
let getpropreq delete wid prop typ =
|
||||
let s = makereq 20 24 6 in
|
||||
|
|
@ -391,8 +372,7 @@ let getpropreq delete wid prop typ =
|
|||
w32 s 12 typ;
|
||||
w32 s 16 0;
|
||||
w32 s 20 2;
|
||||
s;
|
||||
;;
|
||||
s
|
||||
|
||||
let configurewindowreq wid mask values =
|
||||
let s = makereq 12 12 0 in
|
||||
|
|
@ -400,14 +380,12 @@ let configurewindowreq wid mask values =
|
|||
w16 s 2 (Bytes.length s / 4);
|
||||
w32 s 4 wid;
|
||||
w16 s 8 mask;
|
||||
s;
|
||||
;;
|
||||
s
|
||||
|
||||
let s32 n =
|
||||
let s = Bytes.create 4 in
|
||||
w32 s 0 n;
|
||||
s;
|
||||
;;
|
||||
s
|
||||
|
||||
let clientmessage format seq wid typ data =
|
||||
let s = makereq 33 12 0 in
|
||||
|
|
@ -416,8 +394,7 @@ let clientmessage format seq wid typ data =
|
|||
w16 s 2 seq;
|
||||
w32 s 4 wid;
|
||||
w32 s 8 typ;
|
||||
s;
|
||||
;;
|
||||
s
|
||||
|
||||
let sendeventreq propagate destwid mask data =
|
||||
let s = makereq 25 12 11 in
|
||||
|
|
@ -426,20 +403,17 @@ let sendeventreq propagate destwid mask data =
|
|||
w16 s 2 11;
|
||||
w32 s 4 destwid;
|
||||
w32 s 8 mask;
|
||||
s;
|
||||
;;
|
||||
s
|
||||
|
||||
let getmodifiermappingreq () =
|
||||
makereq 119 4 1;
|
||||
;;
|
||||
makereq 119 4 1
|
||||
|
||||
let queryextensionreq name =
|
||||
let s = makereq 98 8 0 in
|
||||
let s = padcat s name in
|
||||
w16 s 2 (Bytes.length s / 4);
|
||||
w16 s 4 (Bytes.length name);
|
||||
s;
|
||||
;;
|
||||
s
|
||||
|
||||
let getkeysym pkpk code mask =
|
||||
if (pkpk >= 0xff80 && pkpk <= 0xffbd)
|
||||
|
|
@ -470,15 +444,13 @@ let getkeysym pkpk code mask =
|
|||
if index land 1 = 1 && keysym = 0
|
||||
then state.keymap.(code-state.mink).(index - 1)
|
||||
else keysym
|
||||
);
|
||||
;;
|
||||
)
|
||||
|
||||
let getkeysym code mask =
|
||||
let pkpk = state.keymap.(code-state.mink).(0) in
|
||||
if state.xkb && pkpk lsr 8 = 0xfe (* XKB *)
|
||||
then 0
|
||||
else getkeysym pkpk code mask;
|
||||
;;
|
||||
else getkeysym pkpk code mask
|
||||
|
||||
let readresp sock =
|
||||
let resp = readstr sock 32 in
|
||||
|
|
@ -661,21 +633,18 @@ let readresp sock =
|
|||
state.t#winstate (List.sort compare wsl)
|
||||
);
|
||||
|
||||
| n -> dolog "event %d %S" n (Bytes.unsafe_to_string resp);
|
||||
;;
|
||||
| n -> dolog "event %d %S" n (Bytes.unsafe_to_string resp)
|
||||
|
||||
let readresp sock =
|
||||
let rec loop () =
|
||||
readresp sock;
|
||||
if hasdata sock then loop ();
|
||||
in
|
||||
loop ();
|
||||
;;
|
||||
loop ()
|
||||
|
||||
let sendstr s ?(pos=0) ?(len=Bytes.length s) sock =
|
||||
sendstr1 s pos len sock;
|
||||
if hasdata sock then readresp sock;
|
||||
;;
|
||||
if hasdata sock then readresp sock
|
||||
|
||||
let reshape w h =
|
||||
if state.fs = NoFs
|
||||
|
|
@ -685,12 +654,10 @@ let reshape w h =
|
|||
w32 s 4 h;
|
||||
let s = configurewindowreq state.wid 0x000c s in
|
||||
sendstr s state.sock;
|
||||
else state.fullscreen state.wid;
|
||||
;;
|
||||
else state.fullscreen state.wid
|
||||
|
||||
let activatewin () =
|
||||
state.actwin ();
|
||||
;;
|
||||
state.actwin ()
|
||||
|
||||
let syncsendwithrep sock secstowait s f =
|
||||
let completed = ref false in
|
||||
|
|
@ -712,18 +679,15 @@ let syncsendwithrep sock secstowait s f =
|
|||
if not !completed
|
||||
then readtillcompletion ();
|
||||
in
|
||||
readtillcompletion ();
|
||||
;;
|
||||
readtillcompletion ()
|
||||
|
||||
let mapwin () =
|
||||
let s = mapreq state.wid in
|
||||
sendstr s state.sock;
|
||||
;;
|
||||
sendstr s state.sock
|
||||
|
||||
let syncsendintern sock secstowait s onlyifexists f =
|
||||
let s = internreq s onlyifexists in
|
||||
syncsendwithrep sock secstowait s f;
|
||||
;;
|
||||
syncsendwithrep sock secstowait s f
|
||||
|
||||
let setup disp sock rootwid screennum w h =
|
||||
let s = readstr sock 2 in
|
||||
|
|
@ -1024,8 +988,7 @@ let setup disp sock rootwid screennum w h =
|
|||
state.h <- h;
|
||||
);
|
||||
|
||||
| c -> error "unknown connection setup response %d" (Char.code c);
|
||||
;;
|
||||
| c -> error "unknown connection setup response %d" (Char.code c)
|
||||
|
||||
let getauth haddr dnum =
|
||||
let haddr =
|
||||
|
|
@ -1101,7 +1064,6 @@ let getauth haddr dnum =
|
|||
dolog "failed to open X authority file `%S' : %s" path @@ exntos exn
|
||||
;
|
||||
E.s, E.s
|
||||
;;
|
||||
|
||||
let init t w h =
|
||||
let d =
|
||||
|
|
@ -1182,8 +1144,7 @@ let init t w h =
|
|||
state.sock <- fd;
|
||||
setup d fd 0 screennum w h;
|
||||
state.t <- t;
|
||||
fd, state.w, state.h;
|
||||
;;
|
||||
fd, state.w, state.h
|
||||
|
||||
let setcursor cursor =
|
||||
if cursor != state.curcurs
|
||||
|
|
@ -1191,7 +1152,6 @@ let setcursor cursor =
|
|||
setcursor cursor;
|
||||
state.curcurs <- cursor;
|
||||
)
|
||||
;;
|
||||
|
||||
let xlatt, xlatf =
|
||||
let t = Hashtbl.create 20
|
||||
|
|
@ -1229,21 +1189,18 @@ let xlatt, xlatf =
|
|||
add "up" [] 0xff52;
|
||||
add "down" [] 0xff54;
|
||||
add "menu" [] 0xff67;
|
||||
t, f;
|
||||
;;
|
||||
t, f
|
||||
|
||||
let keyname k =
|
||||
try Hashtbl.find xlatf k
|
||||
with Not_found -> Printf.sprintf "%#x" k;
|
||||
;;
|
||||
with Not_found -> Printf.sprintf "%#x" k
|
||||
|
||||
let namekey name =
|
||||
try Hashtbl.find xlatt name
|
||||
with Not_found ->
|
||||
if String.length name = 1
|
||||
then Char.code name.[0]
|
||||
else int_of_string name;
|
||||
;;
|
||||
else int_of_string name
|
||||
|
||||
let ks2kt =
|
||||
let open Keys in
|
||||
|
|
@ -1279,4 +1236,3 @@ let ks2kt =
|
|||
| code when code >= 0xffbe && code <= 0xffc8 -> Fn (code - 0xffbe + 1)
|
||||
| code when code land 0xff00 = 0xff00 -> Ctrl code
|
||||
| code -> Code code
|
||||
;;
|
||||
|
|
|
|||
Loading…
Reference in New Issue