TM
[llpp.git] / main.ml
blobf67d1abe113329409f6c9b1504695db1d7011848
1 open Utils;;
3 exception Quit;;
5 type under =
6 | Unone
7 | Ulinkuri of string
8 | Ulinkgoto of (int * int)
9 | Utext of facename
10 | Uunexpected of string
11 | Ulaunch of string
12 | Unamed of string
13 | Uremote of (string * int)
14 and facename = string;;
16 type params = (angle * fitmodel * trimparams
17 * texcount * sliceheight * memsize
18 * colorspace * fontpath * trimcachepath
19 * haspbo)
20 and pageno = int
21 and width = int
22 and height = int
23 and leftx = int
24 and opaque = string
25 and recttype = int
26 and pixmapsize = int
27 and angle = int
28 and trimmargins = bool
29 and interpagespace = int
30 and texcount = int
31 and sliceheight = int
32 and gen = int
33 and top = float
34 and dtop = float
35 and fontpath = string
36 and trimcachepath = string
37 and memsize = int
38 and aalevel = int
39 and irect = (int * int * int * int)
40 and trimparams = (trimmargins * irect)
41 and colorspace = | Rgb | Bgr | Gray
42 and fitmodel = | FitWidth | FitProportional | FitPage
43 and haspbo = bool
46 type x = int
47 and y = int
48 and tilex = int
49 and tiley = int
50 and tileparams = (x * y * width * height * tilex * tiley)
53 type link =
54 | Lnotfound
55 | Lfound of int
56 and linkdir =
57 | LDfirst
58 | LDlast
59 | LDfirstvisible of (int * int * int)
60 | LDleft of int
61 | LDright of int
62 | LDdown of int
63 | LDup of int
66 type pagewithlinks =
67 | Pwlnotfound
68 | Pwl of int
71 type keymap =
72 | KMinsrt of key
73 | KMinsrl of key list
74 | KMmulti of key list * key list
75 and key = int * int
76 and keyhash = (key, keymap) Hashtbl.t
77 and keystate =
78 | KSnone
79 | KSinto of (key list * key list)
82 type platform = | Punknown | Plinux | Posx | Psun | Pfreebsd
83 | Pdragonflybsd | Popenbsd | Pnetbsd | Pcygwin;;
85 type pipe = (Unix.file_descr * Unix.file_descr);;
87 external init : pipe -> params -> unit = "ml_init";;
88 external seltext : string -> (int * int * int * int) -> unit = "ml_seltext";;
89 external copysel : Unix.file_descr -> opaque -> unit = "ml_copysel";;
90 external getpdimrect : int -> float array = "ml_getpdimrect";;
91 external whatsunder : string -> int -> int -> under = "ml_whatsunder";;
92 external zoomforh : int -> int -> int -> int -> float = "ml_zoom_for_height";;
93 external drawstr : int -> int -> int -> string -> float = "ml_draw_string";;
94 external measurestr : int -> string -> float = "ml_measure_string";;
95 external postprocess :
96 opaque -> int -> int -> int -> (int * string * int) -> int
97 = "ml_postprocess";;
98 external pagebbox : opaque -> (int * int * int * int) = "ml_getpagebox";;
99 external platform : unit -> platform = "ml_platform";;
100 external setaalevel : int -> unit = "ml_setaalevel";;
101 external realloctexts : int -> bool = "ml_realloctexts";;
102 external findlink : opaque -> linkdir -> link = "ml_findlink";;
103 external getlink : opaque -> int -> under = "ml_getlink";;
104 external getlinkrect : opaque -> int -> irect = "ml_getlinkrect";;
105 external getlinkcount : opaque -> int = "ml_getlinkcount";;
106 external findpwl : int -> int -> pagewithlinks = "ml_find_page_with_links"
107 external popen : string -> (Unix.file_descr * int) list -> unit = "ml_popen";;
108 external getpbo : width -> height -> colorspace -> string = "ml_getpbo";;
109 external freepbo : string -> unit = "ml_freepbo";;
110 external unmappbo : string -> unit = "ml_unmappbo";;
111 external pbousable : unit -> bool = "ml_pbo_usable";;
112 external unproject : opaque -> int -> int -> (int * int) option
113 = "ml_unproject";;
114 external drawtile : tileparams -> opaque -> unit = "ml_drawtile";;
116 let platform_to_string = function
117 | Punknown -> "unknown"
118 | Plinux -> "Linux"
119 | Posx -> "OSX"
120 | Psun -> "Sun"
121 | Pfreebsd -> "FreeBSD"
122 | Pdragonflybsd -> "DragonflyBSD"
123 | Popenbsd -> "OpenBSD"
124 | Pnetbsd -> "NetBSD"
125 | Pcygwin -> "Cygwin"
128 let platform = platform ();;
130 let now = Unix.gettimeofday;;
132 let popen cmd fda =
133 if platform = Pcygwin
134 then (
135 let sh = "/bin/sh" in
136 let args = [|sh; "-c"; cmd|] in
137 let rec std si so se = function
138 | [] -> si, so, se
139 | (fd, 0) :: rest -> std fd so se rest
140 | (fd, -1) :: rest ->
141 Unix.set_close_on_exec fd;
142 std si so se rest
143 | (_, n) :: _ ->
144 failwith ("unexpected fdn in cygwin popen " ^ string_of_int n)
146 let si, so, se = std Unix.stdin Unix.stdout Unix.stderr fda in
147 ignore (Unix.create_process sh args si so se)
149 else popen cmd fda;
152 type mpos = int * int
153 and mstate =
154 | Msel of (mpos * mpos)
155 | Mpan of mpos
156 | Mscrolly | Mscrollx
157 | Mzoom of (int * int)
158 | Mzoomrect of (mpos * mpos)
159 | Mnone
162 type textentry = string * string * onhist option * onkey * ondone * cancelonempty
163 and onkey = string -> int -> te
164 and ondone = string -> unit
165 and histcancel = unit -> unit
166 and onhist = ((histcmd -> string) * histcancel)
167 and histcmd = HCnext | HCprev | HCfirst | HClast
168 and cancelonempty = bool
169 and te =
170 | TEstop
171 | TEdone of string
172 | TEcont of string
173 | TEswitch of textentry
176 type 'a circbuf =
177 { store : 'a array
178 ; mutable rc : int
179 ; mutable wc : int
180 ; mutable len : int
184 let bound v minv maxv =
185 max minv (min maxv v);
188 let cbnew n v =
189 { store = Array.create n v
190 ; rc = 0
191 ; wc = 0
192 ; len = 0
196 let cbcap b = Array.length b.store;;
198 let cbput b v =
199 let cap = cbcap b in
200 b.store.(b.wc) <- v;
201 b.wc <- (b.wc + 1) mod cap;
202 b.rc <- b.wc;
203 b.len <- min (b.len + 1) cap;
206 let cbempty b = b.len = 0;;
208 let cbgetg b circular dir =
209 if cbempty b
210 then b.store.(0)
211 else
212 let rc = b.rc + dir in
213 let rc =
214 if circular
215 then (
216 if rc = -1
217 then b.len-1
218 else (
219 if rc >= b.len
220 then 0
221 else rc
224 else bound rc 0 (b.len-1)
226 b.rc <- rc;
227 b.store.(rc);
230 let cbget b = cbgetg b false;;
231 let cbgetc b = cbgetg b true;;
233 let drawstring size x y s =
234 Gl.enable `blend;
235 Gl.enable `texture_2d;
236 GlFunc.blend_func `src_alpha `one_minus_src_alpha;
237 ignore (drawstr size x y s);
238 Gl.disable `blend;
239 Gl.disable `texture_2d;
242 let drawstring1 size x y s =
243 drawstr size x y s;
246 let drawstring2 size x y fmt =
247 Printf.kprintf (drawstring size (x+1) (y+size+1)) fmt
250 type page =
251 { pageno : int
252 ; pagedimno : int
253 ; pagew : int
254 ; pageh : int
255 ; pagex : int
256 ; pagey : int
257 ; pagevw : int
258 ; pagevh : int
259 ; pagedispx : int
260 ; pagedispy : int
261 ; pagecol : int
265 let debugl l =
266 dolog "l %d dim=%d {" l.pageno l.pagedimno;
267 dolog " WxH %dx%d" l.pagew l.pageh;
268 dolog " vWxH %dx%d" l.pagevw l.pagevh;
269 dolog " pagex,y %d,%d" l.pagex l.pagey;
270 dolog " dispx,y %d,%d" l.pagedispx l.pagedispy;
271 dolog " column %d" l.pagecol;
272 dolog "}";
275 let debugrect (x0, y0, x1, y1, x2, y2, x3, y3) =
276 dolog "rect {";
277 dolog " x0,y0=(% f, % f)" x0 y0;
278 dolog " x1,y1=(% f, % f)" x1 y1;
279 dolog " x2,y2=(% f, % f)" x2 y2;
280 dolog " x3,y3=(% f, % f)" x3 y3;
281 dolog "}";
284 type multicolumns = multicol * pagegeom
285 and singlecolumn = pagegeom
286 and splitcolumns = columncount * pagegeom
287 and pagegeom = ((pdimno * x * y * (pageno * width * height * leftx)) array)
288 and multicol = columncount * covercount * covercount
289 and pdimno = int
290 and columncount = int
291 and covercount = int;;
293 type conf =
294 { mutable scrollbw : int
295 ; mutable scrollh : int
296 ; mutable icase : bool
297 ; mutable preload : bool
298 ; mutable pagebias : int
299 ; mutable verbose : bool
300 ; mutable debug : bool
301 ; mutable scrollstep : int
302 ; mutable hscrollstep : int
303 ; mutable maxhfit : bool
304 ; mutable crophack : bool
305 ; mutable autoscrollstep : int
306 ; mutable maxwait : float option
307 ; mutable hlinks : bool
308 ; mutable underinfo : bool
309 ; mutable interpagespace : interpagespace
310 ; mutable zoom : float
311 ; mutable presentation : bool
312 ; mutable angle : angle
313 ; mutable cwinw : int
314 ; mutable cwinh : int
315 ; mutable savebmarks : bool
316 ; mutable fitmodel : fitmodel
317 ; mutable trimmargins : trimmargins
318 ; mutable trimfuzz : irect
319 ; mutable memlimit : memsize
320 ; mutable texcount : texcount
321 ; mutable sliceheight : sliceheight
322 ; mutable thumbw : width
323 ; mutable jumpback : bool
324 ; mutable bgcolor : (float * float * float)
325 ; mutable bedefault : bool
326 ; mutable scrollbarinpm : bool
327 ; mutable tilew : int
328 ; mutable tileh : int
329 ; mutable mustoresize : memsize
330 ; mutable checkers : bool
331 ; mutable aalevel : int
332 ; mutable urilauncher : string
333 ; mutable pathlauncher : string
334 ; mutable colorspace : colorspace
335 ; mutable invert : bool
336 ; mutable colorscale : float
337 ; mutable redirectstderr : bool
338 ; mutable ghyllscroll : (int * int * int) option
339 ; mutable columns : columns
340 ; mutable beyecolumns : columncount option
341 ; mutable selcmd : string
342 ; mutable updatecurs : bool
343 ; mutable keyhashes : (string * keyhash) list
344 ; mutable hfsize : int
345 ; mutable pgscale : float
346 ; mutable usepbo : bool
347 ; mutable wheelbypage : bool
348 ; mutable stcmd : string
350 and columns =
351 | Csingle of singlecolumn
352 | Cmulti of multicolumns
353 | Csplit of splitcolumns
356 type anchor = pageno * top * dtop;;
358 type outline = string * int * anchor;;
360 type rect = float * float * float * float * float * float * float * float;;
362 type tile = opaque * pixmapsize * elapsed
363 and elapsed = float;;
364 type pagemapkey = pageno * gen;;
365 type tilemapkey = pageno * gen * colorspace * angle * width * height * col * row
366 and row = int
367 and col = int;;
369 let emptyanchor = (0, 0.0, 0.0);;
371 type infochange = | Memused | Docinfo | Pdim;;
373 class type uioh = object
374 method display : unit
375 method key : int -> int -> uioh
376 method button : int -> bool -> int -> int -> int -> uioh
377 method motion : int -> int -> uioh
378 method pmotion : int -> int -> uioh
379 method infochanged : infochange -> unit
380 method scrollpw : (int * float * float)
381 method scrollph : (int * float * float)
382 method modehash : keyhash
383 method eformsgs : bool
384 end;;
386 type mode =
387 | Birdseye of (conf * leftx * pageno * pageno * anchor)
388 | Textentry of (textentry * onleave)
389 | View
390 | LinkNav of linktarget
391 and onleave = leavetextentrystatus -> unit
392 and leavetextentrystatus = | Cancel | Confirm
393 and helpitem = string * int * action
394 and action =
395 | Noaction
396 | Action of (uioh -> uioh)
397 and linktarget =
398 | Ltexact of (pageno * int)
399 | Ltgendir of int
402 let isbirdseye = function Birdseye _ -> true | _ -> false;;
403 let istextentry = function Textentry _ -> true | _ -> false;;
405 type currently =
406 | Idle
407 | Loading of (page * gen)
408 | Tiling of (
409 page * opaque * colorspace * angle * gen * col * row * width * height
411 | Outlining of outline list
414 let emptykeyhash = Hashtbl.create 0;;
415 let nouioh : uioh = object (self)
416 method display = ()
417 method key _ _ = self
418 method button _ _ _ _ _ = self
419 method motion _ _ = self
420 method pmotion _ _ = self
421 method infochanged _ = ()
422 method scrollpw = (0, nan, nan)
423 method scrollph = (0, nan, nan)
424 method modehash = emptykeyhash
425 method eformsgs = false
426 end;;
428 type state =
429 { mutable sr : Unix.file_descr
430 ; mutable sw : Unix.file_descr
431 ; mutable wsfd : Unix.file_descr
432 ; mutable errfd : Unix.file_descr option
433 ; mutable stderr : Unix.file_descr
434 ; mutable errmsgs : Buffer.t
435 ; mutable newerrmsgs : bool
436 ; mutable w : int
437 ; mutable x : int
438 ; mutable y : int
439 ; mutable scrollw : int
440 ; mutable hscrollh : int
441 ; mutable anchor : anchor
442 ; mutable ranchors : (string * string * anchor * string) list
443 ; mutable maxy : int
444 ; mutable layout : page list
445 ; pagemap : (pagemapkey, opaque) Hashtbl.t
446 ; tilemap : (tilemapkey, tile) Hashtbl.t
447 ; tilelru : (tilemapkey * opaque * pixmapsize) Queue.t
448 ; mutable pdims : (pageno * width * height * leftx) list
449 ; mutable pagecount : int
450 ; mutable currently : currently
451 ; mutable mstate : mstate
452 ; mutable searchpattern : string
453 ; mutable rects : (pageno * recttype * rect) list
454 ; mutable rects1 : (pageno * recttype * rect) list
455 ; mutable text : string
456 ; mutable winstate : Wsi.winstate list
457 ; mutable mode : mode
458 ; mutable uioh : uioh
459 ; mutable outlines : outline array
460 ; mutable bookmarks : outline list
461 ; mutable path : string
462 ; mutable password : string
463 ; mutable nameddest : string
464 ; mutable geomcmds : (string * ((string * (unit -> unit)) list))
465 ; mutable memused : memsize
466 ; mutable gen : gen
467 ; mutable throttle : (page list * int * float) option
468 ; mutable autoscroll : int option
469 ; mutable ghyll : (int option -> unit)
470 ; mutable help : helpitem array
471 ; mutable docinfo : (int * string) list
472 ; mutable texid : GlTex.texture_id option
473 ; hists : hists
474 ; mutable prevzoom : float
475 ; mutable progress : float
476 ; mutable redisplay : bool
477 ; mutable mpos : mpos
478 ; mutable keystate : keystate
479 ; mutable glinks : bool
480 ; mutable prevcolumns : (columns * float) option
481 ; mutable winw : int
482 ; mutable winh : int
483 ; mutable reprf : (unit -> unit)
484 ; mutable origin : string
486 and hists =
487 { pat : string circbuf
488 ; pag : string circbuf
489 ; nav : anchor circbuf
490 ; sel : string circbuf
494 let defconf =
495 { scrollbw = 7
496 ; scrollh = 12
497 ; icase = true
498 ; preload = true
499 ; pagebias = 0
500 ; verbose = false
501 ; debug = false
502 ; scrollstep = 24
503 ; hscrollstep = 24
504 ; maxhfit = true
505 ; crophack = false
506 ; autoscrollstep = 2
507 ; maxwait = None
508 ; hlinks = false
509 ; underinfo = false
510 ; interpagespace = 2
511 ; zoom = 1.0
512 ; presentation = false
513 ; angle = 0
514 ; cwinw = 900
515 ; cwinh = 900
516 ; savebmarks = true
517 ; fitmodel = FitProportional
518 ; trimmargins = false
519 ; trimfuzz = (0,0,0,0)
520 ; memlimit = 32 lsl 20
521 ; texcount = 256
522 ; sliceheight = 24
523 ; thumbw = 76
524 ; jumpback = true
525 ; bgcolor = (0.5, 0.5, 0.5)
526 ; bedefault = false
527 ; scrollbarinpm = true
528 ; tilew = 2048
529 ; tileh = 2048
530 ; mustoresize = 256 lsl 20
531 ; checkers = true
532 ; aalevel = 8
533 ; urilauncher =
534 (match platform with
535 | Plinux | Pfreebsd | Pdragonflybsd
536 | Popenbsd | Pnetbsd | Psun -> "xdg-open \"%s\""
537 | Posx -> "open \"%s\""
538 | Pcygwin -> "cygstart \"%s\""
539 | Punknown -> "echo %s")
540 ; pathlauncher = "lp \"%s\""
541 ; selcmd =
542 (match platform with
543 | Plinux | Pfreebsd | Pdragonflybsd
544 | Popenbsd | Pnetbsd | Psun -> "xsel -i"
545 | Posx -> "pbcopy"
546 | Pcygwin -> "wsel"
547 | Punknown -> "cat")
548 ; colorspace = Rgb
549 ; invert = false
550 ; colorscale = 1.0
551 ; redirectstderr = false
552 ; ghyllscroll = None
553 ; columns = Csingle [||]
554 ; beyecolumns = None
555 ; updatecurs = false
556 ; hfsize = 12
557 ; pgscale = 1.0
558 ; usepbo = false
559 ; wheelbypage = false
560 ; stcmd = "echo SyncTex"
561 ; keyhashes =
562 let mk n = (n, Hashtbl.create 1) in
563 [ mk "global"
564 ; mk "info"
565 ; mk "help"
566 ; mk "outline"
567 ; mk "listview"
568 ; mk "birdseye"
569 ; mk "textentry"
570 ; mk "links"
571 ; mk "view"
576 let wtmode = ref false;;
578 let findkeyhash c name =
579 try List.assoc name c.keyhashes
580 with Not_found -> failwith ("invalid mode name `" ^ name ^ "'")
583 let conf = { defconf with angle = defconf.angle };;
585 let pgscale h = truncate (float h *. conf.pgscale);;
587 type fontstate =
588 { mutable fontsize : int
589 ; mutable wwidth : float
590 ; mutable maxrows : int
594 let fstate =
595 { fontsize = 14
596 ; wwidth = nan
597 ; maxrows = -1
601 let geturl s =
602 let colonpos = try String.index s ':' with Not_found -> -1 in
603 let len = String.length s in
604 if colonpos >= 0 && colonpos + 3 < len
605 then (
606 if s.[colonpos+1] = '/' && s.[colonpos+2] = '/'
607 then
608 let schemestartpos =
609 try String.rindex_from s colonpos ' '
610 with Not_found -> -1
612 let scheme =
613 String.sub s (schemestartpos+1) (colonpos-1-schemestartpos)
615 match scheme with
616 | "http" | "ftp" | "mailto" ->
617 let epos =
618 try String.index_from s colonpos ' '
619 with Not_found -> len
621 String.sub s (schemestartpos+1) (epos-1-schemestartpos)
622 | _ -> ""
623 else ""
625 else ""
628 let gotouri uri =
629 if String.length conf.urilauncher = 0
630 then print_endline uri
631 else (
632 let url = geturl uri in
633 if String.length url = 0
634 then print_endline uri
635 else
636 let re = Str.regexp "%s" in
637 let command = Str.global_replace re url conf.urilauncher in
638 try popen command []
639 with exn ->
640 Printf.eprintf
641 "failed to execute `%s': %s\n" command (exntos exn);
642 flush stderr;
646 let version () =
647 Printf.sprintf "llpp version %s (%s/%dbit, ocaml %s)" Help.version
648 (platform_to_string platform) Sys.word_size Sys.ocaml_version
651 let makehelp () =
652 let strings = version () :: "" :: Help.keys in
653 Array.of_list (
654 List.map (fun s ->
655 let url = geturl s in
656 if String.length url > 0
657 then (s, 0, Action (fun u -> gotouri url; u))
658 else (s, 0, Noaction)
659 ) strings);
662 let noghyll _ = ();;
663 let firstgeomcmds = "", [];;
664 let noreprf () = ();;
666 let state =
667 { sr = Unix.stdin
668 ; sw = Unix.stdin
669 ; wsfd = Unix.stdin
670 ; errfd = None
671 ; stderr = Unix.stderr
672 ; errmsgs = Buffer.create 0
673 ; newerrmsgs = false
674 ; x = 0
675 ; y = 0
676 ; w = 0
677 ; scrollw = 0
678 ; hscrollh = 0
679 ; anchor = emptyanchor
680 ; ranchors = []
681 ; layout = []
682 ; maxy = max_int
683 ; tilelru = Queue.create ()
684 ; pagemap = Hashtbl.create 10
685 ; tilemap = Hashtbl.create 10
686 ; pdims = []
687 ; pagecount = 0
688 ; currently = Idle
689 ; mstate = Mnone
690 ; rects = []
691 ; rects1 = []
692 ; text = ""
693 ; mode = View
694 ; winstate = []
695 ; searchpattern = ""
696 ; outlines = [||]
697 ; bookmarks = []
698 ; path = ""
699 ; password = ""
700 ; nameddest = ""
701 ; geomcmds = firstgeomcmds
702 ; hists =
703 { nav = cbnew 10 emptyanchor
704 ; pat = cbnew 10 ""
705 ; pag = cbnew 10 ""
706 ; sel = cbnew 10 ""
708 ; memused = 0
709 ; gen = 0
710 ; throttle = None
711 ; autoscroll = None
712 ; ghyll = noghyll
713 ; help = makehelp ()
714 ; docinfo = []
715 ; texid = None
716 ; prevzoom = 1.0
717 ; progress = -1.0
718 ; uioh = nouioh
719 ; redisplay = true
720 ; mpos = (-1, -1)
721 ; keystate = KSnone
722 ; glinks = false
723 ; prevcolumns = None
724 ; winw = -1
725 ; winh = -1
726 ; reprf = noreprf
727 ; origin = ""
731 let setfontsize n =
732 fstate.fontsize <- n;
733 fstate.wwidth <- measurestr fstate.fontsize "w";
734 fstate.maxrows <- (state.winh - fstate.fontsize - 1) / (fstate.fontsize + 1);
737 let vlog fmt =
738 if conf.verbose
739 then
740 Printf.kprintf prerr_endline fmt
741 else
742 Printf.kprintf ignore fmt
745 let launchpath () =
746 if String.length conf.pathlauncher = 0
747 then print_endline state.path
748 else (
749 let re = Str.regexp "%s" in
750 let command = Str.global_replace re state.path conf.pathlauncher in
751 try popen command []
752 with exn ->
753 Printf.eprintf "failed to execute `%s': %s\n" command (exntos exn);
754 flush stderr;
758 module Ne = struct
759 type 'a t = | Res of 'a | Exn of exn;;
761 let pipe () =
762 try Res (Unix.pipe ())
763 with exn -> Exn exn
766 let clo fd f =
767 try tempfailureretry Unix.close fd
768 with exn -> f (exntos exn)
771 let dup fd =
772 try Res (tempfailureretry Unix.dup fd)
773 with exn -> Exn exn
776 let dup2 fd1 fd2 =
777 try Res (tempfailureretry (Unix.dup2 fd1) fd2)
778 with exn -> Exn exn
780 end;;
782 let redirectstderr () =
783 let clofail what errmsg = dolog "failed to close %s: %s" what errmsg in
784 if conf.redirectstderr
785 then
786 match Ne.pipe () with
787 | Ne.Exn exn ->
788 dolog "failed to create stderr redirection pipes: %s" (exntos exn)
790 | Ne.Res (r, w) ->
791 begin match Ne.dup Unix.stderr with
792 | Ne.Exn exn ->
793 dolog "failed to dup stderr: %s" (exntos exn);
794 Ne.clo r (clofail "pipe/r");
795 Ne.clo w (clofail "pipe/w");
797 | Ne.Res dupstderr ->
798 begin match Ne.dup2 w Unix.stderr with
799 | Ne.Exn exn ->
800 dolog "failed to dup2 to stderr: %s" (exntos exn);
801 Ne.clo dupstderr (clofail "stderr duplicate");
802 Ne.clo r (clofail "redir pipe/r");
803 Ne.clo w (clofail "redir pipe/w");
805 | Ne.Res () ->
806 state.stderr <- dupstderr;
807 state.errfd <- Some r;
808 end;
810 else (
811 state.newerrmsgs <- false;
812 begin match state.errfd with
813 | Some fd ->
814 begin match Ne.dup2 state.stderr Unix.stderr with
815 | Ne.Exn exn ->
816 dolog "failed to dup2 original stderr: %s" (exntos exn)
817 | Ne.Res () ->
818 Ne.clo fd (clofail "dup of stderr");
819 state.errfd <- None;
820 end;
821 | None -> ()
822 end;
823 prerr_string (Buffer.contents state.errmsgs);
824 flush stderr;
825 Buffer.clear state.errmsgs;
829 module G =
830 struct
831 let postRedisplay who =
832 if conf.verbose
833 then prerr_endline ("redisplay for " ^ who);
834 state.redisplay <- true;
836 end;;
838 let getopaque pageno =
839 try Some (Hashtbl.find state.pagemap (pageno, state.gen))
840 with Not_found -> None
843 let putopaque pageno opaque =
844 Hashtbl.replace state.pagemap (pageno, state.gen) opaque
847 let pagetranslatepoint l x y =
848 let dy = y - l.pagedispy in
849 let y = dy + l.pagey in
850 let dx = x - l.pagedispx in
851 let x = dx + l.pagex in
852 (x, y);
855 let onppundermouse g x y d =
856 let rec f = function
857 | l :: rest ->
858 begin match getopaque l.pageno with
859 | Some opaque ->
860 let x0 = l.pagedispx in
861 let x1 = x0 + l.pagevw in
862 let y0 = l.pagedispy in
863 let y1 = y0 + l.pagevh in
864 if y >= y0 && y <= y1 && x >= x0 && x <= x1
865 then
866 let px, py = pagetranslatepoint l x y in
867 match g opaque l px py with
868 | Some res -> res
869 | None -> f rest
870 else f rest
871 | _ ->
872 f rest
874 | [] -> d
876 f state.layout
879 let getunder x y =
880 let g opaque _ px py =
881 match whatsunder opaque px py with
882 | Unone -> None
883 | under -> Some under
885 onppundermouse g x y Unone
888 let unproject x y =
889 let g opaque l x y =
890 match unproject opaque x y with
891 | Some (x, y) -> Some (Some (l.pageno, x, y))
892 | None -> None
894 onppundermouse g x y None;
897 let showtext c s =
898 state.text <- Printf.sprintf "%c%s" c s;
899 G.postRedisplay "showtext";
902 let selstring s =
903 match Ne.pipe () with
904 | Ne.Exn exn ->
905 showtext '!' (Printf.sprintf "pipe failed: %s" (exntos exn))
906 | Ne.Res (r, w) ->
907 let popened =
908 try popen conf.selcmd [r, 0; w, -1]; true
909 with exn ->
910 showtext '!'
911 (Printf.sprintf "failed to execute %s: %s"
912 conf.selcmd (exntos exn));
913 false
915 let clo cap fd =
916 Ne.clo fd (fun msg ->
917 showtext '!' (Printf.sprintf "failed to close %s: %s" cap msg)
920 if popened
921 then
922 (try
923 let l = String.length s in
924 let n = tempfailureretry (Unix.write w s 0) l in
925 if n != l
926 then
927 showtext '!'
928 (Printf.sprintf
929 "failed to write %d characters to sel pipe, wrote %d"
932 with exn ->
933 showtext '!'
934 (Printf.sprintf "failed to write to sel pipe: %s"
935 (exntos exn)
938 else dolog "%s" s;
939 clo "pipe/r" r;
940 clo "pipe/w" w;
943 let undertext = function
944 | Unone -> "none"
945 | Ulinkuri s -> s
946 | Ulinkgoto (pageno, _) -> Printf.sprintf "%s: page %d" state.path (pageno+1)
947 | Utext s -> "font: " ^ s
948 | Uunexpected s -> "unexpected: " ^ s
949 | Ulaunch s -> "launch: " ^ s
950 | Unamed s -> "named: " ^ s
951 | Uremote (filename, pageno) ->
952 Printf.sprintf "%s: page %d" filename (pageno+1)
955 let updateunder x y =
956 match getunder x y with
957 | Unone -> Wsi.setcursor Wsi.CURSOR_INHERIT
958 | Ulinkuri uri ->
959 if conf.underinfo then showtext 'u' ("ri: " ^ uri);
960 Wsi.setcursor Wsi.CURSOR_INFO
961 | Ulinkgoto (pageno, _) ->
962 if conf.underinfo
963 then showtext 'p' ("age: " ^ string_of_int (pageno+1));
964 Wsi.setcursor Wsi.CURSOR_INFO
965 | Utext s ->
966 if conf.underinfo then showtext 'f' ("ont: " ^ s);
967 Wsi.setcursor Wsi.CURSOR_TEXT
968 | Uunexpected s ->
969 if conf.underinfo then showtext 'u' ("nexpected: " ^ s);
970 Wsi.setcursor Wsi.CURSOR_INHERIT
971 | Ulaunch s ->
972 if conf.underinfo then showtext 'l' ("aunch: " ^ s);
973 Wsi.setcursor Wsi.CURSOR_INHERIT
974 | Unamed s ->
975 if conf.underinfo then showtext 'n' ("amed: " ^ s);
976 Wsi.setcursor Wsi.CURSOR_INHERIT
977 | Uremote (filename, pageno) ->
978 if conf.underinfo then showtext 'r'
979 (Printf.sprintf "emote: %s (%d)" filename (pageno+1));
980 Wsi.setcursor Wsi.CURSOR_INFO
983 let showlinktype under =
984 if conf.underinfo
985 then
986 match under with
987 | Unone -> ()
988 | under ->
989 let s = undertext under in
990 showtext ' ' s
993 let addchar s c =
994 let b = Buffer.create (String.length s + 1) in
995 Buffer.add_string b s;
996 Buffer.add_char b c;
997 Buffer.contents b;
1000 let colorspace_of_string s =
1001 match String.lowercase s with
1002 | "rgb" -> Rgb
1003 | "bgr" -> Bgr
1004 | "gray" -> Gray
1005 | _ -> failwith "invalid colorspace"
1008 let int_of_colorspace = function
1009 | Rgb -> 0
1010 | Bgr -> 1
1011 | Gray -> 2
1014 let colorspace_of_int = function
1015 | 0 -> Rgb
1016 | 1 -> Bgr
1017 | 2 -> Gray
1018 | n -> failwith ("invalid colorspace index " ^ string_of_int n)
1021 let colorspace_to_string = function
1022 | Rgb -> "rgb"
1023 | Bgr -> "bgr"
1024 | Gray -> "gray"
1027 let fitmodel_of_string s =
1028 match String.lowercase s with
1029 | "width" -> FitWidth
1030 | "proportional" -> FitProportional
1031 | "page" -> FitPage
1032 | _ -> failwith "invalid fit model"
1035 let int_of_fitmodel = function
1036 | FitWidth -> 0
1037 | FitProportional -> 1
1038 | FitPage -> 2
1041 let fitmodel_of_int = function
1042 | 0 -> FitWidth
1043 | 1 -> FitProportional
1044 | 2 -> FitPage
1045 | n -> failwith ("invalid fit model index " ^ string_of_int n)
1048 let fitmodel_to_string = function
1049 | FitWidth -> "width"
1050 | FitProportional -> "proportional"
1051 | FitPage -> "page"
1054 let intentry_with_suffix text key =
1055 let c =
1056 if key >= 32 && key < 127
1057 then Char.chr key
1058 else '\000'
1060 match Char.lowercase c with
1061 | '0' .. '9' ->
1062 let text = addchar text c in
1063 TEcont text
1065 | 'k' | 'm' | 'g' ->
1066 let text = addchar text c in
1067 TEcont text
1069 | _ ->
1070 state.text <- Printf.sprintf "invalid char (%d, `%c')" key c;
1071 TEcont text
1074 let multicolumns_to_string (n, a, b) =
1075 if a = 0 && b = 0
1076 then Printf.sprintf "%d" n
1077 else Printf.sprintf "%d,%d,%d" n a b;
1080 let multicolumns_of_string s =
1082 (int_of_string s, 0, 0)
1083 with _ ->
1084 Scanf.sscanf s "%u,%u,%u" (fun n a b ->
1085 if a > 1 || b > 1
1086 then failwith "subtly broken"; (n, a, b)
1090 let readcmd fd =
1091 let s = "xxxx" in
1092 let n = tempfailureretry (Unix.read fd s 0) 4 in
1093 if n != 4 then failwith "incomplete read(len)";
1094 let len = 0
1095 lor (Char.code s.[0] lsl 24)
1096 lor (Char.code s.[1] lsl 16)
1097 lor (Char.code s.[2] lsl 8)
1098 lor (Char.code s.[3] lsl 0)
1100 let s = String.create len in
1101 let n = tempfailureretry (Unix.read fd s 0) len in
1102 if n != len then failwith "incomplete read(data)";
1106 let btod b = if b then 1 else 0;;
1108 let wcmd fmt =
1109 let b = Buffer.create 16 in
1110 Buffer.add_string b "llll";
1111 Printf.kbprintf
1112 (fun b ->
1113 let s = Buffer.contents b in
1114 let n = String.length s in
1115 let len = n - 4 in
1116 (* dolog "wcmd %S" (String.sub s 4 len); *)
1117 s.[0] <- Char.chr ((len lsr 24) land 0xff);
1118 s.[1] <- Char.chr ((len lsr 16) land 0xff);
1119 s.[2] <- Char.chr ((len lsr 8) land 0xff);
1120 s.[3] <- Char.chr (len land 0xff);
1121 let n' = tempfailureretry (Unix.write state.sw s 0) n in
1122 if n' != n then failwith "write failed";
1123 ) b fmt;
1126 let calcips h =
1127 let d = state.winh - h in
1128 max conf.interpagespace ((d + 1) / 2)
1131 let rowyh (c, coverA, coverB) b n =
1132 if c = 1 || (n < coverA || n >= state.pagecount - coverB)
1133 then
1134 let _, _, vy, (_, _, h, _) = b.(n) in
1135 (vy, h)
1136 else
1137 let n' = n - coverA in
1138 let d = n' mod c in
1139 let s = n - d in
1140 let e = min state.pagecount (s + c) in
1141 let rec find m miny maxh = if m = e then miny, maxh else
1142 let _, _, y, (_, _, h, _) = b.(m) in
1143 let miny = min miny y in
1144 let maxh = max maxh h in
1145 find (m+1) miny maxh
1146 in find s max_int 0
1149 let calcheight () =
1150 match conf.columns with
1151 | Cmulti ((_, _, _) as cl, b) ->
1152 if Array.length b > 0
1153 then
1154 let y, h = rowyh cl b (Array.length b - 1) in
1155 y + h + (if conf.presentation then calcips h else 0)
1156 else 0
1157 | Csingle b ->
1158 if Array.length b > 0
1159 then
1160 let (_, _, y, (_, _, h, _)) = b.(Array.length b - 1) in
1161 y + h + (if conf.presentation then calcips h else 0)
1162 else 0
1163 | Csplit (_, b) ->
1164 if Array.length b > 0
1165 then
1166 let (_, _, y, (_, _, h, _)) = b.(Array.length b - 1) in
1167 y + h
1168 else 0
1171 let getpageyh pageno =
1172 let pageno = bound pageno 0 (state.pagecount-1) in
1173 match conf.columns with
1174 | Csingle b ->
1175 if Array.length b = 0
1176 then 0, 0
1177 else
1178 let (_, _, y, (_, _, h, _)) = b.(pageno) in
1179 let y =
1180 if conf.presentation
1181 then y - calcips h
1182 else y
1184 y, h
1185 | Cmulti (cl, b) ->
1186 if Array.length b = 0
1187 then 0, 0
1188 else
1189 let y, h = rowyh cl b pageno in
1190 let y =
1191 if conf.presentation
1192 then y - calcips h
1193 else y
1195 y, h
1196 | Csplit (c, b) ->
1197 if Array.length b = 0
1198 then 0, 0
1199 else
1200 let n = pageno*c in
1201 let (_, _, y, (_, _, h, _)) = b.(n) in
1202 y, h
1205 let getpagedim pageno =
1206 let rec f ppdim l =
1207 match l with
1208 | (n, _, _, _) as pdim :: rest ->
1209 if n >= pageno
1210 then (if n = pageno then pdim else ppdim)
1211 else f pdim rest
1213 | [] -> ppdim
1215 f (-1, -1, -1, -1) state.pdims
1218 let getpagey pageno = fst (getpageyh pageno);;
1220 let nogeomcmds cmds =
1221 match cmds with
1222 | s, [] -> String.length s = 0
1223 | _ -> false
1226 let page_of_y y =
1227 let ((c, coverA, coverB) as cl), b =
1228 match conf.columns with
1229 | Csingle b -> (1, 0, 0), b
1230 | Cmulti (c, b) -> c, b
1231 | Csplit (_, b) -> (1, 0, 0), b
1233 if Array.length b = 0
1234 then -1
1235 else
1236 let rec bsearch nmin nmax =
1237 if nmin > nmax
1238 then bound nmin 0 (state.pagecount-1)
1239 else
1240 let n = (nmax + nmin) / 2 in
1241 let vy, h = rowyh cl b n in
1242 let y0, y1 =
1243 if conf.presentation
1244 then
1245 let ips = calcips h in
1246 let y0 = vy - ips in
1247 let y1 = vy + h + ips in
1248 y0, y1
1249 else (
1250 if n = 0
1251 then 0, vy + h + conf.interpagespace
1252 else
1253 let y0 = vy - conf.interpagespace in
1254 y0, y0 + h + conf.interpagespace
1257 if y >= y0 && y < y1
1258 then (
1259 if c = 1
1260 then n
1261 else (
1262 if n > coverA
1263 then
1264 if n < state.pagecount - coverB
1265 then ((n-coverA)/c)*c + coverA
1266 else n
1267 else n
1270 else (
1271 if y > y0
1272 then bsearch (n+1) nmax
1273 else bsearch nmin (n-1)
1276 let r = bsearch 0 (state.pagecount-1) in
1280 let layoutN ((columns, coverA, coverB), b) y sh =
1281 let sh = sh - state.hscrollh in
1282 let rec fold accu n =
1283 if n = Array.length b
1284 then accu
1285 else
1286 let pdimno, dx, vy, (_, w, h, xoff) = b.(n) in
1287 if (vy - y) > sh &&
1288 (n = coverA - 1
1289 || n = state.pagecount - coverB
1290 || (n - coverA) mod columns = columns - 1)
1291 then accu
1292 else
1293 let accu =
1294 if vy + h > y
1295 then
1296 let pagey = max 0 (y - vy) in
1297 let pagedispy = if pagey > 0 then 0 else vy - y in
1298 let pagedispx, pagex =
1299 let pdx =
1300 if n = coverA - 1 || n = state.pagecount - coverB
1301 then state.x + (state.winw - state.scrollw - w) / 2
1302 else dx + xoff + state.x
1304 if pdx < 0
1305 then 0, -pdx
1306 else pdx, 0
1308 let pagevw =
1309 let vw = state.winw - state.scrollw - pagedispx in
1310 let pw = w - pagex in
1311 min vw pw
1313 let pagevh = min (h - pagey) (sh - pagedispy) in
1314 if pagevw > 0 && pagevh > 0
1315 then
1316 let e =
1317 { pageno = n
1318 ; pagedimno = pdimno
1319 ; pagew = w
1320 ; pageh = h
1321 ; pagex = pagex
1322 ; pagey = pagey
1323 ; pagevw = pagevw
1324 ; pagevh = pagevh
1325 ; pagedispx = pagedispx
1326 ; pagedispy = pagedispy
1327 ; pagecol = 0
1330 e :: accu
1331 else
1332 accu
1333 else
1334 accu
1336 fold accu (n+1)
1338 List.rev (fold [] (page_of_y y));
1341 let layoutS (columns, b) y sh =
1342 let sh = sh - state.hscrollh in
1343 let rec fold accu n =
1344 if n = Array.length b
1345 then accu
1346 else
1347 let pdimno, px, vy, (_, pagew, pageh, xoff) = b.(n) in
1348 if (vy - y) > sh
1349 then accu
1350 else
1351 let accu =
1352 if vy + pageh > y
1353 then
1354 let x = xoff + state.x in
1355 let pagey = max 0 (y - vy) in
1356 let pagedispy = if pagey > 0 then 0 else vy - y in
1357 let pagedispx, pagex =
1358 if px = 0
1359 then (
1360 if x < 0
1361 then 0, -x
1362 else x, 0
1364 else (
1365 let px = px - x in
1366 if px < 0
1367 then -px, 0
1368 else 0, px
1371 let pagecolw = pagew/columns in
1372 let pagedispx =
1373 if pagecolw < state.winw
1374 then pagedispx + ((state.winw - state.scrollw - pagecolw) / 2)
1375 else pagedispx
1377 let pagevw =
1378 let vw = state.winw - pagedispx - state.scrollw in
1379 let pw = pagew - pagex in
1380 min vw pw
1382 let pagevw = min pagevw pagecolw in
1383 let pagevh = min (pageh - pagey) (sh - pagedispy) in
1384 if pagevw > 0 && pagevh > 0
1385 then
1386 let e =
1387 { pageno = n/columns
1388 ; pagedimno = pdimno
1389 ; pagew = pagew
1390 ; pageh = pageh
1391 ; pagex = pagex
1392 ; pagey = pagey
1393 ; pagevw = pagevw
1394 ; pagevh = pagevh
1395 ; pagedispx = pagedispx
1396 ; pagedispy = pagedispy
1397 ; pagecol = n mod columns
1400 e :: accu
1401 else
1402 accu
1403 else
1404 accu
1406 fold accu (n+1)
1408 List.rev (fold [] 0)
1411 let layout y sh =
1412 if nogeomcmds state.geomcmds
1413 then
1414 match conf.columns with
1415 | Csingle b -> layoutN ((1, 0, 0), b) y sh
1416 | Cmulti c -> layoutN c y sh
1417 | Csplit s -> layoutS s y sh
1418 else []
1421 let clamp incr =
1422 let y = state.y + incr in
1423 let y = max 0 y in
1424 let y = min y (state.maxy - (if conf.maxhfit then state.winh else 0)) in
1428 let itertiles l f =
1429 let tilex = l.pagex mod conf.tilew in
1430 let tiley = l.pagey mod conf.tileh in
1432 let col = l.pagex / conf.tilew in
1433 let row = l.pagey / conf.tileh in
1435 let rec rowloop row y0 dispy h =
1436 if h = 0
1437 then ()
1438 else (
1439 let dh = conf.tileh - y0 in
1440 let dh = min h dh in
1441 let rec colloop col x0 dispx w =
1442 if w = 0
1443 then ()
1444 else (
1445 let dw = conf.tilew - x0 in
1446 let dw = min w dw in
1448 f col row dispx dispy x0 y0 dw dh;
1449 colloop (col+1) 0 (dispx+dw) (w-dw)
1452 colloop col tilex l.pagedispx l.pagevw;
1453 rowloop (row+1) 0 (dispy+dh) (h-dh)
1456 if l.pagevw > 0 && l.pagevh > 0
1457 then rowloop row tiley l.pagedispy l.pagevh;
1460 let gettileopaque l col row =
1461 let key =
1462 l.pageno, state.gen, conf.colorspace, conf.angle, l.pagew, l.pageh, col, row
1464 try Some (Hashtbl.find state.tilemap key)
1465 with Not_found -> None
1468 let puttileopaque l col row gen colorspace angle opaque size elapsed =
1469 let key = l.pageno, gen, colorspace, angle, l.pagew, l.pageh, col, row in
1470 Hashtbl.add state.tilemap key (opaque, size, elapsed)
1473 let drawtiles l color =
1474 GlDraw.color color;
1475 let f col row x y tilex tiley w h =
1476 match gettileopaque l col row with
1477 | Some (opaque, _, t) ->
1478 let params = x, y, w, h, tilex, tiley in
1479 if conf.invert
1480 then (
1481 Gl.enable `blend;
1482 GlFunc.blend_func `zero `one_minus_src_color;
1484 drawtile params opaque;
1485 if conf.invert
1486 then Gl.disable `blend;
1487 if conf.debug
1488 then (
1489 let s = Printf.sprintf
1490 "%d[%d,%d] %f sec"
1491 l.pageno col row t
1493 let w = measurestr fstate.fontsize s in
1494 GlMisc.push_attrib [`current];
1495 GlDraw.color (0.0, 0.0, 0.0);
1496 GlDraw.rect
1497 (float (x-2), float (y-2))
1498 (float (x+2) +. w, float (y + fstate.fontsize + 2));
1499 GlDraw.color (1.0, 1.0, 1.0);
1500 drawstring fstate.fontsize x (y + fstate.fontsize - 1) s;
1501 GlMisc.pop_attrib ();
1504 | _ ->
1505 let w =
1506 let lw = state.winw - state.scrollw - x in
1507 min lw w
1508 and h =
1509 let lh = state.winh - y in
1510 min lh h
1512 begin match state.texid with
1513 | Some id ->
1514 Gl.enable `texture_2d;
1515 GlTex.bind_texture `texture_2d id;
1516 let x0 = float x
1517 and y0 = float y
1518 and x1 = float (x+w)
1519 and y1 = float (y+h) in
1521 let tw = float w /. 16.0
1522 and th = float h /. 16.0 in
1523 let tx0 = float tilex /. 16.0
1524 and ty0 = float tiley /. 16.0 in
1525 let tx1 = tx0 +. tw
1526 and ty1 = ty0 +. th in
1527 GlDraw.begins `quads;
1528 GlTex.coord2 (tx0, ty0); GlDraw.vertex2 (x0, y0);
1529 GlTex.coord2 (tx0, ty1); GlDraw.vertex2 (x0, y1);
1530 GlTex.coord2 (tx1, ty1); GlDraw.vertex2 (x1, y1);
1531 GlTex.coord2 (tx1, ty0); GlDraw.vertex2 (x1, y0);
1532 GlDraw.ends ();
1534 Gl.disable `texture_2d;
1535 | None ->
1536 GlDraw.color (1.0, 1.0, 1.0);
1537 GlDraw.rect
1538 (float x, float y)
1539 (float (x+w), float (y+h));
1540 end;
1541 if w > 128 && h > fstate.fontsize + 10
1542 then (
1543 GlDraw.color (0.0, 0.0, 0.0);
1544 let c, r =
1545 if conf.verbose
1546 then (col*conf.tilew, row*conf.tileh)
1547 else col, row
1549 drawstring2 fstate.fontsize x y "Loading %d [%d,%d]" l.pageno c r;
1551 GlDraw.color color;
1553 itertiles l f
1556 let pagevisible layout n = List.exists (fun l -> l.pageno = n) layout;;
1558 let tilevisible1 l x y =
1559 let ax0 = l.pagex
1560 and ax1 = l.pagex + l.pagevw
1561 and ay0 = l.pagey
1562 and ay1 = l.pagey + l.pagevh in
1564 let bx0 = x
1565 and by0 = y in
1566 let bx1 = min (bx0 + conf.tilew) l.pagew
1567 and by1 = min (by0 + conf.tileh) l.pageh in
1569 let rx0 = max ax0 bx0
1570 and ry0 = max ay0 by0
1571 and rx1 = min ax1 bx1
1572 and ry1 = min ay1 by1 in
1574 let nonemptyintersection = rx1 > rx0 && ry1 > ry0 in
1575 nonemptyintersection
1578 let tilevisible layout n x y =
1579 let rec findpageinlayout m = function
1580 | l :: rest when l.pageno = n ->
1581 tilevisible1 l x y || (
1582 match conf.columns with
1583 | Csplit (c, _) when c > m -> findpageinlayout (m+1) rest
1584 | _ -> false
1586 | _ :: rest -> findpageinlayout 0 rest
1587 | [] -> false
1589 findpageinlayout 0 layout;
1592 let tileready l x y =
1593 tilevisible1 l x y &&
1594 gettileopaque l (x/conf.tilew) (y/conf.tileh) != None
1597 let tilepage n p layout =
1598 let rec loop = function
1599 | l :: rest ->
1600 if l.pageno = n
1601 then
1602 let f col row _ _ _ _ _ _ =
1603 if state.currently = Idle
1604 then
1605 match gettileopaque l col row with
1606 | Some _ -> ()
1607 | None ->
1608 let x = col*conf.tilew
1609 and y = row*conf.tileh in
1610 let w =
1611 let w = l.pagew - x in
1612 min w conf.tilew
1614 let h =
1615 let h = l.pageh - y in
1616 min h conf.tileh
1618 let pbo =
1619 if conf.usepbo
1620 then getpbo w h conf.colorspace
1621 else "0"
1623 wcmd "tile %s %d %d %d %d %s" p x y w h pbo;
1624 state.currently <-
1625 Tiling (
1626 l, p, conf.colorspace, conf.angle, state.gen, col, row,
1627 conf.tilew, conf.tileh
1630 itertiles l f;
1631 else
1632 loop rest
1634 | [] -> ()
1636 if nogeomcmds state.geomcmds
1637 then loop layout;
1640 let preloadlayout y =
1641 let y = if y < state.winh then 0 else y - state.winh in
1642 let h = state.winh*3 in
1643 layout y h;
1646 let load pages =
1647 let rec loop pages =
1648 if state.currently != Idle
1649 then ()
1650 else
1651 match pages with
1652 | l :: rest ->
1653 begin match getopaque l.pageno with
1654 | None ->
1655 wcmd "page %d %d" l.pageno l.pagedimno;
1656 state.currently <- Loading (l, state.gen);
1657 | Some opaque ->
1658 tilepage l.pageno opaque pages;
1659 loop rest
1660 end;
1661 | _ -> ()
1663 if nogeomcmds state.geomcmds
1664 then loop pages
1667 let preload pages =
1668 load pages;
1669 if conf.preload && state.currently = Idle
1670 then load (preloadlayout state.y);
1673 let layoutready layout =
1674 let rec fold all ls =
1675 all && match ls with
1676 | l :: rest ->
1677 let seen = ref false in
1678 let allvisible = ref true in
1679 let foo col row _ _ _ _ _ _ =
1680 seen := true;
1681 allvisible := !allvisible &&
1682 begin match gettileopaque l col row with
1683 | Some _ -> true
1684 | None -> false
1687 itertiles l foo;
1688 fold (!seen && !allvisible) rest
1689 | [] -> true
1691 let alltilesvisible = fold true layout in
1692 alltilesvisible;
1695 let gotoy y =
1696 let y = bound y 0 state.maxy in
1697 let y, layout, proceed =
1698 match conf.maxwait with
1699 | Some time when state.ghyll == noghyll ->
1700 begin match state.throttle with
1701 | None ->
1702 let layout = layout y state.winh in
1703 let ready = layoutready layout in
1704 if not ready
1705 then (
1706 load layout;
1707 state.throttle <- Some (layout, y, now ());
1709 else G.postRedisplay "gotoy showall (None)";
1710 y, layout, ready
1711 | Some (_, _, started) ->
1712 let dt = now () -. started in
1713 if dt > time
1714 then (
1715 state.throttle <- None;
1716 let layout = layout y state.winh in
1717 load layout;
1718 G.postRedisplay "maxwait";
1719 y, layout, true
1721 else -1, [], false
1724 | _ ->
1725 let layout = layout y state.winh in
1726 if not !wtmode || layoutready layout
1727 then G.postRedisplay "gotoy ready";
1728 y, layout, true
1730 if proceed
1731 then (
1732 state.y <- y;
1733 state.layout <- layout;
1734 begin match state.mode with
1735 | LinkNav (Ltexact (pageno, linkno)) ->
1736 let rec loop = function
1737 | [] ->
1738 state.mode <- LinkNav (Ltgendir 0)
1739 | l :: _ when l.pageno = pageno ->
1740 begin match getopaque pageno with
1741 | None ->
1742 state.mode <- LinkNav (Ltgendir 0)
1743 | Some opaque ->
1744 let x0, y0, x1, y1 = getlinkrect opaque linkno in
1745 if not (x0 >= l.pagex && x1 <= l.pagex + l.pagevw
1746 && y0 >= l.pagey && y1 <= l.pagey + l.pagevh)
1747 then state.mode <- LinkNav (Ltgendir 0)
1749 | _ :: rest -> loop rest
1751 loop layout
1752 | _ -> ()
1753 end;
1754 begin match state.mode with
1755 | Birdseye (conf, leftx, pageno, hooverpageno, anchor) ->
1756 if not (pagevisible layout pageno)
1757 then (
1758 match state.layout with
1759 | [] -> ()
1760 | l :: _ ->
1761 state.mode <- Birdseye (
1762 conf, leftx, l.pageno, hooverpageno, anchor
1765 | LinkNav (Ltgendir dir as lt) ->
1766 let linknav =
1767 let rec loop = function
1768 | [] -> lt
1769 | l :: rest ->
1770 match getopaque l.pageno with
1771 | None -> loop rest
1772 | Some opaque ->
1773 let link =
1774 let ld =
1775 if dir = 0
1776 then LDfirstvisible (l.pagex, l.pagey, dir)
1777 else (
1778 if dir > 0 then LDfirst else LDlast
1781 findlink opaque ld
1783 match link with
1784 | Lnotfound -> loop rest
1785 | Lfound n ->
1786 showlinktype (getlink opaque n);
1787 Ltexact (l.pageno, n)
1789 loop state.layout
1791 state.mode <- LinkNav linknav
1792 | _ -> ()
1793 end;
1794 preload layout;
1796 state.ghyll <- noghyll;
1797 if conf.updatecurs
1798 then (
1799 let mx, my = state.mpos in
1800 updateunder mx my;
1804 let conttiling pageno opaque =
1805 tilepage pageno opaque
1806 (if conf.preload then preloadlayout state.y else state.layout)
1809 let gotoy_and_clear_text y =
1810 if not conf.verbose then state.text <- "";
1811 gotoy y;
1814 let getanchor1 l =
1815 let top =
1816 let coloff = l.pagecol * l.pageh in
1817 float (l.pagey + coloff) /. float l.pageh
1819 let dtop =
1820 if l.pagedispy = 0
1821 then
1823 else
1824 if conf.presentation
1825 then float l.pagedispy /. float (calcips l.pageh)
1826 else float l.pagedispy /. float conf.interpagespace
1828 (l.pageno, top, dtop)
1831 let getanchor () =
1832 match state.layout with
1833 | l :: _ -> getanchor1 l
1834 | [] ->
1835 let n = page_of_y state.y in
1836 if n = -1
1837 then state.anchor
1838 else
1839 let y, h = getpageyh n in
1840 let dy = y - state.y in
1841 let dtop =
1842 if conf.presentation
1843 then
1844 let ips = calcips h in
1845 float (dy + ips) /. float ips
1846 else
1847 float dy /. float conf.interpagespace
1849 (n, 0.0, dtop)
1852 let getanchory (n, top, dtop) =
1853 let y, h = getpageyh n in
1854 if conf.presentation
1855 then
1856 let ips = calcips h in
1857 y + truncate (top*.float h -. dtop*.float ips) + ips;
1858 else
1859 y + truncate (top*.float h -. dtop*.float conf.interpagespace)
1862 let gotoanchor anchor =
1863 gotoy (getanchory anchor);
1866 let addnav () =
1867 cbput state.hists.nav (getanchor ());
1870 let getnav dir =
1871 let anchor = cbgetc state.hists.nav dir in
1872 getanchory anchor;
1875 let gotoghyll y =
1876 let scroll f n a b =
1877 (* http://devmaster.net/forums/topic/9796-ease-in-ease-out-algorithm/ *)
1878 let snake f a b =
1879 let s x = 3.0*.x**2.0 -. 2.0*.x**3.0 in
1880 if f < a
1881 then s (float f /. float a)
1882 else (
1883 if f > b
1884 then 1.0 -. s ((float (f-b) /. float (n-b)))
1885 else 1.0
1888 snake f a b
1889 and summa f n a b =
1890 (* courtesy:
1891 http://integrals.wolfram.com/index.jsp?expr=3x%5E2-2x%5E3&random=false *)
1892 let iv x = -.((-.2.0 +. x)*.x**3.0)/.2.0 in
1893 let iv1 = iv f in
1894 let ins = float a *. iv1
1895 and outs = float (n-b) *. iv1 in
1896 let ones = b - a in
1897 ins +. outs +. float ones
1899 let rec set (_N, _A, _B) y sy =
1900 let sum = summa 1.0 _N _A _B in
1901 let dy = float (y - sy) in
1902 state.ghyll <- (
1903 let rec gf n y1 o =
1904 if n >= _N
1905 then state.ghyll <- noghyll
1906 else
1907 let go n =
1908 let s = scroll n _N _A _B in
1909 let y1 = y1 +. ((s *. dy) /. sum) in
1910 gotoy_and_clear_text (truncate y1);
1911 state.ghyll <- gf (n+1) y1;
1913 match o with
1914 | None -> go n
1915 | Some y' -> set (_N/2, 1, 1) y' state.y
1917 gf 0 (float state.y)
1920 match conf.ghyllscroll with
1921 | None ->
1922 gotoy_and_clear_text y
1923 | Some nab ->
1924 if state.ghyll == noghyll
1925 then set nab y state.y
1926 else state.ghyll (Some y)
1929 let gotopage n top =
1930 let y, h = getpageyh n in
1931 let y = y + (truncate (top *. float h)) in
1932 gotoghyll y
1935 let gotopage1 n top =
1936 let y = getpagey n in
1937 let y = y + top in
1938 gotoghyll y
1941 let invalidate s f =
1942 state.layout <- [];
1943 state.pdims <- [];
1944 state.rects <- [];
1945 state.rects1 <- [];
1946 match state.geomcmds with
1947 | ps, [] when String.length ps = 0 ->
1948 f ();
1949 state.geomcmds <- s, [];
1951 | ps, [] ->
1952 state.geomcmds <- ps, [s, f];
1954 | ps, (s', _) :: rest when s' = s ->
1955 state.geomcmds <- ps, ((s, f) :: rest);
1957 | ps, cmds ->
1958 state.geomcmds <- ps, ((s, f) :: cmds);
1961 let flushpages () =
1962 Hashtbl.iter (fun _ opaque ->
1963 wcmd "freepage %s" opaque;
1964 ) state.pagemap;
1965 Hashtbl.clear state.pagemap;
1968 let flushtiles () =
1969 if not (Queue.is_empty state.tilelru)
1970 then (
1971 Queue.iter (fun (k, p, s) ->
1972 wcmd "freetile %s" p;
1973 state.memused <- state.memused - s;
1974 Hashtbl.remove state.tilemap k;
1975 ) state.tilelru;
1976 state.uioh#infochanged Memused;
1977 Queue.clear state.tilelru;
1979 load state.layout;
1982 let opendoc path password =
1983 state.path <- path;
1984 state.password <- password;
1985 state.gen <- state.gen + 1;
1986 state.docinfo <- [];
1988 flushpages ();
1989 setaalevel conf.aalevel;
1990 let titlepath =
1991 if String.length state.origin = 0
1992 then path
1993 else state.origin
1995 Wsi.settitle ("llpp " ^ (mbtoutf8 (Filename.basename titlepath)));
1996 wcmd "open %d %s\000%s\000" (btod !wtmode) path password;
1997 invalidate "reqlayout"
1998 (fun () ->
1999 wcmd "reqlayout %d %d %f %s\000"
2000 conf.angle (int_of_fitmodel conf.fitmodel) conf.zoom state.nameddest;
2004 let reload () =
2005 state.anchor <- getanchor ();
2006 opendoc state.path state.password;
2009 let scalecolor c =
2010 let c = c *. conf.colorscale in
2011 (c, c, c);
2014 let scalecolor2 (r, g, b) =
2015 (r *. conf.colorscale, g *. conf.colorscale, b *. conf.colorscale);
2018 let docolumns = function
2019 | Csingle _ ->
2020 let a = Array.make state.pagecount (-1, -1, -1, (-1, -1, -1, -1)) in
2021 let rec loop pageno pdimno pdim y ph pdims =
2022 if pageno = state.pagecount
2023 then ()
2024 else
2025 let pdimno, ((_, w, h, xoff) as pdim), pdims =
2026 match pdims with
2027 | ((pageno', _, _, _) as pdim) :: rest when pageno' = pageno ->
2028 pdimno+1, pdim, rest
2029 | _ ->
2030 pdimno, pdim, pdims
2032 let x = max 0 (((state.winw - state.scrollw - w) / 2) - xoff) in
2033 let y = y +
2034 (if conf.presentation
2035 then (if pageno = 0 then calcips h else calcips ph + calcips h)
2036 else (if pageno = 0 then 0 else conf.interpagespace)
2039 a.(pageno) <- (pdimno, x, y, pdim);
2040 loop (pageno+1) pdimno pdim (y + h) h pdims
2042 loop 0 ~-1 (-1,-1,-1,-1) 0 0 state.pdims;
2043 conf.columns <- Csingle a;
2045 | Cmulti ((columns, coverA, coverB), _) ->
2046 let a = Array.make state.pagecount (-1, -1, -1, (-1, -1, -1, -1)) in
2047 let rec loop pageno pdimno pdim x y rowh pdims =
2048 let rec fixrow m = if m = pageno then () else
2049 let (pdimno, x, y, ((_, _, h, _) as pdim)) = a.(m) in
2050 if h < rowh
2051 then (
2052 let y = y + (rowh - h) / 2 in
2053 a.(m) <- (pdimno, x, y, pdim);
2055 fixrow (m+1)
2057 if pageno = state.pagecount
2058 then fixrow (((pageno - 1) / columns) * columns)
2059 else
2060 let pdimno, ((_, w, h, xoff) as pdim), pdims =
2061 match pdims with
2062 | ((pageno', _, _, _) as pdim) :: rest when pageno' = pageno ->
2063 pdimno+1, pdim, rest
2064 | _ ->
2065 pdimno, pdim, pdims
2067 let x, y, rowh' =
2068 if pageno = coverA - 1 || pageno = state.pagecount - coverB
2069 then (
2070 let x = (state.winw - state.scrollw - w) / 2 in
2071 let ips =
2072 if conf.presentation then calcips h else conf.interpagespace in
2073 x, y + ips + rowh, h
2075 else (
2076 if (pageno - coverA) mod columns = 0
2077 then (
2078 let x = max 0 (state.winw - state.scrollw - state.w) / 2 in
2079 let y =
2080 if conf.presentation
2081 then
2082 let ips = calcips h in
2083 y + (if pageno = 0 then 0 else calcips rowh + ips)
2084 else
2085 y + (if pageno = 0 then 0 else conf.interpagespace)
2087 x, y + rowh, h
2089 else x, y, max rowh h
2092 let y =
2093 if pageno > 1 && (pageno - coverA) mod columns = 0
2094 then (
2095 let y =
2096 if pageno = columns && conf.presentation
2097 then (
2098 let ips = calcips rowh in
2099 for i = 0 to pred columns
2101 let (pdimno, x, y, pdim) = a.(i) in
2102 a.(i) <- (pdimno, x, y+ips, pdim)
2103 done;
2104 y+ips;
2106 else y
2108 fixrow (pageno - columns);
2111 else y
2113 a.(pageno) <- (pdimno, x, y, pdim);
2114 let x = x + w + xoff*2 + conf.interpagespace in
2115 loop (pageno+1) pdimno pdim x y rowh' pdims
2117 loop 0 ~-1 (-1,-1,-1,-1) 0 0 0 state.pdims;
2118 conf.columns <- Cmulti ((columns, coverA, coverB), a);
2120 | Csplit (c, _) ->
2121 let a = Array.make (state.pagecount*c) (-1, -1, -1, (-1, -1, -1, -1)) in
2122 let rec loop pageno pdimno pdim y pdims =
2123 if pageno = state.pagecount
2124 then ()
2125 else
2126 let pdimno, ((_, w, h, _) as pdim), pdims =
2127 match pdims with
2128 | ((pageno', _, _, _) as pdim) :: rest when pageno' = pageno ->
2129 pdimno+1, pdim, rest
2130 | _ ->
2131 pdimno, pdim, pdims
2133 let cw = w / c in
2134 let rec loop1 n x y =
2135 if n = c then y else (
2136 a.(pageno*c + n) <- (pdimno, x, y, pdim);
2137 loop1 (n+1) (x+cw) (y + h + conf.interpagespace)
2140 let y = loop1 0 0 y in
2141 loop (pageno+1) pdimno pdim y pdims
2143 loop 0 ~-1 (-1,-1,-1,-1) 0 state.pdims;
2144 conf.columns <- Csplit (c, a);
2147 let represent () =
2148 docolumns conf.columns;
2149 state.maxy <- calcheight ();
2150 state.hscrollh <-
2151 if state.x = 0 && state.w <= state.winw - state.scrollw
2152 then 0
2153 else state.scrollw
2155 if state.reprf == noreprf
2156 then (
2157 match state.mode with
2158 | Birdseye (_, _, pageno, _, _) ->
2159 let y, h = getpageyh pageno in
2160 let top = (state.winh - h) / 2 in
2161 gotoy (max 0 (y - top))
2162 | _ -> gotoanchor state.anchor
2164 else (
2165 state.reprf ();
2166 state.reprf <- noreprf;
2170 let reshape w h =
2171 GlDraw.viewport 0 0 w h;
2172 let firsttime = state.geomcmds == firstgeomcmds in
2173 if not firsttime && nogeomcmds state.geomcmds
2174 then state.anchor <- getanchor ();
2176 state.winw <- w;
2177 let w = truncate (float w *. conf.zoom) - state.scrollw in
2178 let w = max w 2 in
2179 state.winh <- h;
2180 setfontsize fstate.fontsize;
2181 GlMat.mode `modelview;
2182 GlMat.load_identity ();
2184 GlMat.mode `projection;
2185 GlMat.load_identity ();
2186 GlMat.rotate ~x:1.0 ~angle:180.0 ();
2187 GlMat.translate ~x:~-.1.0 ~y:~-.1.0 ();
2188 GlMat.scale3 (2.0 /. float state.winw, 2.0 /. float state.winh, 1.0);
2190 let relx =
2191 if conf.zoom <= 1.0
2192 then 0.0
2193 else float state.x /. float state.w
2195 invalidate "geometry"
2196 (fun () ->
2197 state.w <- w;
2198 if not firsttime
2199 then state.x <- truncate (relx *. float w);
2200 let w =
2201 match conf.columns with
2202 | Csingle _ -> w
2203 | Cmulti ((c, _, _), _) -> (w - (c-1)*conf.interpagespace) / c
2204 | Csplit (c, _) -> w * c
2206 wcmd "geometry %d %d %f %d"
2207 w (h - 2*conf.interpagespace) conf.zoom
2208 (int_of_fitmodel conf.fitmodel));
2211 let enttext () =
2212 let len = String.length state.text in
2213 let drawstring s =
2214 let hscrollh =
2215 match state.mode with
2216 | Textentry _
2217 | View ->
2218 let h, _, _ = state.uioh#scrollpw in
2220 | _ -> 0
2222 let rect x w =
2223 GlDraw.rect
2224 (x, float (state.winh - (fstate.fontsize + 4) - hscrollh))
2225 (x+.w, float (state.winh - hscrollh))
2228 let w = float (state.winw - state.scrollw - 1) in
2229 if state.progress >= 0.0 && state.progress < 1.0
2230 then (
2231 GlDraw.color (0.3, 0.3, 0.3);
2232 let w1 = w *. state.progress in
2233 rect 0.0 w1;
2234 GlDraw.color (0.0, 0.0, 0.0);
2235 rect w1 (w-.w1)
2237 else (
2238 GlDraw.color (0.0, 0.0, 0.0);
2239 rect 0.0 w;
2242 GlDraw.color (1.0, 1.0, 1.0);
2243 drawstring fstate.fontsize
2244 (if len > 0 then 8 else 2) (state.winh - hscrollh - 5) s;
2246 let s =
2247 match state.mode with
2248 | Textentry ((prefix, text, _, _, _, _), _) ->
2249 let s =
2250 if len > 0
2251 then
2252 Printf.sprintf "%s%s_ [%s]" prefix text state.text
2253 else
2254 Printf.sprintf "%s%s_" prefix text
2258 | _ -> state.text
2260 let s =
2261 if state.newerrmsgs
2262 then (
2263 if not (istextentry state.mode) && state.uioh#eformsgs
2264 then
2265 let s1 = "(press 'e' to review error messasges)" in
2266 if String.length s > 0 then s ^ " " ^ s1 else s1
2267 else s
2269 else s
2271 if String.length s > 0
2272 then drawstring s
2275 let gctiles () =
2276 let len = Queue.length state.tilelru in
2277 let layout = lazy (
2278 match state.throttle with
2279 | None ->
2280 if conf.preload
2281 then preloadlayout state.y
2282 else state.layout
2283 | Some (layout, _, _) ->
2284 layout
2285 ) in
2286 let rec loop qpos =
2287 if state.memused <= conf.memlimit
2288 then ()
2289 else (
2290 if qpos < len
2291 then
2292 let (k, p, s) as lruitem = Queue.pop state.tilelru in
2293 let n, gen, colorspace, angle, pagew, pageh, col, row = k in
2294 let (_, pw, ph, _) = getpagedim n in
2296 gen = state.gen
2297 && colorspace = conf.colorspace
2298 && angle = conf.angle
2299 && pagew = pw
2300 && pageh = ph
2301 && (
2302 let x = col*conf.tilew
2303 and y = row*conf.tileh in
2304 tilevisible (Lazy.force_val layout) n x y
2306 then Queue.push lruitem state.tilelru
2307 else (
2308 freepbo p;
2309 wcmd "freetile %s" p;
2310 state.memused <- state.memused - s;
2311 state.uioh#infochanged Memused;
2312 Hashtbl.remove state.tilemap k;
2314 loop (qpos+1)
2317 loop 0
2320 let logcurrently = function
2321 | Idle -> dolog "Idle"
2322 | Loading (l, gen) ->
2323 dolog "Loading %d gen=%d curgen=%d" l.pageno gen state.gen
2324 | Tiling (l, pageopaque, colorspace, angle, gen, col, row, tilew, tileh) ->
2325 dolog
2326 "Tiling %d[%d,%d] page=%s cs=%s angle"
2327 l.pageno col row pageopaque
2328 (colorspace_to_string colorspace)
2330 dolog "gen=(%d,%d) (%d,%d) tile=(%d,%d) (%d,%d)"
2331 angle gen conf.angle state.gen
2332 tilew tileh
2333 conf.tilew conf.tileh
2335 | Outlining _ ->
2336 dolog "outlining"
2339 let splitatspace =
2340 let r = Str.regexp " " in
2341 fun s -> Str.bounded_split r s 2;
2344 let onpagerect pageno f =
2345 let b =
2346 match conf.columns with
2347 | Cmulti (_, b) -> b
2348 | Csingle b -> b
2349 | Csplit (_, b) -> b
2351 if pageno >= 0 && pageno < Array.length b
2352 then
2353 let (pdimno, _, _, (_, _, _, _)) = b.(pageno) in
2354 let r = getpdimrect pdimno in
2355 f (r.(1)-.r.(0)) (r.(3)-.r.(2))
2358 let gotopagexy1 pageno x y =
2359 onpagerect pageno (fun w h ->
2360 let top = y /. h in
2361 let _,w1,_,leftx = getpagedim pageno in
2362 let wh = state.winh - state.hscrollh in
2363 let sw = float w1 /. w in
2364 let x = sw *. x in
2365 let x = leftx + state.x + truncate x in
2366 let sx =
2367 if x < 0 || x >= state.winw - state.scrollw
2368 then state.x - x
2369 else state.x
2371 let py, h = getpageyh pageno in
2372 let pdy = truncate (top *. float h) in
2373 let y' = py + pdy in
2374 let dy = y' - state.y in
2375 let sy =
2376 if x != state.x || not (dy > 0 && dy < wh)
2377 then (
2378 if conf.presentation
2379 then
2380 if abs (py - y') > wh
2381 then y'
2382 else py
2383 else y';
2385 else state.y
2387 if state.x != sx || state.y != sy
2388 then (
2389 let x, y =
2390 if !wtmode
2391 then (
2392 let ww = state.winw - state.scrollw in
2393 let qx = sx / ww
2394 and qy = pdy / wh in
2395 let x = qx * ww
2396 and y = py + qy * wh in
2397 let x = if -x + ww > w1 then -(w1-ww) else x
2398 and y' = if y + wh > state.maxy then state.maxy - wh else y in
2399 let y =
2400 if conf.presentation
2401 then
2402 if abs (py - y') > wh
2403 then y'
2404 else py
2405 else y';
2407 (x, y)
2409 else (sx, sy)
2411 state.x <- x;
2412 state.hscrollh <-
2413 if x = 0 && state.w <= state.winw - state.scrollw
2414 then 0
2415 else state.scrollw
2417 gotoy_and_clear_text y;
2419 else gotoy_and_clear_text state.y;
2423 let gotopagexy pageno x y =
2424 match state.mode with
2425 | Birdseye _ -> gotopage pageno 0.0
2426 | _ -> gotopagexy1 pageno x y
2429 let act cmds =
2430 (* dolog "%S" cmds; *)
2431 let cl = splitatspace cmds in
2432 let scan s fmt f =
2433 try Scanf.sscanf s fmt f
2434 with exn ->
2435 dolog "error processing '%S': %s" cmds (exntos exn);
2436 exit 1
2438 match cl with
2439 | "clear" :: [] ->
2440 state.uioh#infochanged Pdim;
2441 state.pdims <- [];
2443 | "clearrects" :: [] ->
2444 state.rects <- state.rects1;
2445 G.postRedisplay "clearrects";
2447 | "continue" :: args :: [] ->
2448 let n = scan args "%u" (fun n -> n) in
2449 state.pagecount <- n;
2450 begin match state.currently with
2451 | Outlining l ->
2452 state.currently <- Idle;
2453 state.outlines <- Array.of_list (List.rev l)
2454 | _ -> ()
2455 end;
2457 let cur, cmds = state.geomcmds in
2458 if String.length cur = 0
2459 then failwith "umpossible";
2461 begin match List.rev cmds with
2462 | [] ->
2463 state.geomcmds <- "", [];
2464 represent ();
2465 | (s, f) :: rest ->
2466 f ();
2467 state.geomcmds <- s, List.rev rest;
2468 end;
2469 if conf.maxwait = None && not !wtmode
2470 then G.postRedisplay "continue";
2472 | "title" :: args :: [] ->
2473 Wsi.settitle args
2475 | "msg" :: args :: [] ->
2476 showtext ' ' args
2478 | "vmsg" :: args :: [] ->
2479 if conf.verbose
2480 then showtext ' ' args
2482 | "emsg" :: args :: [] ->
2483 Buffer.add_string state.errmsgs args;
2484 state.newerrmsgs <- true;
2485 G.postRedisplay "error message"
2487 | "progress" :: args :: [] ->
2488 let progress, text =
2489 scan args "%f %n"
2490 (fun f pos ->
2491 f, String.sub args pos (String.length args - pos))
2493 state.text <- text;
2494 state.progress <- progress;
2495 G.postRedisplay "progress"
2497 | "firstmatch" :: args :: [] ->
2498 let pageno, c, x0, y0, x1, y1, x2, y2, x3, y3 =
2499 scan args "%u %d %f %f %f %f %f %f %f %f"
2500 (fun p c x0 y0 x1 y1 x2 y2 x3 y3 ->
2501 (p, c, x0, y0, x1, y1, x2, y2, x3, y3))
2503 let y = (getpagey pageno) + truncate y0 in
2504 addnav ();
2505 gotoy y;
2506 state.rects1 <- [pageno, c, (x0, y0, x1, y1, x2, y2, x3, y3)]
2508 | "match" :: args :: [] ->
2509 let pageno, c, x0, y0, x1, y1, x2, y2, x3, y3 =
2510 scan args "%u %d %f %f %f %f %f %f %f %f"
2511 (fun p c x0 y0 x1 y1 x2 y2 x3 y3 ->
2512 (p, c, x0, y0, x1, y1, x2, y2, x3, y3))
2514 state.rects1 <-
2515 (pageno, c, (x0, y0, x1, y1, x2, y2, x3, y3)) :: state.rects1
2517 | "page" :: args :: [] ->
2518 let pageopaque, t = scan args "%s %f" (fun p t -> p, t) in
2519 begin match state.currently with
2520 | Loading (l, gen) ->
2521 vlog "page %d took %f sec" l.pageno t;
2522 Hashtbl.replace state.pagemap (l.pageno, gen) pageopaque;
2523 begin match state.throttle with
2524 | None ->
2525 let preloadedpages =
2526 if conf.preload
2527 then preloadlayout state.y
2528 else state.layout
2530 let evict () =
2531 let set =
2532 List.fold_left (fun s l -> IntSet.add l.pageno s)
2533 IntSet.empty preloadedpages
2535 let evictedpages =
2536 Hashtbl.fold (fun ((pageno, _) as key) opaque accu ->
2537 if not (IntSet.mem pageno set)
2538 then (
2539 wcmd "freepage %s" opaque;
2540 key :: accu
2542 else accu
2543 ) state.pagemap []
2545 List.iter (Hashtbl.remove state.pagemap) evictedpages;
2547 evict ();
2548 state.currently <- Idle;
2549 if gen = state.gen
2550 then (
2551 tilepage l.pageno pageopaque state.layout;
2552 load state.layout;
2553 load preloadedpages;
2554 if pagevisible state.layout l.pageno
2555 && layoutready state.layout
2556 then G.postRedisplay "page";
2559 | Some (layout, _, _) ->
2560 state.currently <- Idle;
2561 tilepage l.pageno pageopaque layout;
2562 load state.layout
2563 end;
2565 | _ ->
2566 dolog "Inconsistent loading state";
2567 logcurrently state.currently;
2568 exit 1
2571 | "tile" :: args :: [] ->
2572 let (x, y, opaque, size, t) =
2573 scan args "%u %u %s %u %f"
2574 (fun x y p size t -> (x, y, p, size, t))
2576 begin match state.currently with
2577 | Tiling (l, pageopaque, cs, angle, gen, col, row, tilew, tileh) ->
2578 vlog "tile %d [%d,%d] took %f sec" l.pageno col row t;
2580 unmappbo opaque;
2581 if tilew != conf.tilew || tileh != conf.tileh
2582 then (
2583 wcmd "freetile %s" opaque;
2584 state.currently <- Idle;
2585 load state.layout;
2587 else (
2588 puttileopaque l col row gen cs angle opaque size t;
2589 state.memused <- state.memused + size;
2590 state.uioh#infochanged Memused;
2591 gctiles ();
2592 Queue.push ((l.pageno, gen, cs, angle, l.pagew, l.pageh, col, row),
2593 opaque, size) state.tilelru;
2595 let layout =
2596 match state.throttle with
2597 | None -> state.layout
2598 | Some (layout, _, _) -> layout
2601 state.currently <- Idle;
2602 if gen = state.gen
2603 && conf.colorspace = cs
2604 && conf.angle = angle
2605 && tilevisible layout l.pageno x y
2606 then conttiling l.pageno pageopaque;
2608 begin match state.throttle with
2609 | None ->
2610 preload state.layout;
2611 if gen = state.gen
2612 && conf.colorspace = cs
2613 && conf.angle = angle
2614 && tilevisible state.layout l.pageno x y
2615 && (not !wtmode || layoutready state.layout)
2616 then G.postRedisplay "tile nothrottle";
2618 | Some (layout, y, _) ->
2619 let ready = layoutready layout in
2620 if ready
2621 then (
2622 state.y <- y;
2623 state.layout <- layout;
2624 state.throttle <- None;
2625 G.postRedisplay "throttle";
2627 else load layout;
2628 end;
2631 | _ ->
2632 dolog "Inconsistent tiling state";
2633 logcurrently state.currently;
2634 exit 1
2637 | "pdim" :: args :: [] ->
2638 let pdim =
2639 scan args "%u %u %u %u" (fun n w h x -> n, w, h, x)
2641 state.uioh#infochanged Pdim;
2642 state.pdims <- pdim :: state.pdims
2644 | "o" :: args :: [] ->
2645 let (l, n, t, h, pos) =
2646 scan args "%u %u %d %u %n"
2647 (fun l n t h pos -> l, n, t, h, pos)
2649 let s = String.sub args pos (String.length args - pos) in
2650 let outline = (s, l, (n, float t /. float h, 0.0)) in
2651 begin match state.currently with
2652 | Outlining outlines ->
2653 state.currently <- Outlining (outline :: outlines)
2654 | Idle ->
2655 state.currently <- Outlining [outline]
2656 | currently ->
2657 dolog "invalid outlining state";
2658 logcurrently currently
2661 | "a" :: args :: [] ->
2662 let (n, l, t) =
2663 scan args "%u %d %d" (fun n l t -> n, l, t)
2665 state.reprf <- (fun () -> gotopagexy n (float l) (float t))
2667 | "info" :: args :: [] ->
2668 state.docinfo <- (1, args) :: state.docinfo
2670 | "infoend" :: [] ->
2671 state.uioh#infochanged Docinfo;
2672 state.docinfo <- List.rev state.docinfo
2674 | _ ->
2675 failwith (Printf.sprintf "unknown cmd `%S'" cmds)
2678 let onhist cb =
2679 let rc = cb.rc in
2680 let action = function
2681 | HCprev -> cbget cb ~-1
2682 | HCnext -> cbget cb 1
2683 | HCfirst -> cbget cb ~-(cb.rc)
2684 | HClast -> cbget cb (cb.len - 1 - cb.rc)
2685 and cancel () = cb.rc <- rc
2686 in (action, cancel)
2689 let search pattern forward =
2690 if String.length pattern > 0
2691 then
2692 let pn, py =
2693 match state.layout with
2694 | [] -> 0, 0
2695 | l :: _ ->
2696 l.pageno, (l.pagey + if forward then 0 else 0*l.pagevh)
2698 wcmd "search %d %d %d %d,%s\000"
2699 (btod conf.icase) pn py (btod forward) pattern;
2702 let intentry text key =
2703 let c =
2704 if key >= 32 && key < 127
2705 then Char.chr key
2706 else '\000'
2708 match c with
2709 | '0' .. '9' ->
2710 let text = addchar text c in
2711 TEcont text
2713 | _ ->
2714 state.text <- Printf.sprintf "invalid char (%d, `%c')" key c;
2715 TEcont text
2718 let linknentry text key =
2719 let c =
2720 if key >= 32 && key < 127
2721 then Char.chr key
2722 else '\000'
2724 match c with
2725 | 'a' .. 'z' ->
2726 let text = addchar text c in
2727 TEcont text
2729 | _ ->
2730 state.text <- Printf.sprintf "invalid char (%d, `%c')" key c;
2731 TEcont text
2734 let linkndone f s =
2735 if String.length s > 0
2736 then (
2737 let n =
2738 let l = String.length s in
2739 let rec loop pos n = if pos = l then n else
2740 let m = Char.code s.[pos] - (if pos = 0 && l > 1 then 96 else 97) in
2741 loop (pos+1) (n*26 + m)
2742 in loop 0 0
2744 let rec loop n = function
2745 | [] -> ()
2746 | l :: rest ->
2747 match getopaque l.pageno with
2748 | None -> loop n rest
2749 | Some opaque ->
2750 let m = getlinkcount opaque in
2751 if n < m
2752 then (
2753 let under = getlink opaque n in
2754 f under
2756 else loop (n-m) rest
2758 loop n state.layout;
2762 let textentry text key =
2763 if key land 0xff00 = 0xff00
2764 then TEcont text
2765 else TEcont (text ^ toutf8 key)
2768 let reqlayout angle fitmodel =
2769 match state.throttle with
2770 | None ->
2771 if nogeomcmds state.geomcmds
2772 then state.anchor <- getanchor ();
2773 conf.angle <- angle mod 360;
2774 if conf.angle != 0
2775 then (
2776 match state.mode with
2777 | LinkNav _ -> state.mode <- View
2778 | _ -> ()
2780 conf.fitmodel <- fitmodel;
2781 invalidate "reqlayout"
2782 (fun () ->
2783 wcmd "reqlayout %d %d %f"
2784 conf.angle (int_of_fitmodel fitmodel) conf.zoom);
2785 | _ -> ()
2788 let settrim trimmargins trimfuzz =
2789 if nogeomcmds state.geomcmds
2790 then state.anchor <- getanchor ();
2791 conf.trimmargins <- trimmargins;
2792 conf.trimfuzz <- trimfuzz;
2793 let x0, y0, x1, y1 = trimfuzz in
2794 invalidate "settrim"
2795 (fun () ->
2796 wcmd "settrim %d %d %d %d %d %f"
2797 (btod conf.trimmargins) x0 y0 x1 y1 conf.zoom);
2798 flushpages ();
2801 let setzoom zoom =
2802 match state.throttle with
2803 | None ->
2804 let zoom = max 0.0001 zoom in
2805 if zoom <> conf.zoom
2806 then (
2807 state.prevzoom <- conf.zoom;
2808 conf.zoom <- zoom;
2809 reshape state.winw state.winh;
2810 state.text <- Printf.sprintf "zoom is now %-5.2f" (zoom *. 100.0);
2813 | Some (layout, y, started) ->
2814 let time =
2815 match conf.maxwait with
2816 | None -> 0.0
2817 | Some t -> t
2819 let dt = now () -. started in
2820 if dt > time
2821 then (
2822 state.y <- y;
2823 load layout;
2827 let setcolumns mode columns coverA coverB =
2828 state.prevcolumns <- Some (conf.columns, conf.zoom);
2829 if columns < 0
2830 then (
2831 if isbirdseye mode
2832 then showtext '!' "split mode doesn't work in bird's eye"
2833 else (
2834 conf.columns <- Csplit (-columns, [||]);
2835 state.x <- 0;
2836 conf.zoom <- 1.0;
2839 else (
2840 if columns < 2
2841 then (
2842 conf.columns <- Csingle [||];
2843 state.x <- 0;
2844 setzoom 1.0;
2846 else (
2847 conf.columns <- Cmulti ((columns, coverA, coverB), [||]);
2848 conf.zoom <- 1.0;
2851 reshape state.winw state.winh;
2854 let enterbirdseye () =
2855 let zoom = float conf.thumbw /. float state.winw in
2856 let birdseyepageno =
2857 let cy = state.winh / 2 in
2858 let fold = function
2859 | [] -> 0
2860 | l :: rest ->
2861 let rec fold best = function
2862 | [] -> best.pageno
2863 | l :: rest ->
2864 let d = cy - (l.pagedispy + l.pagevh/2)
2865 and dbest = cy - (best.pagedispy + best.pagevh/2) in
2866 if abs d < abs dbest
2867 then fold l rest
2868 else best.pageno
2869 in fold l rest
2871 fold state.layout
2873 state.mode <- Birdseye (
2874 { conf with zoom = conf.zoom }, state.x, birdseyepageno, -1, getanchor ()
2876 conf.zoom <- zoom;
2877 conf.presentation <- false;
2878 conf.interpagespace <- 10;
2879 conf.hlinks <- false;
2880 conf.fitmodel <- FitProportional;
2881 state.x <- 0;
2882 state.mstate <- Mnone;
2883 conf.maxwait <- None;
2884 conf.columns <- (
2885 match conf.beyecolumns with
2886 | Some c ->
2887 conf.zoom <- 1.0;
2888 Cmulti ((c, 0, 0), [||])
2889 | None -> Csingle [||]
2891 Wsi.setcursor Wsi.CURSOR_INHERIT;
2892 if conf.verbose
2893 then
2894 state.text <- Printf.sprintf "birds eye mode on (zoom %3.1f%%)"
2895 (100.0*.zoom)
2896 else
2897 state.text <- ""
2899 reshape state.winw state.winh;
2902 let leavebirdseye (c, leftx, pageno, _, anchor) goback =
2903 state.mode <- View;
2904 conf.zoom <- c.zoom;
2905 conf.presentation <- c.presentation;
2906 conf.interpagespace <- c.interpagespace;
2907 conf.maxwait <- c.maxwait;
2908 conf.hlinks <- c.hlinks;
2909 conf.fitmodel <- c.fitmodel;
2910 conf.beyecolumns <- (
2911 match conf.columns with
2912 | Cmulti ((c, _, _), _) -> Some c
2913 | Csingle _ -> None
2914 | Csplit _ -> failwith "leaving bird's eye split mode"
2916 conf.columns <- (
2917 match c.columns with
2918 | Cmulti (c, _) -> Cmulti (c, [||])
2919 | Csingle _ -> Csingle [||]
2920 | Csplit (c, _) -> Csplit (c, [||])
2922 state.x <- leftx;
2923 if conf.verbose
2924 then
2925 state.text <- Printf.sprintf "birds eye mode off (zoom %3.1f%%)"
2926 (100.0*.conf.zoom)
2928 reshape state.winw state.winh;
2929 state.anchor <- if goback then anchor else (pageno, 0.0, 1.0);
2932 let togglebirdseye () =
2933 match state.mode with
2934 | Birdseye vals -> leavebirdseye vals true
2935 | View -> enterbirdseye ()
2936 | _ -> ()
2939 let upbirdseye incr (conf, leftx, pageno, hooverpageno, anchor) =
2940 let pageno = max 0 (pageno - incr) in
2941 let rec loop = function
2942 | [] -> gotopage1 pageno 0
2943 | l :: _ when l.pageno = pageno ->
2944 if l.pagedispy >= 0 && l.pagey = 0
2945 then G.postRedisplay "upbirdseye"
2946 else gotopage1 pageno 0
2947 | _ :: rest -> loop rest
2949 loop state.layout;
2950 state.mode <- Birdseye (conf, leftx, pageno, hooverpageno, anchor)
2953 let downbirdseye incr (conf, leftx, pageno, hooverpageno, anchor) =
2954 let pageno = min (state.pagecount - 1) (pageno + incr) in
2955 state.mode <- Birdseye (conf, leftx, pageno, hooverpageno, anchor);
2956 let rec loop = function
2957 | [] ->
2958 let y, h = getpageyh pageno in
2959 let dy = (y - state.y) - (state.winh - h - conf.interpagespace) in
2960 gotoy (clamp dy)
2961 | l :: _ when l.pageno = pageno ->
2962 if l.pagevh != l.pageh
2963 then gotoy (clamp (l.pageh - l.pagevh + conf.interpagespace))
2964 else G.postRedisplay "downbirdseye"
2965 | _ :: rest -> loop rest
2967 loop state.layout
2970 let optentry mode _ key =
2971 let btos b = if b then "on" else "off" in
2972 if key >= 32 && key < 127
2973 then
2974 let c = Char.chr key in
2975 match c with
2976 | 's' ->
2977 let ondone s =
2978 try conf.scrollstep <- int_of_string s with exc ->
2979 state.text <- Printf.sprintf "bad integer `%s': %s" s (exntos exc)
2981 TEswitch ("scroll step: ", "", None, intentry, ondone, true)
2983 | 'A' ->
2984 let ondone s =
2986 conf.autoscrollstep <- int_of_string s;
2987 if state.autoscroll <> None
2988 then state.autoscroll <- Some conf.autoscrollstep
2989 with exc ->
2990 state.text <- Printf.sprintf "bad integer `%s': %s" s (exntos exc)
2992 TEswitch ("auto scroll step: ", "", None, intentry, ondone, true)
2994 | 'C' ->
2995 let ondone s =
2997 let n, a, b = multicolumns_of_string s in
2998 setcolumns mode n a b;
2999 with exc ->
3000 state.text <- Printf.sprintf "bad columns `%s': %s" s (exntos exc)
3002 TEswitch ("columns: ", "", None, textentry, ondone, true)
3004 | 'Z' ->
3005 let ondone s =
3007 let zoom = float (int_of_string s) /. 100.0 in
3008 setzoom zoom
3009 with exc ->
3010 state.text <- Printf.sprintf "bad integer `%s': %s" s (exntos exc)
3012 TEswitch ("zoom: ", "", None, intentry, ondone, true)
3014 | 't' ->
3015 let ondone s =
3017 conf.thumbw <- bound (int_of_string s) 2 4096;
3018 state.text <-
3019 Printf.sprintf "thumbnail width is set to %d" conf.thumbw;
3020 begin match mode with
3021 | Birdseye beye ->
3022 leavebirdseye beye false;
3023 enterbirdseye ();
3024 | _ -> ();
3026 with exc ->
3027 state.text <- Printf.sprintf "bad integer `%s': %s" s (exntos exc)
3029 TEswitch ("thumbnail width: ", "", None, intentry, ondone, true)
3031 | 'R' ->
3032 let ondone s =
3033 match try
3034 Some (int_of_string s)
3035 with exc ->
3036 state.text <- Printf.sprintf "bad integer `%s': %s"
3037 s (exntos exc);
3038 None
3039 with
3040 | Some angle -> reqlayout angle conf.fitmodel
3041 | None -> ()
3043 TEswitch ("rotation: ", "", None, intentry, ondone, true)
3045 | 'i' ->
3046 conf.icase <- not conf.icase;
3047 TEdone ("case insensitive search " ^ (btos conf.icase))
3049 | 'p' ->
3050 conf.preload <- not conf.preload;
3051 gotoy state.y;
3052 TEdone ("preload " ^ (btos conf.preload))
3054 | 'v' ->
3055 conf.verbose <- not conf.verbose;
3056 TEdone ("verbose " ^ (btos conf.verbose))
3058 | 'd' ->
3059 conf.debug <- not conf.debug;
3060 TEdone ("debug " ^ (btos conf.debug))
3062 | 'h' ->
3063 conf.maxhfit <- not conf.maxhfit;
3064 state.maxy <- calcheight ();
3065 TEdone ("maxhfit " ^ (btos conf.maxhfit))
3067 | 'c' ->
3068 conf.crophack <- not conf.crophack;
3069 TEdone ("crophack " ^ btos conf.crophack)
3071 | 'a' ->
3072 let s =
3073 match conf.maxwait with
3074 | None ->
3075 conf.maxwait <- Some infinity;
3076 "always wait for page to complete"
3077 | Some _ ->
3078 conf.maxwait <- None;
3079 "show placeholder if page is not ready"
3081 TEdone s
3083 | 'f' ->
3084 conf.underinfo <- not conf.underinfo;
3085 TEdone ("underinfo " ^ btos conf.underinfo)
3087 | 'P' ->
3088 conf.savebmarks <- not conf.savebmarks;
3089 TEdone ("persistent bookmarks " ^ btos conf.savebmarks)
3091 | 'S' ->
3092 let ondone s =
3094 let pageno, py =
3095 match state.layout with
3096 | [] -> 0, 0
3097 | l :: _ ->
3098 l.pageno, l.pagey
3100 conf.interpagespace <- int_of_string s;
3101 docolumns conf.columns;
3102 state.maxy <- calcheight ();
3103 let y = getpagey pageno in
3104 gotoy (y + py)
3105 with exc ->
3106 state.text <- Printf.sprintf "bad integer `%s': %s" s (exntos exc)
3108 TEswitch ("vertical margin: ", "", None, intentry, ondone, true)
3110 | 'l' ->
3111 let fm =
3112 match conf.fitmodel with
3113 | FitProportional -> FitWidth
3114 | _ -> FitProportional
3116 reqlayout conf.angle fm;
3117 TEdone ("proportional display " ^ btos (fm == FitProportional))
3119 | 'T' ->
3120 settrim (not conf.trimmargins) conf.trimfuzz;
3121 TEdone ("trim margins " ^ btos conf.trimmargins)
3123 | 'I' ->
3124 conf.invert <- not conf.invert;
3125 TEdone ("invert colors " ^ btos conf.invert)
3127 | 'x' ->
3128 let ondone s =
3129 cbput state.hists.sel s;
3130 conf.selcmd <- s;
3132 TEswitch ("selection command: ", "", Some (onhist state.hists.sel),
3133 textentry, ondone, true)
3135 | _ ->
3136 state.text <- Printf.sprintf "bad option %d `%c'" key c;
3137 TEstop
3138 else
3139 TEcont state.text
3142 class type lvsource = object
3143 method getitemcount : int
3144 method getitem : int -> (string * int)
3145 method hasaction : int -> bool
3146 method exit :
3147 uioh:uioh ->
3148 cancel:bool ->
3149 active:int ->
3150 first:int ->
3151 pan:int ->
3152 qsearch:string ->
3153 uioh option
3154 method getactive : int
3155 method getfirst : int
3156 method getqsearch : string
3157 method setqsearch : string -> unit
3158 method getpan : int
3159 end;;
3161 class virtual lvsourcebase = object
3162 val mutable m_active = 0
3163 val mutable m_first = 0
3164 val mutable m_qsearch = ""
3165 val mutable m_pan = 0
3166 method getactive = m_active
3167 method getfirst = m_first
3168 method getqsearch = m_qsearch
3169 method getpan = m_pan
3170 method setqsearch s = m_qsearch <- s
3171 end;;
3173 let withoutlastutf8 s =
3174 let len = String.length s in
3175 if len = 0
3176 then s
3177 else
3178 let rec find pos =
3179 if pos = 0
3180 then pos
3181 else
3182 let b = Char.code s.[pos] in
3183 if b land 0b11000000 = 0b11000000
3184 then pos
3185 else find (pos-1)
3187 let first =
3188 if Char.code s.[len-1] land 0x80 = 0
3189 then len-1
3190 else find (len-1)
3192 String.sub s 0 first;
3195 let textentrykeyboard
3196 key _mask ((c, text, opthist, onkey, ondone, cancelonempty), onleave) =
3197 let key =
3198 if key >= 0xffb0 && key <= 0xffb9
3199 then key - 0xffb0 + 48 else key
3201 let enttext te =
3202 state.mode <- Textentry (te, onleave);
3203 state.text <- "";
3204 enttext ();
3205 G.postRedisplay "textentrykeyboard enttext";
3207 let histaction cmd =
3208 match opthist with
3209 | None -> ()
3210 | Some (action, _) ->
3211 state.mode <- Textentry (
3212 (c, action cmd, opthist, onkey, ondone, cancelonempty), onleave
3214 G.postRedisplay "textentry histaction"
3216 match key with
3217 | 0xff08 -> (* backspace *)
3218 let s = withoutlastutf8 text in
3219 let len = String.length s in
3220 if cancelonempty && len = 0
3221 then (
3222 onleave Cancel;
3223 G.postRedisplay "textentrykeyboard after cancel";
3225 else (
3226 enttext (c, s, opthist, onkey, ondone, cancelonempty)
3229 | 0xff0d | 0xff8d -> (* (kp) enter *)
3230 ondone text;
3231 onleave Confirm;
3232 G.postRedisplay "textentrykeyboard after confirm"
3234 | 0xff52 | 0xff97 -> histaction HCprev (* (kp) up *)
3235 | 0xff54 | 0xff99 -> histaction HCnext (* (kp) down *)
3236 | 0xff50 | 0xff95 -> histaction HCfirst (* (kp) home) *)
3237 | 0xff57 | 0xff9c -> histaction HClast (* (kp) end *)
3239 | 0xff1b -> (* escape*)
3240 if String.length text = 0
3241 then (
3242 begin match opthist with
3243 | None -> ()
3244 | Some (_, onhistcancel) -> onhistcancel ()
3245 end;
3246 onleave Cancel;
3247 state.text <- "";
3248 G.postRedisplay "textentrykeyboard after cancel2"
3250 else (
3251 enttext (c, "", opthist, onkey, ondone, cancelonempty)
3254 | 0xff9f | 0xffff -> () (* delete *)
3256 | _ when key != 0
3257 && key land 0xff00 != 0xff00 (* keyboard *)
3258 && key land 0xfe00 != 0xfe00 (* xkb *)
3259 && key land 0xfd00 != 0xfd00 (* 3270 *)
3261 begin match onkey text key with
3262 | TEdone text ->
3263 ondone text;
3264 onleave Confirm;
3265 G.postRedisplay "textentrykeyboard after confirm2";
3267 | TEcont text ->
3268 enttext (c, text, opthist, onkey, ondone, cancelonempty);
3270 | TEstop ->
3271 onleave Cancel;
3272 G.postRedisplay "textentrykeyboard after cancel3"
3274 | TEswitch te ->
3275 state.mode <- Textentry (te, onleave);
3276 G.postRedisplay "textentrykeyboard switch";
3277 end;
3279 | _ ->
3280 vlog "unhandled key %s" (Wsi.keyname key)
3283 let firstof first active =
3284 if first > active || abs (first - active) > fstate.maxrows - 1
3285 then max 0 (active - (fstate.maxrows/2))
3286 else first
3289 let calcfirst first active =
3290 if active > first
3291 then
3292 let rows = active - first in
3293 if rows > fstate.maxrows then active - fstate.maxrows else first
3294 else active
3297 let scrollph y maxy =
3298 let sh = (float (maxy + state.winh) /. float state.winh) in
3299 let sh = float state.winh /. sh in
3300 let sh = max sh (float conf.scrollh) in
3302 let percent =
3303 if y = state.maxy
3304 then 1.0
3305 else float y /. float maxy
3307 let position = (float state.winh -. sh) *. percent in
3309 let position =
3310 if position +. sh > float state.winh
3311 then float state.winh -. sh
3312 else position
3314 position, sh;
3317 let coe s = (s :> uioh);;
3319 class listview ~(source:lvsource) ~trusted ~modehash =
3320 object (self)
3321 val m_pan = source#getpan
3322 val m_first = source#getfirst
3323 val m_active = source#getactive
3324 val m_qsearch = source#getqsearch
3325 val m_prev_uioh = state.uioh
3327 method private elemunder y =
3328 let n = y / (fstate.fontsize+1) in
3329 if m_first + n < source#getitemcount
3330 then (
3331 if source#hasaction (m_first + n)
3332 then Some (m_first + n)
3333 else None
3335 else None
3337 method display =
3338 Gl.enable `blend;
3339 GlFunc.blend_func `src_alpha `one_minus_src_alpha;
3340 GlDraw.color (0., 0., 0.) ~alpha:0.85;
3341 GlDraw.rect (0., 0.) (float state.winw, float state.winh);
3342 GlDraw.color (1., 1., 1.);
3343 Gl.enable `texture_2d;
3344 let fs = fstate.fontsize in
3345 let nfs = fs + 1 in
3346 let ww = fstate.wwidth in
3347 let tabw = 30.0*.ww in
3348 let itemcount = source#getitemcount in
3349 let rec loop row =
3350 if (row - m_first) > fstate.maxrows
3351 then ()
3352 else (
3353 if row >= 0 && row < itemcount
3354 then (
3355 let (s, level) = source#getitem row in
3356 let y = (row - m_first) * nfs in
3357 let x = 5.0 +. float (level + m_pan) *. ww in
3358 if row = m_active
3359 then (
3360 Gl.disable `texture_2d;
3361 GlDraw.polygon_mode `both `line;
3362 let alpha = if source#hasaction row then 0.9 else 0.3 in
3363 GlDraw.color (1., 1., 1.) ~alpha;
3364 GlDraw.rect (1., float (y + 1))
3365 (float (state.winw - conf.scrollbw - 1), float (y + fs + 3));
3366 GlDraw.polygon_mode `both `fill;
3367 GlDraw.color (1., 1., 1.);
3368 Gl.enable `texture_2d;
3371 let drawtabularstring s =
3372 let drawstr x s = drawstring1 fs (truncate x) (y+nfs) s in
3373 if trusted
3374 then
3375 let tabpos = try String.index s '\t' with Not_found -> -1 in
3376 if tabpos > 0
3377 then
3378 let len = String.length s - tabpos - 1 in
3379 let s1 = String.sub s 0 tabpos
3380 and s2 = String.sub s (tabpos + 1) len in
3381 let nx = drawstr x s1 in
3382 let sw = nx -. x in
3383 let x = x +. (max tabw sw) in
3384 drawstr x s2
3385 else
3386 drawstr x s
3387 else
3388 drawstr x s
3390 let _ = drawtabularstring s in
3391 loop (row+1)
3395 loop m_first;
3396 Gl.disable `blend;
3397 Gl.disable `texture_2d;
3399 method updownlevel incr =
3400 let len = source#getitemcount in
3401 let curlevel =
3402 if m_active >= 0 && m_active < len
3403 then snd (source#getitem m_active)
3404 else -1
3406 let rec flow i =
3407 if i = len then i-1 else if i = -1 then 0 else
3408 let _, l = source#getitem i in
3409 if l != curlevel then i else flow (i+incr)
3411 let active = flow m_active in
3412 let first = calcfirst m_first active in
3413 G.postRedisplay "outline updownlevel";
3414 {< m_active = active; m_first = first >}
3416 method private key1 key mask =
3417 let set1 active first qsearch =
3418 coe {< m_active = active; m_first = first; m_qsearch = qsearch >}
3420 let search active pattern incr =
3421 let active = if active = -1 then m_first else active in
3422 let dosearch re =
3423 let rec loop n =
3424 if n >= 0 && n < source#getitemcount
3425 then (
3426 let s, _ = source#getitem n in
3428 (try ignore (Str.search_forward re s 0); true
3429 with Not_found -> false)
3430 then Some n
3431 else loop (n + incr)
3433 else None
3435 loop active
3438 let re = Str.regexp_case_fold pattern in
3439 dosearch re
3440 with Failure s ->
3441 state.text <- s;
3442 None
3444 let itemcount = source#getitemcount in
3445 let find start incr =
3446 let rec find i =
3447 if i = -1 || i = itemcount
3448 then -1
3449 else (
3450 if source#hasaction i
3451 then i
3452 else find (i + incr)
3455 find start
3457 let set active first =
3458 let first = bound first 0 (itemcount - fstate.maxrows) in
3459 state.text <- "";
3460 coe {< m_active = active; m_first = first; m_qsearch = "" >}
3462 let navigate incr =
3463 let isvisible first n = n >= first && n - first <= fstate.maxrows in
3464 let active, first =
3465 let incr1 = if incr > 0 then 1 else -1 in
3466 if isvisible m_first m_active
3467 then
3468 let next =
3469 let next = m_active + incr in
3470 let next =
3471 if next < 0 || next >= itemcount
3472 then -1
3473 else find next incr1
3475 if next = -1 || abs (m_active - next) > fstate.maxrows
3476 then -1
3477 else next
3479 if next = -1
3480 then
3481 let first = m_first + incr in
3482 let first = bound first 0 (itemcount - 1) in
3483 let next =
3484 let next = m_active + incr in
3485 let next = bound next 0 (itemcount - 1) in
3486 find next ~-incr1
3488 let active = if next = -1 then m_active else next in
3489 active, first
3490 else
3491 let first = min next m_first in
3492 let first =
3493 if abs (next - first) > fstate.maxrows
3494 then first + incr
3495 else first
3497 next, first
3498 else
3499 let first = m_first + incr in
3500 let first = bound first 0 (itemcount - 1) in
3501 let active =
3502 let next = m_active + incr in
3503 let next = bound next 0 (itemcount - 1) in
3504 let next = find next incr1 in
3505 let active =
3506 if next = -1 || abs (m_active - first) > fstate.maxrows
3507 then (
3508 let active = if m_active = -1 then next else m_active in
3509 active
3511 else next
3513 if isvisible first active
3514 then active
3515 else -1
3517 active, first
3519 G.postRedisplay "listview navigate";
3520 set active first;
3522 match key with
3523 | (0x72|0x73) when Wsi.withctrl mask -> (* ctrl-r/ctlr-s *)
3524 let incr = if key = 0x72 then -1 else 1 in
3525 let active, first =
3526 match search (m_active + incr) m_qsearch incr with
3527 | None ->
3528 state.text <- m_qsearch ^ " [not found]";
3529 m_active, m_first
3530 | Some active ->
3531 state.text <- m_qsearch;
3532 active, firstof m_first active
3534 G.postRedisplay "listview ctrl-r/s";
3535 set1 active first m_qsearch;
3537 | 0xff63 when Wsi.withctrl mask -> (* ctrl-insert *)
3538 if m_active >= 0 && m_active < source#getitemcount
3539 then (
3540 let s, _ = source#getitem m_active in
3541 selstring s;
3543 coe self
3545 | 0xff08 -> (* backspace *)
3546 if String.length m_qsearch = 0
3547 then coe self
3548 else (
3549 let qsearch = withoutlastutf8 m_qsearch in
3550 let len = String.length qsearch in
3551 if len = 0
3552 then (
3553 state.text <- "";
3554 G.postRedisplay "listview empty qsearch";
3555 set1 m_active m_first "";
3557 else
3558 let active, first =
3559 match search m_active qsearch ~-1 with
3560 | None ->
3561 state.text <- qsearch ^ " [not found]";
3562 m_active, m_first
3563 | Some active ->
3564 state.text <- qsearch;
3565 active, firstof m_first active
3567 G.postRedisplay "listview backspace qsearch";
3568 set1 active first qsearch
3571 | key when (key != 0 && key land 0xff00 != 0xff00) ->
3572 let pattern = m_qsearch ^ toutf8 key in
3573 let active, first =
3574 match search m_active pattern 1 with
3575 | None ->
3576 state.text <- pattern ^ " [not found]";
3577 m_active, m_first
3578 | Some active ->
3579 state.text <- pattern;
3580 active, firstof m_first active
3582 G.postRedisplay "listview qsearch add";
3583 set1 active first pattern;
3585 | 0xff1b -> (* escape *)
3586 state.text <- "";
3587 if String.length m_qsearch = 0
3588 then (
3589 G.postRedisplay "list view escape";
3590 begin
3591 match
3592 source#exit (coe self) true m_active m_first m_pan m_qsearch
3593 with
3594 | None -> m_prev_uioh
3595 | Some uioh -> uioh
3598 else (
3599 G.postRedisplay "list view kill qsearch";
3600 source#setqsearch "";
3601 coe {< m_qsearch = "" >}
3604 | 0xff0d | 0xff8d -> (* (kp) enter *)
3605 state.text <- "";
3606 let self = {< m_qsearch = "" >} in
3607 source#setqsearch "";
3608 let opt =
3609 G.postRedisplay "listview enter";
3610 if m_active >= 0 && m_active < source#getitemcount
3611 then (
3612 source#exit (coe self) false m_active m_first m_pan "";
3614 else (
3615 source#exit (coe self) true m_active m_first m_pan "";
3618 begin match opt with
3619 | None -> m_prev_uioh
3620 | Some uioh -> uioh
3623 | 0xff9f | 0xffff -> (* (kp) delete *)
3624 coe self
3626 | 0xff52 | 0xff97 -> navigate ~-1 (* (kp) up *)
3627 | 0xff54 | 0xff99 -> navigate 1 (* (kp) down *)
3628 | 0xff55 | 0xff9a -> navigate ~-(fstate.maxrows) (* (kp) prior *)
3629 | 0xff56 | 0xff9b -> navigate fstate.maxrows (* (kp) next *)
3631 | 0xff53 | 0xff98 -> (* (kp) right *)
3632 state.text <- "";
3633 G.postRedisplay "listview right";
3634 coe {< m_pan = m_pan - 1 >}
3636 | 0xff51 | 0xff96 -> (* (kp) left *)
3637 state.text <- "";
3638 G.postRedisplay "listview left";
3639 coe {< m_pan = m_pan + 1 >}
3641 | 0xff50 | 0xff95 -> (* (kp) home *)
3642 let active = find 0 1 in
3643 G.postRedisplay "listview home";
3644 set active 0;
3646 | 0xff57 | 0xff9c -> (* (kp) end *)
3647 let first = max 0 (itemcount - fstate.maxrows) in
3648 let active = find (itemcount - 1) ~-1 in
3649 G.postRedisplay "listview end";
3650 set active first;
3652 | key when (key = 0 || key land 0xff00 = 0xff00) ->
3653 coe self
3655 | _ ->
3656 dolog "listview unknown key %#x" key; coe self
3658 method key key mask =
3659 match state.mode with
3660 | Textentry te -> textentrykeyboard key mask te; coe self
3661 | _ -> self#key1 key mask
3663 method button button down x y _ =
3664 let opt =
3665 match button with
3666 | 1 when x > state.winw - conf.scrollbw ->
3667 G.postRedisplay "listview scroll";
3668 if down
3669 then
3670 let _, position, sh = self#scrollph in
3671 if y > truncate position && y < truncate (position +. sh)
3672 then (
3673 state.mstate <- Mscrolly;
3674 Some (coe self)
3676 else
3677 let s = float (max 0 (y - conf.scrollh)) /. float state.winh in
3678 let first = truncate (s *. float source#getitemcount) in
3679 let first = min source#getitemcount first in
3680 Some (coe {< m_first = first; m_active = first >})
3681 else (
3682 state.mstate <- Mnone;
3683 Some (coe self);
3685 | 1 when not down ->
3686 begin match self#elemunder y with
3687 | Some n ->
3688 G.postRedisplay "listview click";
3689 source#exit
3690 (coe {< m_active = n >}) false n m_first m_pan m_qsearch
3691 | _ ->
3692 Some (coe self)
3694 | n when (n == 4 || n == 5) && not down ->
3695 let len = source#getitemcount in
3696 let first =
3697 if n = 5 && m_first + fstate.maxrows >= len
3698 then
3699 m_first
3700 else
3701 let first = m_first + (if n == 4 then -1 else 1) in
3702 bound first 0 (len - 1)
3704 G.postRedisplay "listview wheel";
3705 Some (coe {< m_first = first >})
3706 | n when (n = 6 || n = 7) && not down ->
3707 let inc = m_first + (if n = 7 then -1 else 1) in
3708 G.postRedisplay "listview hwheel";
3709 Some (coe {< m_pan = m_pan + inc >})
3710 | _ ->
3711 Some (coe self)
3713 match opt with
3714 | None -> m_prev_uioh
3715 | Some uioh -> uioh
3717 method motion _ y =
3718 match state.mstate with
3719 | Mscrolly ->
3720 let s = float (max 0 (y - conf.scrollh)) /. float state.winh in
3721 let first = truncate (s *. float source#getitemcount) in
3722 let first = min source#getitemcount first in
3723 G.postRedisplay "listview motion";
3724 coe {< m_first = first; m_active = first >}
3725 | _ -> coe self
3727 method pmotion x y =
3728 if x < state.winw - conf.scrollbw
3729 then
3730 let n =
3731 match self#elemunder y with
3732 | None -> Wsi.setcursor Wsi.CURSOR_INHERIT; m_active
3733 | Some n -> Wsi.setcursor Wsi.CURSOR_INFO; n
3735 let o =
3736 if n != m_active
3737 then (G.postRedisplay "listview pmotion"; {< m_active = n >})
3738 else self
3740 coe o
3741 else (
3742 Wsi.setcursor Wsi.CURSOR_INHERIT;
3743 coe self
3746 method infochanged _ = ()
3748 method scrollpw = (0, 0.0, 0.0)
3749 method scrollph =
3750 let nfs = fstate.fontsize + 1 in
3751 let y = m_first * nfs in
3752 let itemcount = source#getitemcount in
3753 let maxi = max 0 (itemcount - fstate.maxrows) in
3754 let maxy = maxi * nfs in
3755 let p, h = scrollph y maxy in
3756 conf.scrollbw, p, h
3758 method modehash = modehash
3759 method eformsgs = false
3760 end;;
3762 class outlinelistview ~source =
3763 object (self)
3764 inherit listview
3765 ~source:(source :> lvsource)
3766 ~trusted:false
3767 ~modehash:(findkeyhash conf "outline")
3768 as super
3770 method key key mask =
3771 let calcfirst first active =
3772 if active > first
3773 then
3774 let rows = active - first in
3775 let maxrows =
3776 if String.length state.text = 0
3777 then fstate.maxrows
3778 else fstate.maxrows - 2
3780 if rows > maxrows then active - maxrows else first
3781 else active
3783 let navigate incr =
3784 let active = m_active + incr in
3785 let active = bound active 0 (source#getitemcount - 1) in
3786 let first = calcfirst m_first active in
3787 G.postRedisplay "outline navigate";
3788 coe {< m_active = active; m_first = first >}
3790 let ctrl = Wsi.withctrl mask in
3791 match key with
3792 | 110 when ctrl -> (* ctrl-n *)
3793 source#narrow m_qsearch;
3794 G.postRedisplay "outline ctrl-n";
3795 coe {< m_first = 0; m_active = 0 >}
3797 | 117 when ctrl -> (* ctrl-u *)
3798 source#denarrow;
3799 G.postRedisplay "outline ctrl-u";
3800 state.text <- "";
3801 coe {< m_first = 0; m_active = 0 >}
3803 | 108 when ctrl -> (* ctrl-l *)
3804 let first = max 0 (m_active - (fstate.maxrows / 2)) in
3805 G.postRedisplay "outline ctrl-l";
3806 coe {< m_first = first >}
3808 | 0xff9f | 0xffff -> (* (kp) delete *)
3809 source#remove m_active;
3810 G.postRedisplay "outline delete";
3811 let active = max 0 (m_active-1) in
3812 coe {< m_first = firstof m_first active;
3813 m_active = active >}
3815 | 0xff52 | 0xff97 -> navigate ~-1 (* (kp) up *)
3816 | 0xff54 | 0xff99 -> navigate 1 (* (kp) down *)
3817 | 0xff55 | 0xff9a -> (* (kp) prior *)
3818 navigate ~-(fstate.maxrows)
3819 | 0xff56 | 0xff9b -> (* (kp) next *)
3820 navigate fstate.maxrows
3822 | 0xff53 | 0xff98 -> (* [ctrl-] (kp) right *)
3823 let o =
3824 if ctrl
3825 then (
3826 G.postRedisplay "outline ctrl right";
3827 {< m_pan = m_pan + 1 >}
3829 else self#updownlevel 1
3831 coe o
3833 | 0xff51 | 0xff96 -> (* [ctrl-] (kp) left *)
3834 let o =
3835 if ctrl
3836 then (
3837 G.postRedisplay "outline ctrl left";
3838 {< m_pan = m_pan - 1 >}
3840 else self#updownlevel ~-1
3842 coe o
3844 | 0xff50 | 0xff95 -> (* (kp) home *)
3845 G.postRedisplay "outline home";
3846 coe {< m_first = 0; m_active = 0 >}
3848 | 0xff57 | 0xff9c -> (* (kp) end *)
3849 let active = source#getitemcount - 1 in
3850 let first = max 0 (active - fstate.maxrows) in
3851 G.postRedisplay "outline end";
3852 coe {< m_active = active; m_first = first >}
3854 | _ -> super#key key mask
3857 let outlinesource usebookmarks =
3858 let empty = [||] in
3859 (object
3860 inherit lvsourcebase
3861 val mutable m_items = empty
3862 val mutable m_orig_items = empty
3863 val mutable m_prev_items = empty
3864 val mutable m_narrow_pattern = ""
3865 val mutable m_hadremovals = false
3867 method getitemcount =
3868 Array.length m_items + (if m_hadremovals then 1 else 0)
3870 method getitem n =
3871 if n == Array.length m_items && m_hadremovals
3872 then
3873 ("[Confirm removal]", 0)
3874 else
3875 let s, n, _ = m_items.(n) in
3876 (s, n)
3878 method exit ~uioh ~cancel ~active ~first ~pan ~qsearch =
3879 ignore (uioh, first, qsearch);
3880 let confrimremoval = m_hadremovals && active = Array.length m_items in
3881 let items =
3882 if String.length m_narrow_pattern = 0
3883 then m_orig_items
3884 else m_items
3886 if not cancel
3887 then (
3888 if not confrimremoval
3889 then(
3890 let _, _, anchor = m_items.(active) in
3891 gotoghyll (getanchory anchor);
3892 m_items <- items;
3894 else (
3895 state.bookmarks <- Array.to_list m_items;
3896 m_orig_items <- m_items;
3899 else m_items <- items;
3900 m_pan <- pan;
3901 None
3903 method hasaction _ = true
3905 method greetmsg =
3906 if Array.length m_items != Array.length m_orig_items
3907 then "Narrowed to " ^ m_narrow_pattern ^ " (ctrl-u to restore)"
3908 else ""
3910 method narrow pattern =
3911 let reopt = try Some (Str.regexp_case_fold pattern) with _ -> None in
3912 match reopt with
3913 | None -> ()
3914 | Some re ->
3915 let rec loop accu n =
3916 if n = -1
3917 then (
3918 m_narrow_pattern <- pattern;
3919 m_items <- Array.of_list accu
3921 else
3922 let (s, _, _) as o = m_items.(n) in
3923 let accu =
3924 if (try ignore (Str.search_forward re s 0); true
3925 with Not_found -> false)
3926 then o :: accu
3927 else accu
3929 loop accu (n-1)
3931 loop [] (Array.length m_items - 1)
3933 method denarrow =
3934 m_orig_items <- (
3935 if usebookmarks
3936 then Array.of_list state.bookmarks
3937 else state.outlines
3939 m_items <- m_orig_items
3941 method remove m =
3942 if usebookmarks
3943 then
3944 if m >= 0 && m < Array.length m_items
3945 then (
3946 m_hadremovals <- true;
3947 m_items <- Array.init (Array.length m_items - 1) (fun n ->
3948 let n = if n >= m then n+1 else n in
3949 m_items.(n)
3953 method reset anchor items =
3954 m_hadremovals <- false;
3955 if m_orig_items == empty || m_prev_items != items
3956 then (
3957 m_orig_items <- items;
3958 if String.length m_narrow_pattern = 0
3959 then m_items <- items;
3961 m_prev_items <- items;
3962 let rely = getanchory anchor in
3963 let active =
3964 let rec loop n best bestd =
3965 if n = Array.length m_items
3966 then best
3967 else
3968 let (_, _, anchor) = m_items.(n) in
3969 let orely = getanchory anchor in
3970 let d = abs (orely - rely) in
3971 if d < bestd
3972 then loop (n+1) n d
3973 else loop (n+1) best bestd
3975 loop 0 ~-1 max_int
3977 m_active <- active;
3978 m_first <- firstof m_first active
3979 end)
3982 let enterselector usebookmarks =
3983 let source = outlinesource usebookmarks in
3984 fun errmsg ->
3985 let outlines =
3986 if usebookmarks
3987 then Array.of_list state.bookmarks
3988 else state.outlines
3990 if Array.length outlines = 0
3991 then (
3992 showtext ' ' errmsg;
3994 else (
3995 state.text <- source#greetmsg;
3996 Wsi.setcursor Wsi.CURSOR_INHERIT;
3997 let anchor = getanchor () in
3998 source#reset anchor outlines;
3999 state.uioh <- coe (new outlinelistview ~source);
4000 G.postRedisplay "enter selector";
4004 let enteroutlinemode =
4005 let f = enterselector false in
4006 fun ()-> f "Document has no outline";
4009 let enterbookmarkmode =
4010 let f = enterselector true in
4011 fun () -> f "Document has no bookmarks (yet)";
4014 let color_of_string s =
4015 Scanf.sscanf s "%d/%d/%d" (fun r g b ->
4016 (float r /. 256.0, float g /. 256.0, float b /. 256.0)
4020 let color_to_string (r, g, b) =
4021 let r = truncate (r *. 256.0)
4022 and g = truncate (g *. 256.0)
4023 and b = truncate (b *. 256.0) in
4024 Printf.sprintf "%d/%d/%d" r g b
4027 let irect_of_string s =
4028 Scanf.sscanf s "%d/%d/%d/%d" (fun x0 y0 x1 y1 -> (x0,y0,x1,y1))
4031 let irect_to_string (x0,y0,x1,y1) =
4032 Printf.sprintf "%d/%d/%d/%d" x0 y0 x1 y1
4035 let makecheckers () =
4036 (* Based on lablGL-1.04/LablGlut/examples/lablGL/checker.ml which had
4037 following to say:
4038 converted by Issac Trotts. July 25, 2002 *)
4039 let image = GlPix.create `ubyte ~format:`luminance ~width:2 ~height:2 in
4040 Raw.sets_string (GlPix.to_raw image) ~pos:0 "\255\200\200\255";
4041 let id = GlTex.gen_texture () in
4042 GlTex.bind_texture `texture_2d id;
4043 GlPix.store (`unpack_alignment 1);
4044 GlTex.image2d image;
4045 List.iter (GlTex.parameter ~target:`texture_2d)
4046 [ `mag_filter `nearest; `min_filter `nearest ];
4050 let setcheckers enabled =
4051 match state.texid with
4052 | None ->
4053 if enabled then state.texid <- Some (makecheckers ())
4055 | Some texid ->
4056 if not enabled
4057 then (
4058 GlTex.delete_texture texid;
4059 state.texid <- None;
4063 let int_of_string_with_suffix s =
4064 let l = String.length s in
4065 let s1, shift =
4066 if l > 1
4067 then
4068 let suffix = Char.lowercase s.[l-1] in
4069 match suffix with
4070 | 'k' -> String.sub s 0 (l-1), 10
4071 | 'm' -> String.sub s 0 (l-1), 20
4072 | 'g' -> String.sub s 0 (l-1), 30
4073 | _ -> s, 0
4074 else s, 0
4076 let n = int_of_string s1 in
4077 let m = n lsl shift in
4078 if m < 0 || m < n
4079 then raise (Failure "value too large")
4080 else m
4083 let string_with_suffix_of_int n =
4084 if n = 0
4085 then "0"
4086 else
4087 let n, s =
4088 if n land ((1 lsl 30) - 1) = 0
4089 then n lsr 30, "G"
4090 else (
4091 if n land ((1 lsl 20) - 1) = 0
4092 then n lsr 20, "M"
4093 else (
4094 if n land ((1 lsl 10) - 1) = 0
4095 then n lsr 10, "K"
4096 else n, ""
4100 let rec loop s n =
4101 let h = n mod 1000 in
4102 let n = n / 1000 in
4103 if n = 0
4104 then string_of_int h ^ s
4105 else (
4106 let s = Printf.sprintf "_%03d%s" h s in
4107 loop s n
4110 loop "" n ^ s;
4113 let defghyllscroll = (40, 8, 32);;
4114 let ghyllscroll_of_string s =
4115 let (n, a, b) as nab =
4116 if s = "default"
4117 then defghyllscroll
4118 else Scanf.sscanf s "%u,%u,%u" (fun n a b -> n, a, b)
4120 if n <= a || n <= b || a >= b
4121 then failwith "invalid ghyll N,A,B (N <= A, A < B, N <= B)";
4122 nab;
4125 let ghyllscroll_to_string ((n, a, b) as nab) =
4126 if nab = defghyllscroll
4127 then "default"
4128 else Printf.sprintf "%d,%d,%d" n a b;
4131 let describe_location () =
4132 let fn = page_of_y state.y in
4133 let ln = page_of_y (state.y + state.winh - state.hscrollh - 1) in
4134 let maxy = state.maxy - (if conf.maxhfit then state.winh else 0) in
4135 let percent =
4136 if maxy <= 0
4137 then 100.
4138 else (100. *. (float state.y /. float maxy))
4140 if fn = ln
4141 then
4142 Printf.sprintf "page %d of %d [%.2f%%]"
4143 (fn+1) state.pagecount percent
4144 else
4145 Printf.sprintf
4146 "pages %d-%d of %d [%.2f%%]"
4147 (fn+1) (ln+1) state.pagecount percent
4150 let setpresentationmode v =
4151 let n = page_of_y state.y in
4152 state.anchor <- (n, 0.0, 1.0);
4153 conf.presentation <- v;
4154 if conf.presentation
4155 then (
4156 if not conf.scrollbarinpm
4157 then state.scrollw <- 0;
4159 else state.scrollw <- conf.scrollbw;
4160 represent ();
4163 let enterinfomode =
4164 let btos b = if b then "\xe2\x88\x9a" else "" in
4165 let showextended = ref false in
4166 let leave mode = function
4167 | Confirm -> state.mode <- mode
4168 | Cancel -> state.mode <- mode in
4169 let src =
4170 (object
4171 val mutable m_first_time = true
4172 val mutable m_l = []
4173 val mutable m_a = [||]
4174 val mutable m_prev_uioh = nouioh
4175 val mutable m_prev_mode = View
4177 inherit lvsourcebase
4179 method reset prev_mode prev_uioh =
4180 m_a <- Array.of_list (List.rev m_l);
4181 m_l <- [];
4182 m_prev_mode <- prev_mode;
4183 m_prev_uioh <- prev_uioh;
4184 if m_first_time
4185 then (
4186 let rec loop n =
4187 if n >= Array.length m_a
4188 then ()
4189 else
4190 match m_a.(n) with
4191 | _, _, _, Action _ -> m_active <- n
4192 | _ -> loop (n+1)
4194 loop 0;
4195 m_first_time <- false;
4198 method int name get set =
4199 m_l <-
4200 (name, `int get, 1, Action (
4201 fun u ->
4202 let ondone s =
4203 try set (int_of_string s)
4204 with exn ->
4205 state.text <- Printf.sprintf "bad integer `%s': %s"
4206 s (exntos exn)
4208 state.text <- "";
4209 let te = name ^ ": ", "", None, intentry, ondone, true in
4210 state.mode <- Textentry (te, leave m_prev_mode);
4212 )) :: m_l
4214 method int_with_suffix name get set =
4215 m_l <-
4216 (name, `intws get, 1, Action (
4217 fun u ->
4218 let ondone s =
4219 try set (int_of_string_with_suffix s)
4220 with exn ->
4221 state.text <- Printf.sprintf "bad integer `%s': %s"
4222 s (exntos exn)
4224 state.text <- "";
4225 let te =
4226 name ^ ": ", "", None, intentry_with_suffix, ondone, true
4228 state.mode <- Textentry (te, leave m_prev_mode);
4230 )) :: m_l
4232 method bool ?(offset=1) ?(btos=btos) name get set =
4233 m_l <-
4234 (name, `bool (btos, get), offset, Action (
4235 fun u ->
4236 let v = get () in
4237 set (not v);
4239 )) :: m_l
4241 method color name get set =
4242 m_l <-
4243 (name, `color get, 1, Action (
4244 fun u ->
4245 let invalid = (nan, nan, nan) in
4246 let ondone s =
4247 let c =
4248 try color_of_string s
4249 with exn ->
4250 state.text <- Printf.sprintf "bad color `%s': %s"
4251 s (exntos exn);
4252 invalid
4254 if c <> invalid
4255 then set c;
4257 let te = name ^ ": ", "", None, textentry, ondone, true in
4258 state.text <- color_to_string (get ());
4259 state.mode <- Textentry (te, leave m_prev_mode);
4261 )) :: m_l
4263 method string name get set =
4264 m_l <-
4265 (name, `string get, 1, Action (
4266 fun u ->
4267 let ondone s = set s in
4268 let te = name ^ ": ", "", None, textentry, ondone, true in
4269 state.mode <- Textentry (te, leave m_prev_mode);
4271 )) :: m_l
4273 method colorspace name get set =
4274 m_l <-
4275 (name, `string get, 1, Action (
4276 fun _ ->
4277 let source =
4278 let vals = [| "rgb"; "bgr"; "gray" |] in
4279 (object
4280 inherit lvsourcebase
4282 initializer
4283 m_active <- int_of_colorspace conf.colorspace;
4284 m_first <- 0;
4286 method getitemcount = Array.length vals
4287 method getitem n = (vals.(n), 0)
4288 method exit ~uioh ~cancel ~active ~first ~pan ~qsearch =
4289 ignore (uioh, first, pan, qsearch);
4290 if not cancel then set active;
4291 None
4292 method hasaction _ = true
4293 end)
4295 state.text <- "";
4296 let modehash = findkeyhash conf "info" in
4297 coe (new listview ~source ~trusted:true ~modehash)
4298 )) :: m_l
4300 method fitmodel name get set =
4301 m_l <-
4302 (name, `string get, 1, Action (
4303 fun _ ->
4304 let source =
4305 let vals = [| "fit width"; "proportional"; "fit page" |] in
4306 (object
4307 inherit lvsourcebase
4309 initializer
4310 m_active <- int_of_fitmodel conf.fitmodel;
4311 m_first <- 0;
4313 method getitemcount = Array.length vals
4314 method getitem n = (vals.(n), 0)
4315 method exit ~uioh ~cancel ~active ~first ~pan ~qsearch =
4316 ignore (uioh, first, pan, qsearch);
4317 if not cancel then set active;
4318 None
4319 method hasaction _ = true
4320 end)
4322 state.text <- "";
4323 let modehash = findkeyhash conf "info" in
4324 coe (new listview ~source ~trusted:true ~modehash)
4325 )) :: m_l
4327 method caption s offset =
4328 m_l <- (s, `empty, offset, Noaction) :: m_l
4330 method caption2 s f offset =
4331 m_l <- (s, `string f, offset, Noaction) :: m_l
4333 method getitemcount = Array.length m_a
4335 method getitem n =
4336 let tostr = function
4337 | `int f -> string_of_int (f ())
4338 | `intws f -> string_with_suffix_of_int (f ())
4339 | `string f -> f ()
4340 | `color f -> color_to_string (f ())
4341 | `bool (btos, f) -> btos (f ())
4342 | `empty -> ""
4344 let name, t, offset, _ = m_a.(n) in
4345 ((let s = tostr t in
4346 if String.length s > 0
4347 then Printf.sprintf "%s\t%s" name s
4348 else name),
4349 offset)
4351 method exit ~uioh ~cancel ~active ~first ~pan ~qsearch =
4352 let uiohopt =
4353 if not cancel
4354 then (
4355 m_qsearch <- qsearch;
4356 let uioh =
4357 match m_a.(active) with
4358 | _, _, _, Action f -> f uioh
4359 | _ -> uioh
4361 Some uioh
4363 else None
4365 m_active <- active;
4366 m_first <- first;
4367 m_pan <- pan;
4368 uiohopt
4370 method hasaction n =
4371 match m_a.(n) with
4372 | _, _, _, Action _ -> true
4373 | _ -> false
4374 end)
4376 let rec fillsrc prevmode prevuioh =
4377 let sep () = src#caption "" 0 in
4378 let colorp name get set =
4379 src#string name
4380 (fun () -> color_to_string (get ()))
4381 (fun v ->
4383 let c = color_of_string v in
4384 set c
4385 with exn ->
4386 state.text <- Printf.sprintf "bad color `%s': %s" v (exntos exn)
4389 let oldmode = state.mode in
4390 let birdseye = isbirdseye state.mode in
4392 src#caption (if birdseye then "Setup (Bird's eye)" else "Setup") 0;
4394 src#bool "presentation mode"
4395 (fun () -> conf.presentation)
4396 (fun v -> setpresentationmode v);
4398 src#bool "ignore case in searches"
4399 (fun () -> conf.icase)
4400 (fun v -> conf.icase <- v);
4402 src#bool "preload"
4403 (fun () -> conf.preload)
4404 (fun v -> conf.preload <- v);
4406 src#bool "highlight links"
4407 (fun () -> conf.hlinks)
4408 (fun v -> conf.hlinks <- v);
4410 src#bool "under info"
4411 (fun () -> conf.underinfo)
4412 (fun v -> conf.underinfo <- v);
4414 src#bool "persistent bookmarks"
4415 (fun () -> conf.savebmarks)
4416 (fun v -> conf.savebmarks <- v);
4418 src#fitmodel "fit model"
4419 (fun () -> fitmodel_to_string conf.fitmodel)
4420 (fun v -> reqlayout conf.angle (fitmodel_of_int v));
4422 src#bool "trim margins"
4423 (fun () -> conf.trimmargins)
4424 (fun v -> settrim v conf.trimfuzz; fillsrc prevmode prevuioh);
4426 src#bool "persistent location"
4427 (fun () -> conf.jumpback)
4428 (fun v -> conf.jumpback <- v);
4430 sep ();
4431 src#int "inter-page space"
4432 (fun () -> conf.interpagespace)
4433 (fun n ->
4434 conf.interpagespace <- n;
4435 docolumns conf.columns;
4436 let pageno, py =
4437 match state.layout with
4438 | [] -> 0, 0
4439 | l :: _ ->
4440 l.pageno, l.pagey
4442 state.maxy <- calcheight ();
4443 let y = getpagey pageno in
4444 gotoy (y + py)
4447 src#int "page bias"
4448 (fun () -> conf.pagebias)
4449 (fun v -> conf.pagebias <- v);
4451 src#int "scroll step"
4452 (fun () -> conf.scrollstep)
4453 (fun n -> conf.scrollstep <- n);
4455 src#int "horizontal scroll step"
4456 (fun () -> conf.hscrollstep)
4457 (fun v -> conf.hscrollstep <- v);
4459 src#int "auto scroll step"
4460 (fun () ->
4461 match state.autoscroll with
4462 | Some step -> step
4463 | _ -> conf.autoscrollstep)
4464 (fun n ->
4465 if state.autoscroll <> None
4466 then state.autoscroll <- Some n;
4467 conf.autoscrollstep <- n);
4469 src#int "zoom"
4470 (fun () -> truncate (conf.zoom *. 100.))
4471 (fun v -> setzoom ((float v) /. 100.));
4473 src#int "rotation"
4474 (fun () -> conf.angle)
4475 (fun v -> reqlayout v conf.fitmodel);
4477 src#int "scroll bar width"
4478 (fun () -> state.scrollw)
4479 (fun v ->
4480 state.scrollw <- v;
4481 conf.scrollbw <- v;
4482 reshape state.winw state.winh;
4485 src#int "scroll handle height"
4486 (fun () -> conf.scrollh)
4487 (fun v -> conf.scrollh <- v;);
4489 src#int "thumbnail width"
4490 (fun () -> conf.thumbw)
4491 (fun v ->
4492 conf.thumbw <- min 4096 v;
4493 match oldmode with
4494 | Birdseye beye ->
4495 leavebirdseye beye false;
4496 enterbirdseye ()
4497 | _ -> ()
4500 let mode = state.mode in
4501 src#string "columns"
4502 (fun () ->
4503 match conf.columns with
4504 | Csingle _ -> "1"
4505 | Cmulti (multi, _) -> multicolumns_to_string multi
4506 | Csplit (count, _) -> "-" ^ string_of_int count
4508 (fun v ->
4509 let n, a, b = multicolumns_of_string v in
4510 setcolumns mode n a b);
4512 sep ();
4513 src#caption "Presentation mode" 0;
4514 src#bool "scrollbar visible"
4515 (fun () -> conf.scrollbarinpm)
4516 (fun v ->
4517 if v != conf.scrollbarinpm
4518 then (
4519 conf.scrollbarinpm <- v;
4520 if conf.presentation
4521 then (
4522 state.scrollw <- if v then conf.scrollbw else 0;
4523 reshape state.winw state.winh;
4528 sep ();
4529 src#caption "Pixmap cache" 0;
4530 src#int_with_suffix "size (advisory)"
4531 (fun () -> conf.memlimit)
4532 (fun v -> conf.memlimit <- v);
4534 src#caption2 "used"
4535 (fun () -> Printf.sprintf "%s bytes, %d tiles"
4536 (string_with_suffix_of_int state.memused)
4537 (Hashtbl.length state.tilemap)) 1;
4539 sep ();
4540 src#caption "Layout" 0;
4541 src#caption2 "Dimension"
4542 (fun () ->
4543 Printf.sprintf "%dx%d (virtual %dx%d)"
4544 state.winw state.winh
4545 state.w state.maxy)
4547 if conf.debug
4548 then
4549 src#caption2 "Position" (fun () ->
4550 Printf.sprintf "%dx%d" state.x state.y
4552 else
4553 src#caption2 "Position" (fun () -> describe_location ()) 1
4556 sep ();
4557 src#bool ~offset:0 ~btos:(fun v -> if v then "(on)" else "(off)")
4558 "Save these parameters as global defaults at exit"
4559 (fun () -> conf.bedefault)
4560 (fun v -> conf.bedefault <- v)
4563 sep ();
4564 let btos b = if b then "\xc2\xab" else "\xc2\xbb" in
4565 src#bool ~offset:0 ~btos "Extended parameters"
4566 (fun () -> !showextended)
4567 (fun v -> showextended := v; fillsrc prevmode prevuioh);
4568 if !showextended
4569 then (
4570 src#bool "checkers"
4571 (fun () -> conf.checkers)
4572 (fun v -> conf.checkers <- v; setcheckers v);
4573 src#bool "update cursor"
4574 (fun () -> conf.updatecurs)
4575 (fun v -> conf.updatecurs <- v);
4576 src#bool "verbose"
4577 (fun () -> conf.verbose)
4578 (fun v -> conf.verbose <- v);
4579 src#bool "invert colors"
4580 (fun () -> conf.invert)
4581 (fun v -> conf.invert <- v);
4582 src#bool "max fit"
4583 (fun () -> conf.maxhfit)
4584 (fun v -> conf.maxhfit <- v);
4585 src#bool "redirect stderr"
4586 (fun () -> conf.redirectstderr)
4587 (fun v -> conf.redirectstderr <- v; redirectstderr ());
4588 src#string "uri launcher"
4589 (fun () -> conf.urilauncher)
4590 (fun v -> conf.urilauncher <- v);
4591 src#string "path launcher"
4592 (fun () -> conf.pathlauncher)
4593 (fun v -> conf.pathlauncher <- v);
4594 src#string "tile size"
4595 (fun () -> Printf.sprintf "%dx%d" conf.tilew conf.tileh)
4596 (fun v ->
4598 let w, h = Scanf.sscanf v "%dx%d" (fun w h -> w, h) in
4599 conf.tilew <- max 64 w;
4600 conf.tileh <- max 64 h;
4601 flushtiles ();
4602 with exn ->
4603 state.text <- Printf.sprintf "bad tile size `%s': %s"
4604 v (exntos exn)
4606 src#int "texture count"
4607 (fun () -> conf.texcount)
4608 (fun v ->
4609 if realloctexts v
4610 then conf.texcount <- v
4611 else showtext '!' " Failed to set texture count please retry later"
4613 src#int "slice height"
4614 (fun () -> conf.sliceheight)
4615 (fun v ->
4616 conf.sliceheight <- v;
4617 wcmd "sliceh %d" conf.sliceheight;
4619 src#int "anti-aliasing level"
4620 (fun () -> conf.aalevel)
4621 (fun v ->
4622 conf.aalevel <- bound v 0 8;
4623 state.anchor <- getanchor ();
4624 opendoc state.path state.password;
4626 src#string "page scroll scaling factor"
4627 (fun () -> string_of_float conf.pgscale)
4628 (fun v ->
4630 let s = float_of_string v in
4631 conf.pgscale <- s
4632 with exn ->
4633 state.text <- Printf.sprintf
4634 "bad page scroll scaling factor `%s': %s" v (exntos exn)
4637 src#int "ui font size"
4638 (fun () -> fstate.fontsize)
4639 (fun v -> setfontsize (bound v 5 100));
4640 src#int "hint font size"
4641 (fun () -> conf.hfsize)
4642 (fun v -> conf.hfsize <- bound v 5 100);
4643 colorp "background color"
4644 (fun () -> conf.bgcolor)
4645 (fun v -> conf.bgcolor <- v);
4646 src#bool "crop hack"
4647 (fun () -> conf.crophack)
4648 (fun v -> conf.crophack <- v);
4649 src#string "trim fuzz"
4650 (fun () -> irect_to_string conf.trimfuzz)
4651 (fun v ->
4653 conf.trimfuzz <- irect_of_string v;
4654 if conf.trimmargins
4655 then settrim true conf.trimfuzz;
4656 with exn ->
4657 state.text <- Printf.sprintf "bad irect `%s': %s" v (exntos exn)
4659 src#string "throttle"
4660 (fun () ->
4661 match conf.maxwait with
4662 | None -> "show place holder if page is not ready"
4663 | Some time ->
4664 if time = infinity
4665 then "wait for page to fully render"
4666 else
4667 "wait " ^ string_of_float time
4668 ^ " seconds before showing placeholder"
4670 (fun v ->
4672 let f = float_of_string v in
4673 if f <= 0.0
4674 then conf.maxwait <- None
4675 else conf.maxwait <- Some f
4676 with exn ->
4677 state.text <- Printf.sprintf "bad time `%s': %s" v (exntos exn)
4679 src#string "ghyll scroll"
4680 (fun () ->
4681 match conf.ghyllscroll with
4682 | None -> ""
4683 | Some nab -> ghyllscroll_to_string nab
4685 (fun v ->
4687 let gs =
4688 if String.length v = 0
4689 then None
4690 else Some (ghyllscroll_of_string v)
4692 conf.ghyllscroll <- gs
4693 with exn ->
4694 state.text <- Printf.sprintf "bad ghyll `%s': %s" v (exntos exn)
4696 src#string "selection command"
4697 (fun () -> conf.selcmd)
4698 (fun v -> conf.selcmd <- v);
4699 src#string "synctex command"
4700 (fun () -> conf.stcmd)
4701 (fun v -> conf.stcmd <- v);
4702 src#colorspace "color space"
4703 (fun () -> colorspace_to_string conf.colorspace)
4704 (fun v ->
4705 conf.colorspace <- colorspace_of_int v;
4706 wcmd "cs %d" v;
4707 load state.layout;
4709 if pbousable ()
4710 then
4711 src#bool "use PBO"
4712 (fun () -> conf.usepbo)
4713 (fun v -> conf.usepbo <- v);
4714 src#bool "mouse wheel scrolls pages"
4715 (fun () -> conf.wheelbypage)
4716 (fun v -> conf.wheelbypage <- v);
4719 sep ();
4720 src#caption "Document" 0;
4721 List.iter (fun (_, s) -> src#caption s 1) state.docinfo;
4722 src#caption2 "Pages"
4723 (fun () -> string_of_int state.pagecount) 1;
4724 src#caption2 "Dimensions"
4725 (fun () -> string_of_int (List.length state.pdims)) 1;
4726 if conf.trimmargins
4727 then (
4728 sep ();
4729 src#caption "Trimmed margins" 0;
4730 src#caption2 "Dimensions"
4731 (fun () -> string_of_int (List.length state.pdims)) 1;
4734 sep ();
4735 src#caption "OpenGL" 0;
4736 src#caption (Printf.sprintf "Vendor\t%s" (GlMisc.get_string `vendor)) 1;
4737 src#caption (Printf.sprintf "Renderer\t%s" (GlMisc.get_string `renderer)) 1;
4739 sep ();
4740 src#caption "Location" 0;
4741 src#caption ("Path\t" ^ mbtoutf8 state.path) 1;
4742 if String.length state.origin > 0
4743 then src#caption ("Orign\t" ^ mbtoutf8 state.origin) 1;
4745 src#reset prevmode prevuioh;
4747 fun () ->
4748 state.text <- "";
4749 let prevmode = state.mode
4750 and prevuioh = state.uioh in
4751 fillsrc prevmode prevuioh;
4752 let source = (src :> lvsource) in
4753 let modehash = findkeyhash conf "info" in
4754 state.uioh <- coe (object (self)
4755 inherit listview ~source ~trusted:true ~modehash as super
4756 val mutable m_prevmemused = 0
4757 method infochanged = function
4758 | Memused ->
4759 if m_prevmemused != state.memused
4760 then (
4761 m_prevmemused <- state.memused;
4762 G.postRedisplay "memusedchanged";
4764 | Pdim -> G.postRedisplay "pdimchanged"
4765 | Docinfo -> fillsrc prevmode prevuioh
4767 method key key mask =
4768 if not (Wsi.withctrl mask)
4769 then
4770 match key with
4771 | 0xff51 | 0xff96 -> coe (self#updownlevel ~-1) (* (kp) left *)
4772 | 0xff53 | 0xff98 -> coe (self#updownlevel 1) (* (kp) right *)
4773 | _ -> super#key key mask
4774 else super#key key mask
4775 end);
4776 G.postRedisplay "info";
4779 let enterhelpmode =
4780 let source =
4781 (object
4782 inherit lvsourcebase
4783 method getitemcount = Array.length state.help
4784 method getitem n =
4785 let s, l, _ = state.help.(n) in
4786 (s, l)
4788 method exit ~uioh ~cancel ~active ~first ~pan ~qsearch =
4789 let optuioh =
4790 if not cancel
4791 then (
4792 m_qsearch <- qsearch;
4793 match state.help.(active) with
4794 | _, _, Action f -> Some (f uioh)
4795 | _ -> Some (uioh)
4797 else None
4799 m_active <- active;
4800 m_first <- first;
4801 m_pan <- pan;
4802 optuioh
4804 method hasaction n =
4805 match state.help.(n) with
4806 | _, _, Action _ -> true
4807 | _ -> false
4809 initializer
4810 m_active <- -1
4811 end)
4812 in fun () ->
4813 let modehash = findkeyhash conf "help" in
4814 state.uioh <- coe (new listview ~source ~trusted:true ~modehash);
4815 G.postRedisplay "help";
4818 let entermsgsmode =
4819 let msgsource =
4820 let re = Str.regexp "[\r\n]" in
4821 (object
4822 inherit lvsourcebase
4823 val mutable m_items = [||]
4825 method getitemcount = 1 + Array.length m_items
4827 method getitem n =
4828 if n = 0
4829 then "[Clear]", 0
4830 else m_items.(n-1), 0
4832 method exit ~uioh ~cancel ~active ~first ~pan ~qsearch =
4833 ignore uioh;
4834 if not cancel
4835 then (
4836 if active = 0
4837 then Buffer.clear state.errmsgs;
4838 m_qsearch <- qsearch;
4840 m_active <- active;
4841 m_first <- first;
4842 m_pan <- pan;
4843 None
4845 method hasaction n =
4846 n = 0
4848 method reset =
4849 state.newerrmsgs <- false;
4850 let l = Str.split re (Buffer.contents state.errmsgs) in
4851 m_items <- Array.of_list l
4853 initializer
4854 m_active <- 0
4855 end)
4856 in fun () ->
4857 state.text <- "";
4858 msgsource#reset;
4859 let source = (msgsource :> lvsource) in
4860 let modehash = findkeyhash conf "listview" in
4861 state.uioh <- coe (object
4862 inherit listview ~source ~trusted:false ~modehash as super
4863 method display =
4864 if state.newerrmsgs
4865 then msgsource#reset;
4866 super#display
4867 end);
4868 G.postRedisplay "msgs";
4871 let quickbookmark ?title () =
4872 match state.layout with
4873 | [] -> ()
4874 | l :: _ ->
4875 let title =
4876 match title with
4877 | None ->
4878 let sec = Unix.gettimeofday () in
4879 let tm = Unix.localtime sec in
4880 Printf.sprintf "Quick (page %d) (bookmarked at %d/%d/%d %d:%d)"
4881 (l.pageno+1)
4882 tm.Unix.tm_mday
4883 tm.Unix.tm_mon
4884 (tm.Unix.tm_year + 1900)
4885 tm.Unix.tm_hour
4886 tm.Unix.tm_min
4887 | Some title -> title
4889 state.bookmarks <- (title, 0, getanchor1 l) :: state.bookmarks
4892 let setautoscrollspeed step goingdown =
4893 let incr = max 1 ((abs step) / 2) in
4894 let incr = if goingdown then incr else -incr in
4895 let astep = step + incr in
4896 state.autoscroll <- Some astep;
4899 let gotounder = function
4900 | Ulinkgoto (pageno, top) ->
4901 if pageno >= 0
4902 then (
4903 addnav ();
4904 gotopage1 pageno top;
4907 | Ulinkuri s ->
4908 gotouri s
4910 | Uremote (filename, pageno) ->
4911 let path =
4912 if Sys.file_exists filename
4913 then filename
4914 else
4915 let dir = Filename.dirname state.path in
4916 let path = Filename.concat dir filename in
4917 if Sys.file_exists path
4918 then path
4919 else ""
4921 if String.length path > 0
4922 then (
4923 let anchor = getanchor () in
4924 let ranchor = state.path, state.password, anchor, state.origin in
4925 state.origin <- "";
4926 state.anchor <- (pageno, 0.0, 0.0);
4927 state.ranchors <- ranchor :: state.ranchors;
4928 opendoc path "";
4930 else showtext '!' ("Could not find " ^ filename)
4932 | Uunexpected _ | Ulaunch _ | Unamed _ | Utext _ | Unone -> ()
4935 let canpan () =
4936 match conf.columns with
4937 | Csplit _ -> true
4938 | _ -> state.x != 0 || conf.zoom > 1.0
4941 let existsinrow pageno (columns, coverA, coverB) p =
4942 let last = ((pageno - coverA) mod columns) + columns in
4943 let rec any = function
4944 | [] -> false
4945 | l :: rest ->
4946 if l.pageno = coverA - 1 || l.pageno = state.pagecount - coverB
4947 then p l
4948 else (
4949 if not (p l)
4950 then (if l.pageno = last then false else any rest)
4951 else true
4954 any state.layout
4957 let nextpage () =
4958 match state.layout with
4959 | [] ->
4960 let pageno = page_of_y state.y in
4961 gotoghyll (getpagey (pageno+1))
4962 | l :: rest ->
4963 match conf.columns with
4964 | Csingle _ ->
4965 if conf.presentation && rest == [] && l.pageh > l.pagey + l.pagevh
4966 then
4967 let y = clamp (pgscale state.winh) in
4968 gotoghyll y
4969 else
4970 let pageno = min (l.pageno+1) (state.pagecount-1) in
4971 gotoghyll (getpagey pageno)
4972 | Cmulti ((c, _, _) as cl, _) ->
4973 if conf.presentation
4974 && (existsinrow l.pageno cl
4975 (fun l -> l.pageh > l.pagey + l.pagevh))
4976 then
4977 let y = clamp (pgscale state.winh) in
4978 gotoghyll y
4979 else
4980 let pageno = min (l.pageno+c) (state.pagecount-1) in
4981 gotoghyll (getpagey pageno)
4982 | Csplit (n, _) ->
4983 if l.pageno < state.pagecount - 1 || l.pagecol < n - 1
4984 then
4985 let pagey, pageh = getpageyh l.pageno in
4986 let pagey = pagey + pageh * l.pagecol in
4987 let ips = if l.pagecol = 0 then 0 else conf.interpagespace in
4988 gotoghyll (pagey + pageh + ips)
4991 let prevpage () =
4992 match state.layout with
4993 | [] ->
4994 let pageno = page_of_y state.y in
4995 gotoghyll (getpagey (pageno-1))
4996 | l :: _ ->
4997 match conf.columns with
4998 | Csingle _ ->
4999 if conf.presentation && l.pagey != 0
5000 then
5001 gotoghyll (clamp (pgscale ~-(state.winh)))
5002 else
5003 let pageno = max 0 (l.pageno-1) in
5004 gotoghyll (getpagey pageno)
5005 | Cmulti ((c, _, coverB) as cl, _) ->
5006 if conf.presentation &&
5007 (existsinrow l.pageno cl (fun l -> l.pagey != 0))
5008 then
5009 gotoghyll (clamp (pgscale ~-(state.winh)))
5010 else
5011 let decr =
5012 if l.pageno = state.pagecount - coverB
5013 then 1
5014 else c
5016 let pageno = max 0 (l.pageno-decr) in
5017 gotoghyll (getpagey pageno)
5018 | Csplit (n, _) ->
5019 let y =
5020 if l.pagecol = 0
5021 then
5022 if l.pageno = 0
5023 then l.pagey
5024 else
5025 let pageno = max 0 (l.pageno-1) in
5026 let pagey, pageh = getpageyh pageno in
5027 pagey + (n-1)*pageh
5028 else
5029 let pagey, pageh = getpageyh l.pageno in
5030 pagey + pageh * (l.pagecol-1) - conf.interpagespace
5032 gotoghyll y
5035 let viewkeyboard key mask =
5036 let enttext te =
5037 let mode = state.mode in
5038 state.mode <- Textentry (te, fun _ -> state.mode <- mode);
5039 state.text <- "";
5040 enttext ();
5041 G.postRedisplay "view:enttext"
5043 let ctrl = Wsi.withctrl mask in
5044 let key =
5045 if key >= 0xffb0 && key < 0xffb9 then key - 0xffb0 + 48 else key
5047 match key with
5048 | 81 -> (* Q *)
5049 exit 0
5051 | 0xff63 -> (* insert *)
5052 if conf.angle mod 360 = 0 && not (isbirdseye state.mode)
5053 then (
5054 state.mode <- LinkNav (Ltgendir 0);
5055 gotoy state.y;
5057 else showtext '!' "Keyboard link navigation does not work under rotation"
5059 | 0xff1b | 113 -> (* escape / q *)
5060 begin match state.mstate with
5061 | Mzoomrect _ ->
5062 state.mstate <- Mnone;
5063 Wsi.setcursor Wsi.CURSOR_INHERIT;
5064 G.postRedisplay "kill zoom rect";
5065 | _ ->
5066 begin match state.mode with
5067 | LinkNav _ ->
5068 state.mode <- View;
5069 G.postRedisplay "esc leave linknav"
5070 | _ ->
5071 match state.ranchors with
5072 | [] -> raise Quit
5073 | (path, password, anchor, origin) :: rest ->
5074 state.ranchors <- rest;
5075 state.anchor <- anchor;
5076 state.origin <- origin;
5077 opendoc path password
5078 end;
5079 end;
5081 | 0xff08 -> (* backspace *)
5082 gotoghyll (getnav ~-1)
5084 | 111 -> (* o *)
5085 enteroutlinemode ()
5087 | 117 -> (* u *)
5088 state.rects <- [];
5089 state.text <- "";
5090 G.postRedisplay "dehighlight";
5092 | 47 | 63 -> (* / ? *)
5093 let ondone isforw s =
5094 cbput state.hists.pat s;
5095 state.searchpattern <- s;
5096 search s isforw
5098 let s = String.create 1 in
5099 s.[0] <- Char.chr key;
5100 enttext (s, "", Some (onhist state.hists.pat),
5101 textentry, ondone (key = 47), true)
5103 | 43 | 0xffab | 61 when ctrl -> (* ctrl-+ or ctrl-= *)
5104 let incr = if conf.zoom +. 0.01 > 0.1 then 0.1 else 0.01 in
5105 setzoom (conf.zoom +. incr)
5107 | 43 | 0xffab -> (* + *)
5108 let ondone s =
5109 let n =
5110 try int_of_string s with exc ->
5111 state.text <- Printf.sprintf "bad integer `%s': %s" s (exntos exc);
5112 max_int
5114 if n != max_int
5115 then (
5116 conf.pagebias <- n;
5117 state.text <- "page bias is now " ^ string_of_int n;
5120 enttext ("page bias: ", "", None, intentry, ondone, true)
5122 | 45 | 0xffad when ctrl -> (* ctrl-- *)
5123 let decr = if conf.zoom -. 0.1 < 0.1 then 0.01 else 0.1 in
5124 setzoom (max 0.01 (conf.zoom -. decr))
5126 | 45 | 0xffad -> (* - *)
5127 let ondone msg = state.text <- msg in
5128 enttext (
5129 "option [acfhilpstvxACFPRSZTIS]: ", "", None,
5130 optentry state.mode, ondone, true
5133 | 48 when ctrl -> (* ctrl-0 *)
5134 if conf.zoom = 1.0
5135 then (
5136 state.x <- 0;
5137 state.hscrollh <-
5138 if state.w <= state.winw - state.scrollw
5139 then 0
5140 else state.scrollw
5142 gotoy state.y
5144 else setzoom 1.0
5146 | (49 | 50) when ctrl && conf.fitmodel != FitPage -> (* ctrl-1/2 *)
5147 let cols =
5148 match conf.columns with
5149 | Csingle _ | Cmulti _ -> 1
5150 | Csplit (n, _) -> n
5152 let h = state.winh -
5153 conf.interpagespace lsl (if conf.presentation then 1 else 0)
5155 let zoom = zoomforh state.winw h state.scrollw cols in
5156 if zoom > 0.0 && (key = 50 || zoom < 1.0)
5157 then setzoom zoom
5159 | 51 when ctrl -> (* ctrl-3 *)
5160 let fm =
5161 match conf.fitmodel with
5162 | FitWidth -> FitProportional
5163 | FitProportional -> FitPage
5164 | FitPage -> FitWidth
5166 state.text <- "fit model: " ^ fitmodel_to_string fm;
5167 reqlayout conf.angle fm
5169 | 0xffc6 -> (* f9 *)
5170 togglebirdseye ()
5172 | 57 when ctrl -> (* ctrl-9 *)
5173 togglebirdseye ()
5175 | (48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57)
5176 when not ctrl -> (* 0..9 *)
5177 let ondone s =
5178 let n =
5179 try int_of_string s with exc ->
5180 state.text <- Printf.sprintf "bad integer `%s': %s" s (exntos exc);
5183 if n >= 0
5184 then (
5185 addnav ();
5186 cbput state.hists.pag (string_of_int n);
5187 gotopage1 (n + conf.pagebias - 1) 0;
5190 let pageentry text key =
5191 match Char.unsafe_chr key with
5192 | 'g' -> TEdone text
5193 | _ -> intentry text key
5195 let text = "x" in text.[0] <- Char.chr key;
5196 enttext (":", text, Some (onhist state.hists.pag), pageentry, ondone, true)
5198 | 98 -> (* b *)
5199 state.scrollw <- if state.scrollw > 0 then 0 else conf.scrollbw;
5200 reshape state.winw state.winh;
5202 | 108 -> (* l *)
5203 conf.hlinks <- not conf.hlinks;
5204 state.text <- "highlightlinks " ^ if conf.hlinks then "on" else "off";
5205 G.postRedisplay "toggle highlightlinks";
5207 | 70 -> (* F *)
5208 state.glinks <- true;
5209 let mode = state.mode in
5210 state.mode <- Textentry (
5211 (":", "", None, linknentry, linkndone gotounder, false),
5212 (fun _ ->
5213 state.glinks <- false;
5214 state.mode <- mode)
5216 state.text <- "";
5217 G.postRedisplay "view:linkent(F)"
5219 | 121 -> (* y *)
5220 state.glinks <- true;
5221 let mode = state.mode in
5222 state.mode <- Textentry (
5224 ":", "", None, linknentry, linkndone (fun under ->
5225 selstring (undertext under);
5226 ), false
5228 fun _ ->
5229 state.glinks <- false;
5230 state.mode <- mode
5232 state.text <- "";
5233 G.postRedisplay "view:linkent"
5235 | 97 -> (* a *)
5236 begin match state.autoscroll with
5237 | Some step ->
5238 conf.autoscrollstep <- step;
5239 state.autoscroll <- None
5240 | None ->
5241 if conf.autoscrollstep = 0
5242 then state.autoscroll <- Some 1
5243 else state.autoscroll <- Some conf.autoscrollstep
5246 | 112 when ctrl -> (* ctrl-p *)
5247 launchpath ()
5249 | 80 -> (* P *)
5250 setpresentationmode (not conf.presentation);
5251 showtext ' ' ("presentation mode " ^
5252 if conf.presentation then "on" else "off");
5254 | 102 -> (* f *)
5255 if List.mem Wsi.Fullscreen state.winstate
5256 then Wsi.reshape conf.cwinw conf.cwinh
5257 else Wsi.fullscreen ()
5259 | 112 | 78 -> (* p|N *)
5260 search state.searchpattern false
5262 | 110 | 0xffc0 -> (* n|F3 *)
5263 search state.searchpattern true
5265 | 116 -> (* t *)
5266 begin match state.layout with
5267 | [] -> ()
5268 | l :: _ ->
5269 gotoghyll (getpagey l.pageno)
5272 | 32 -> (* space *)
5273 nextpage ()
5275 | 0xff9f | 0xffff -> (* delete *)
5276 prevpage ()
5278 | 61 -> (* = *)
5279 showtext ' ' (describe_location ());
5281 | 119 -> (* w *)
5282 begin match state.layout with
5283 | [] -> ()
5284 | l :: _ ->
5285 Wsi.reshape (l.pagew + state.scrollw) l.pageh;
5286 G.postRedisplay "w"
5289 | 39 -> (* ' *)
5290 enterbookmarkmode ()
5292 | 104 | 0xffbe -> (* h|F1 *)
5293 enterhelpmode ()
5295 | 105 -> (* i *)
5296 enterinfomode ()
5298 | 101 when Buffer.length state.errmsgs > 0 -> (* e *)
5299 entermsgsmode ()
5301 | 109 -> (* m *)
5302 let ondone s =
5303 match state.layout with
5304 | l :: _ ->
5305 if String.length s > 0
5306 then
5307 state.bookmarks <- (s, 0, getanchor1 l) :: state.bookmarks
5308 | _ -> ()
5310 enttext ("bookmark: ", "", None, textentry, ondone, true)
5312 | 126 -> (* ~ *)
5313 quickbookmark ();
5314 showtext ' ' "Quick bookmark added";
5316 | 122 -> (* z *)
5317 begin match state.layout with
5318 | l :: _ ->
5319 let rect = getpdimrect l.pagedimno in
5320 let w, h =
5321 if conf.crophack
5322 then
5323 (truncate (1.8 *. (rect.(1) -. rect.(0))),
5324 truncate (1.2 *. (rect.(3) -. rect.(0))))
5325 else
5326 (truncate (rect.(1) -. rect.(0)),
5327 truncate (rect.(3) -. rect.(0)))
5329 let w = truncate ((float w)*.conf.zoom)
5330 and h = truncate ((float h)*.conf.zoom) in
5331 if w != 0 && h != 0
5332 then (
5333 state.anchor <- getanchor ();
5334 Wsi.reshape (w + state.scrollw) (h + conf.interpagespace)
5336 G.postRedisplay "z";
5338 | [] -> ()
5341 | 60 | 62 -> (* < > *)
5342 reqlayout (conf.angle + (if key = 62 then 30 else -30)) conf.fitmodel
5344 | 91 | 93 -> (* [ ] *)
5345 conf.colorscale <-
5346 bound (conf.colorscale +. (if key = 93 then 0.1 else -0.1)) 0.0 1.0
5348 G.postRedisplay "brightness";
5350 | 99 when state.mode = View -> (* c *)
5351 let (c, a, b), z =
5352 match state.prevcolumns with
5353 | None -> (1, 0, 0), 1.0
5354 | Some (columns, z) ->
5355 let cab =
5356 match columns with
5357 | Csplit (c, _) -> -c, 0, 0
5358 | Cmulti ((c, a, b), _) -> c, a, b
5359 | Csingle _ -> 1, 0, 0
5361 cab, z
5363 setcolumns View c a b;
5364 setzoom z;
5366 | 0xff54 | 0xff52 when ctrl && Wsi.withshift mask ->
5367 setzoom state.prevzoom
5369 | 107 | 0xff52 | 0xff97 -> (* k (kp) up *)
5370 begin match state.autoscroll with
5371 | None ->
5372 begin match state.mode with
5373 | Birdseye beye -> upbirdseye 1 beye
5374 | _ ->
5375 if ctrl
5376 then gotoy_and_clear_text (clamp ~-(state.winh/2))
5377 else (
5378 if not (Wsi.withshift mask) && conf.presentation
5379 then prevpage ()
5380 else gotoy_and_clear_text (clamp (-conf.scrollstep))
5383 | Some n ->
5384 setautoscrollspeed n false
5387 | 106 | 0xff54 | 0xff99 -> (* j (kp) down *)
5388 begin match state.autoscroll with
5389 | None ->
5390 begin match state.mode with
5391 | Birdseye beye -> downbirdseye 1 beye
5392 | _ ->
5393 if ctrl
5394 then gotoy_and_clear_text (clamp (state.winh/2))
5395 else (
5396 if not (Wsi.withshift mask) && conf.presentation
5397 then nextpage ()
5398 else gotoy_and_clear_text (clamp conf.scrollstep)
5401 | Some n ->
5402 setautoscrollspeed n true
5405 | 0xff51 | 0xff53 | 0xff96 | 0xff98
5406 when not (Wsi.withalt mask) -> (* (kp) left / right *)
5407 if canpan ()
5408 then
5409 let dx =
5410 if ctrl
5411 then state.winw / 2
5412 else conf.hscrollstep
5414 let dx = if key = 0xff51 or key = 0xff96 then dx else -dx in
5415 state.x <- state.x + dx;
5416 gotoy_and_clear_text state.y
5417 else (
5418 state.text <- "";
5419 G.postRedisplay "lef/right"
5422 | 0xff55 | 0xff9a -> (* (kp) prior *)
5423 let y =
5424 if ctrl
5425 then
5426 match state.layout with
5427 | [] -> state.y
5428 | l :: _ -> state.y - l.pagey
5429 else
5430 clamp (pgscale (-state.winh))
5432 gotoghyll y
5434 | 0xff56 | 0xff9b -> (* (kp) next *)
5435 let y =
5436 if ctrl
5437 then
5438 match List.rev state.layout with
5439 | [] -> state.y
5440 | l :: _ -> getpagey l.pageno
5441 else
5442 clamp (pgscale state.winh)
5444 gotoghyll y
5446 | 103 | 0xff50 | 0xff95 -> (* g (kp) home *)
5447 gotoghyll 0
5448 | 71 | 0xff57 | 0xff9c -> (* G (kp) end *)
5449 gotoghyll (clamp state.maxy)
5451 | 0xff53 | 0xff98
5452 when Wsi.withalt mask -> (* alt-(kp) right *)
5453 gotoghyll (getnav 1)
5454 | 0xff51 | 0xff96
5455 when Wsi.withalt mask -> (* alt-(kp) left *)
5456 gotoghyll (getnav ~-1)
5458 | 114 -> (* r *)
5459 reload ()
5461 | 118 when conf.debug -> (* v *)
5462 state.rects <- [];
5463 List.iter (fun l ->
5464 match getopaque l.pageno with
5465 | None -> ()
5466 | Some opaque ->
5467 let x0, y0, x1, y1 = pagebbox opaque in
5468 let a,b = float x0, float y0 in
5469 let c,d = float x1, float y0 in
5470 let e,f = float x1, float y1 in
5471 let h,j = float x0, float y1 in
5472 let rect = (a,b,c,d,e,f,h,j) in
5473 debugrect rect;
5474 state.rects <- (l.pageno, l.pageno mod 3, rect) :: state.rects;
5475 ) state.layout;
5476 G.postRedisplay "v";
5478 | _ ->
5479 vlog "huh? %s" (Wsi.keyname key)
5482 let linknavkeyboard key mask linknav =
5483 let getpage pageno =
5484 let rec loop = function
5485 | [] -> None
5486 | l :: _ when l.pageno = pageno -> Some l
5487 | _ :: rest -> loop rest
5488 in loop state.layout
5490 let doexact (pageno, n) =
5491 match getopaque pageno, getpage pageno with
5492 | Some opaque, Some l ->
5493 if key = 0xff0d || key = 0xff8d (* (kp)enter *)
5494 then
5495 let under = getlink opaque n in
5496 G.postRedisplay "link gotounder";
5497 gotounder under;
5498 state.mode <- View;
5499 else
5500 let opt, dir =
5501 match key with
5502 | 0xff50 -> (* home *)
5503 Some (findlink opaque LDfirst), -1
5505 | 0xff57 -> (* end *)
5506 Some (findlink opaque LDlast), 1
5508 | 0xff51 -> (* left *)
5509 Some (findlink opaque (LDleft n)), -1
5511 | 0xff53 -> (* right *)
5512 Some (findlink opaque (LDright n)), 1
5514 | 0xff52 -> (* up *)
5515 Some (findlink opaque (LDup n)), -1
5517 | 0xff54 -> (* down *)
5518 Some (findlink opaque (LDdown n)), 1
5520 | _ -> None, 0
5522 let pwl l dir =
5523 begin match findpwl l.pageno dir with
5524 | Pwlnotfound -> ()
5525 | Pwl pageno ->
5526 let notfound dir =
5527 state.mode <- LinkNav (Ltgendir dir);
5528 let y, h = getpageyh pageno in
5529 let y =
5530 if dir < 0
5531 then y + h - state.winh
5532 else y
5534 gotoy y
5536 begin match getopaque pageno, getpage pageno with
5537 | Some opaque, Some _ ->
5538 let link =
5539 let ld = if dir > 0 then LDfirst else LDlast in
5540 findlink opaque ld
5542 begin match link with
5543 | Lfound m ->
5544 showlinktype (getlink opaque m);
5545 state.mode <- LinkNav (Ltexact (pageno, m));
5546 G.postRedisplay "linknav jpage";
5547 | _ -> notfound dir
5548 end;
5549 | _ -> notfound dir
5550 end;
5551 end;
5553 begin match opt with
5554 | Some Lnotfound -> pwl l dir;
5555 | Some (Lfound m) ->
5556 if m = n
5557 then pwl l dir
5558 else (
5559 let _, y0, _, y1 = getlinkrect opaque m in
5560 if y0 < l.pagey
5561 then gotopage1 l.pageno y0
5562 else (
5563 let d = fstate.fontsize + 1 in
5564 if y1 - l.pagey > l.pagevh - d
5565 then gotopage1 l.pageno (y1 - state.winh - state.hscrollh + d)
5566 else G.postRedisplay "linknav";
5568 showlinktype (getlink opaque m);
5569 state.mode <- LinkNav (Ltexact (l.pageno, m));
5572 | None -> viewkeyboard key mask
5573 end;
5574 | _ -> viewkeyboard key mask
5576 if key = 0xff63
5577 then (
5578 state.mode <- View;
5579 G.postRedisplay "leave linknav"
5581 else
5582 match linknav with
5583 | Ltgendir _ -> viewkeyboard key mask
5584 | Ltexact exact -> doexact exact
5587 let keyboard key mask =
5588 if (key = 103 && Wsi.withctrl mask) && not (istextentry state.mode)
5589 then wcmd "interrupt"
5590 else state.uioh <- state.uioh#key key mask
5593 let birdseyekeyboard key mask
5594 ((oconf, leftx, pageno, hooverpageno, anchor) as beye) =
5595 let incr =
5596 match conf.columns with
5597 | Csingle _ -> 1
5598 | Cmulti ((c, _, _), _) -> c
5599 | Csplit _ -> failwith "bird's eye split mode"
5601 let pgh layout = List.fold_left (fun m l -> max l.pageh m) state.winh layout in
5602 match key with
5603 | 108 when Wsi.withctrl mask -> (* ctrl-l *)
5604 let y, h = getpageyh pageno in
5605 let top = (state.winh - h) / 2 in
5606 gotoy (max 0 (y - top))
5607 | 0xff0d (* enter *)
5608 | 0xff8d -> leavebirdseye beye false (* kp enter *)
5609 | 0xff1b -> leavebirdseye beye true (* escape *)
5610 | 0xff52 -> upbirdseye incr beye (* up *)
5611 | 0xff54 -> downbirdseye incr beye (* down *)
5612 | 0xff51 -> upbirdseye 1 beye (* left *)
5613 | 0xff53 -> downbirdseye 1 beye (* right *)
5615 | 0xff55 -> (* prior *)
5616 begin match state.layout with
5617 | l :: _ ->
5618 if l.pagey != 0
5619 then (
5620 state.mode <- Birdseye (
5621 oconf, leftx, l.pageno, hooverpageno, anchor
5623 gotopage1 l.pageno 0;
5625 else (
5626 let layout = layout (state.y-state.winh) (pgh state.layout) in
5627 match layout with
5628 | [] -> gotoy (clamp (-state.winh))
5629 | l :: _ ->
5630 state.mode <- Birdseye (
5631 oconf, leftx, l.pageno, hooverpageno, anchor
5633 gotopage1 l.pageno 0
5636 | [] -> gotoy (clamp (-state.winh))
5637 end;
5639 | 0xff56 -> (* next *)
5640 begin match List.rev state.layout with
5641 | l :: _ ->
5642 let layout = layout (state.y + (pgh state.layout)) state.winh in
5643 begin match layout with
5644 | [] ->
5645 let incr = l.pageh - l.pagevh in
5646 if incr = 0
5647 then (
5648 state.mode <-
5649 Birdseye (
5650 oconf, leftx, state.pagecount - 1, hooverpageno, anchor
5652 G.postRedisplay "birdseye pagedown";
5654 else gotoy (clamp (incr + conf.interpagespace*2));
5656 | l :: _ ->
5657 state.mode <-
5658 Birdseye (oconf, leftx, l.pageno, hooverpageno, anchor);
5659 gotopage1 l.pageno 0;
5662 | [] -> gotoy (clamp state.winh)
5663 end;
5665 | 0xff50 -> (* home *)
5666 state.mode <- Birdseye (oconf, leftx, 0, hooverpageno, anchor);
5667 gotopage1 0 0
5669 | 0xff57 -> (* end *)
5670 let pageno = state.pagecount - 1 in
5671 state.mode <- Birdseye (oconf, leftx, pageno, hooverpageno, anchor);
5672 if not (pagevisible state.layout pageno)
5673 then
5674 let h =
5675 match List.rev state.pdims with
5676 | [] -> state.winh
5677 | (_, _, h, _) :: _ -> h
5679 gotoy (max 0 (getpagey pageno - (state.winh - h - conf.interpagespace)))
5680 else G.postRedisplay "birdseye end";
5681 | _ -> viewkeyboard key mask
5684 let drawpage l linkindexbase =
5685 let color =
5686 match state.mode with
5687 | Textentry _ -> scalecolor 0.4
5688 | LinkNav _
5689 | View -> scalecolor 1.0
5690 | Birdseye (_, _, pageno, hooverpageno, _) ->
5691 if l.pageno = hooverpageno
5692 then scalecolor 0.9
5693 else (
5694 if l.pageno = pageno
5695 then scalecolor 1.0
5696 else scalecolor 0.8
5699 drawtiles l color;
5700 begin match getopaque l.pageno with
5701 | Some opaque ->
5702 if tileready l l.pagex l.pagey
5703 then
5704 let x = l.pagedispx - l.pagex
5705 and y = l.pagedispy - l.pagey in
5706 let hlmask =
5707 match conf.columns with
5708 | Csingle _ | Cmulti _ ->
5709 (if conf.hlinks then 1 else 0)
5710 + (if state.glinks
5711 && not (isbirdseye state.mode) then 2 else 0)
5712 | _ -> 0
5714 let s =
5715 match state.mode with
5716 | Textentry ((_, s, _, _, _, _), _) when state.glinks -> s
5717 | _ -> ""
5719 postprocess opaque hlmask x y (linkindexbase, s, conf.hfsize);
5720 else 0
5722 | _ -> 0
5723 end;
5726 let scrollindicator () =
5727 let sbw, ph, sh = state.uioh#scrollph in
5728 let sbh, pw, sw = state.uioh#scrollpw in
5730 GlDraw.color (0.64, 0.64, 0.64);
5731 GlDraw.rect
5732 (float (state.winw - sbw), 0.)
5733 (float state.winw, float state.winh)
5735 GlDraw.rect
5736 (0., float (state.winh - sbh))
5737 (float (state.winw - state.scrollw - 1), float state.winh)
5739 GlDraw.color (0.0, 0.0, 0.0);
5741 GlDraw.rect
5742 (float (state.winw - sbw), ph)
5743 (float state.winw, ph +. sh)
5745 GlDraw.rect
5746 (pw, float (state.winh - sbh))
5747 (pw +. sw, float state.winh)
5751 let showsel () =
5752 match state.mstate with
5753 | Mnone | Mscrolly | Mscrollx | Mpan _ | Mzoom _ | Mzoomrect _ ->
5756 | Msel ((x0, y0), (x1, y1)) ->
5757 let rec loop = function
5758 | l :: ls ->
5759 if ((y0 >= l.pagedispy && y0 <= (l.pagedispy + l.pagevh))
5760 || ((y1 >= l.pagedispy && y1 <= (l.pagedispy + l.pagevh))))
5761 && ((x0 >= l.pagedispx && x0 <= (l.pagedispx + l.pagevw))
5762 || ((x1 >= l.pagedispx && x1 <= (l.pagedispx + l.pagevw))))
5763 then
5764 match getopaque l.pageno with
5765 | Some opaque ->
5766 let x0, y0 = pagetranslatepoint l x0 y0 in
5767 let x1, y1 = pagetranslatepoint l x1 y1 in
5768 seltext opaque (x0, y0, x1, y1);
5769 | _ -> ()
5770 else loop ls
5771 | [] -> ()
5773 loop state.layout
5776 let showrects rects =
5777 Gl.enable `blend;
5778 GlDraw.color (0.0, 0.0, 1.0) ~alpha:0.5;
5779 GlDraw.polygon_mode `both `fill;
5780 GlFunc.blend_func `src_alpha `one_minus_src_alpha;
5781 List.iter
5782 (fun (pageno, c, (x0, y0, x1, y1, x2, y2, x3, y3)) ->
5783 List.iter (fun l ->
5784 if l.pageno = pageno
5785 then (
5786 let dx = float (l.pagedispx - l.pagex) in
5787 let dy = float (l.pagedispy - l.pagey) in
5788 GlDraw.color (0.0, 0.0, 1.0 /. float c) ~alpha:0.5;
5789 GlDraw.begins `quads;
5791 GlDraw.vertex2 (x0+.dx, y0+.dy);
5792 GlDraw.vertex2 (x1+.dx, y1+.dy);
5793 GlDraw.vertex2 (x2+.dx, y2+.dy);
5794 GlDraw.vertex2 (x3+.dx, y3+.dy);
5796 GlDraw.ends ();
5798 ) state.layout
5799 ) rects
5801 Gl.disable `blend;
5804 let display () =
5805 GlClear.color (scalecolor2 conf.bgcolor);
5806 GlClear.clear [`color];
5807 let rec loop linkindexbase = function
5808 | l :: rest ->
5809 let linkindexbase = linkindexbase + drawpage l linkindexbase in
5810 loop linkindexbase rest
5811 | [] -> ()
5813 loop 0 state.layout;
5814 let rects =
5815 match state.mode with
5816 | LinkNav (Ltexact (pageno, linkno)) ->
5817 begin match getopaque pageno with
5818 | Some opaque ->
5819 let x0, y0, x1, y1 = getlinkrect opaque linkno in
5820 (pageno, 5, (
5821 float x0, float y0,
5822 float x1, float y0,
5823 float x1, float y1,
5824 float x0, float y1)
5825 ) :: state.rects
5826 | None -> state.rects
5828 | _ -> state.rects
5830 showrects rects;
5831 showsel ();
5832 state.uioh#display;
5833 begin match state.mstate with
5834 | Mzoomrect ((x0, y0), (x1, y1)) ->
5835 Gl.enable `blend;
5836 GlDraw.color (0.3, 0.3, 0.3) ~alpha:0.5;
5837 GlFunc.blend_func `src_alpha `one_minus_src_alpha;
5838 GlDraw.rect (float x0, float y0)
5839 (float x1, float y1);
5840 Gl.disable `blend;
5841 | _ -> ()
5842 end;
5843 enttext ();
5844 scrollindicator ();
5845 Wsi.swapb ();
5848 let zoomrect x y x1 y1 =
5849 let x0 = min x x1
5850 and x1 = max x x1
5851 and y0 = min y y1 in
5852 gotoy (state.y + y0);
5853 state.anchor <- getanchor ();
5854 let zoom = (float state.winw *. conf.zoom) /. float (x1 - x0) in
5855 let margin =
5856 if state.w < state.winw - state.scrollw
5857 then (state.winw - state.scrollw - state.w) / 2
5858 else 0
5860 state.x <- (state.x + margin) - x0;
5861 setzoom zoom;
5862 Wsi.setcursor Wsi.CURSOR_INHERIT;
5863 state.mstate <- Mnone;
5866 let scrollx x =
5867 let winw = state.winw - state.scrollw - 1 in
5868 let s = float x /. float winw in
5869 let destx = truncate (float (state.w + winw) *. s) in
5870 state.x <- winw - destx;
5871 gotoy_and_clear_text state.y;
5872 state.mstate <- Mscrollx;
5875 let scrolly y =
5876 let s = float y /. float state.winh in
5877 let desty = truncate (float (state.maxy - state.winh) *. s) in
5878 gotoy_and_clear_text desty;
5879 state.mstate <- Mscrolly;
5882 let viewmouse button down x y mask =
5883 match button with
5884 | n when (n == 4 || n == 5) && not down ->
5885 if Wsi.withctrl mask
5886 then (
5887 match state.mstate with
5888 | Mzoom (oldn, i) ->
5889 if oldn = n
5890 then (
5891 if i = 2
5892 then
5893 let incr =
5894 match n with
5895 | 5 ->
5896 if conf.zoom +. 0.01 > 0.1 then 0.1 else 0.01
5897 | _ ->
5898 if conf.zoom -. 0.1 < 0.1 then -0.01 else -0.1
5900 let zoom = conf.zoom -. incr in
5901 setzoom zoom;
5902 state.mstate <- Mzoom (n, 0);
5903 else
5904 state.mstate <- Mzoom (n, i+1);
5906 else state.mstate <- Mzoom (n, 0)
5908 | _ -> state.mstate <- Mzoom (n, 0)
5910 else (
5911 match state.autoscroll with
5912 | Some step -> setautoscrollspeed step (n=4)
5913 | None ->
5914 if conf.wheelbypage || conf.presentation
5915 then (
5916 if n = 4
5917 then prevpage ()
5918 else nextpage ()
5920 else
5921 let incr =
5922 if n = 4
5923 then -conf.scrollstep
5924 else conf.scrollstep
5926 let incr = incr * 2 in
5927 let y = clamp incr in
5928 gotoy_and_clear_text y
5931 | n when (n = 6 || n = 7) && not down && canpan () ->
5932 state.x <- state.x + (if n = 7 then -2 else 2) * conf.hscrollstep;
5933 gotoy_and_clear_text state.y
5935 | 1 when Wsi.withshift mask ->
5936 state.mstate <- Mnone;
5937 if not down
5938 then (
5939 match unproject x y with
5940 | Some (pageno, ux, uy) ->
5941 let cmd = Printf.sprintf
5942 "%s %s %d %d %d"
5943 conf.stcmd state.path pageno ux uy
5945 popen cmd []
5946 | None -> ()
5949 | 1 when Wsi.withctrl mask ->
5950 if down
5951 then (
5952 Wsi.setcursor Wsi.CURSOR_CROSSHAIR;
5953 state.mstate <- Mpan (x, y)
5955 else
5956 state.mstate <- Mnone
5958 | 3 ->
5959 if down
5960 then (
5961 Wsi.setcursor Wsi.CURSOR_CYCLE;
5962 let p = (x, y) in
5963 state.mstate <- Mzoomrect (p, p)
5965 else (
5966 match state.mstate with
5967 | Mzoomrect ((x0, y0), _) ->
5968 if abs (x-x0) > 10 && abs (y - y0) > 10
5969 then zoomrect x0 y0 x y
5970 else (
5971 state.mstate <- Mnone;
5972 Wsi.setcursor Wsi.CURSOR_INHERIT;
5973 G.postRedisplay "kill accidental zoom rect";
5975 | _ ->
5976 Wsi.setcursor Wsi.CURSOR_INHERIT;
5977 state.mstate <- Mnone
5980 | 1 when x > state.winw - state.scrollw ->
5981 if down
5982 then
5983 let _, position, sh = state.uioh#scrollph in
5984 if y > truncate position && y < truncate (position +. sh)
5985 then state.mstate <- Mscrolly
5986 else scrolly y
5987 else
5988 state.mstate <- Mnone
5990 | 1 when y > state.winh - state.hscrollh ->
5991 if down
5992 then
5993 let _, position, sw = state.uioh#scrollpw in
5994 if x > truncate position && x < truncate (position +. sw)
5995 then state.mstate <- Mscrollx
5996 else scrollx x
5997 else
5998 state.mstate <- Mnone
6000 | 1 ->
6001 let dest = if down then getunder x y else Unone in
6002 begin match dest with
6003 | Ulinkgoto _
6004 | Ulinkuri _
6005 | Uremote _
6006 | Uunexpected _ | Ulaunch _ | Unamed _ ->
6007 gotounder dest
6009 | Unone when down ->
6010 Wsi.setcursor Wsi.CURSOR_CROSSHAIR;
6011 state.mstate <- Mpan (x, y);
6013 | Unone | Utext _ ->
6014 if down
6015 then (
6016 if conf.angle mod 360 = 0
6017 then (
6018 state.mstate <- Msel ((x, y), (x, y));
6019 G.postRedisplay "mouse select";
6022 else (
6023 match state.mstate with
6024 | Mnone -> ()
6026 | Mzoom _ | Mscrollx | Mscrolly ->
6027 state.mstate <- Mnone
6029 | Mzoomrect ((x0, y0), _) ->
6030 zoomrect x0 y0 x y
6032 | Mpan _ ->
6033 Wsi.setcursor Wsi.CURSOR_INHERIT;
6034 state.mstate <- Mnone
6036 | Msel ((x0, y0), (x1, y1)) ->
6037 let rec loop = function
6038 | [] -> ()
6039 | l :: rest ->
6040 let inside =
6041 let a0 = l.pagedispy in
6042 let a1 = a0 + l.pagevh in
6043 let b0 = l.pagedispx in
6044 let b1 = b0 + l.pagevw in
6045 ((y0 >= a0 && y0 <= a1) || (y1 >= a0 && y1 <= a1))
6046 && ((x0 >= b0 && x0 <= b1) || (x1 >= b0 && x1 <= b1))
6048 if inside
6049 then
6050 match getopaque l.pageno with
6051 | Some opaque ->
6052 begin
6053 match Ne.pipe () with
6054 | Ne.Exn exn ->
6055 showtext '!'
6056 (Printf.sprintf
6057 "can not create sel pipe: %s"
6058 (exntos exn));
6059 | Ne.Res (r, w) ->
6060 let doclose what fd =
6061 Ne.clo fd (fun msg ->
6062 dolog "%s close failed: %s" what msg)
6065 popen conf.selcmd [r, 0; w, -1];
6066 copysel w opaque;
6067 doclose "pipe/r" r;
6068 G.postRedisplay "copysel";
6069 with exn ->
6070 dolog "can not execute %S: %s"
6071 conf.selcmd (exntos exn);
6072 doclose "pipe/r" r;
6073 doclose "pipe/w" w;
6075 | None -> ()
6076 else loop rest
6078 loop state.layout;
6079 Wsi.setcursor Wsi.CURSOR_INHERIT;
6080 state.mstate <- Mnone;
6084 | _ -> ()
6087 let birdseyemouse button down x y mask
6088 (conf, leftx, _, hooverpageno, anchor) =
6089 match button with
6090 | 1 when down ->
6091 let rec loop = function
6092 | [] -> ()
6093 | l :: rest ->
6094 if y > l.pagedispy && y < l.pagedispy + l.pagevh
6095 && x > l.pagedispx && x < l.pagedispx + l.pagevw
6096 then (
6097 leavebirdseye (conf, leftx, l.pageno, hooverpageno, anchor) false;
6099 else loop rest
6101 loop state.layout
6102 | 3 -> ()
6103 | _ -> viewmouse button down x y mask
6106 let mouse button down x y mask =
6107 state.uioh <- state.uioh#button button down x y mask;
6110 let motion ~x ~y =
6111 state.uioh <- state.uioh#motion x y
6114 let pmotion ~x ~y =
6115 state.uioh <- state.uioh#pmotion x y;
6118 let uioh = object
6119 method display = ()
6121 method key key mask =
6122 begin match state.mode with
6123 | Textentry textentry -> textentrykeyboard key mask textentry
6124 | Birdseye birdseye -> birdseyekeyboard key mask birdseye
6125 | View -> viewkeyboard key mask
6126 | LinkNav linknav -> linknavkeyboard key mask linknav
6127 end;
6128 state.uioh
6130 method button button bstate x y mask =
6131 begin match state.mode with
6132 | LinkNav _
6133 | View -> viewmouse button bstate x y mask
6134 | Birdseye beye -> birdseyemouse button bstate x y mask beye
6135 | Textentry _ -> ()
6136 end;
6137 state.uioh
6139 method motion x y =
6140 begin match state.mode with
6141 | Textentry _ -> ()
6142 | View | Birdseye _ | LinkNav _ ->
6143 match state.mstate with
6144 | Mzoom _ | Mnone -> ()
6146 | Mpan (x0, y0) ->
6147 let dx = x - x0
6148 and dy = y0 - y in
6149 state.mstate <- Mpan (x, y);
6150 if canpan ()
6151 then state.x <- state.x + dx;
6152 let y = clamp dy in
6153 gotoy_and_clear_text y
6155 | Msel (a, _) ->
6156 state.mstate <- Msel (a, (x, y));
6157 G.postRedisplay "motion select";
6159 | Mscrolly ->
6160 let y = min state.winh (max 0 y) in
6161 scrolly y
6163 | Mscrollx ->
6164 let x = min state.winw (max 0 x) in
6165 scrollx x
6167 | Mzoomrect (p0, _) ->
6168 state.mstate <- Mzoomrect (p0, (x, y));
6169 G.postRedisplay "motion zoomrect";
6170 end;
6171 state.uioh
6173 method pmotion x y =
6174 begin match state.mode with
6175 | Birdseye (conf, leftx, pageno, hooverpageno, anchor) ->
6176 let rec loop = function
6177 | [] ->
6178 if hooverpageno != -1
6179 then (
6180 state.mode <- Birdseye (conf, leftx, pageno, -1, anchor);
6181 G.postRedisplay "pmotion birdseye no hoover";
6183 | l :: rest ->
6184 if y > l.pagedispy && y < l.pagedispy + l.pagevh
6185 && x > l.pagedispx && x < l.pagedispx + l.pagevw
6186 then (
6187 state.mode <- Birdseye (conf, leftx, pageno, l.pageno, anchor);
6188 G.postRedisplay "pmotion birdseye hoover";
6190 else loop rest
6192 loop state.layout
6194 | Textentry _ -> ()
6196 | LinkNav _
6197 | View ->
6198 match state.mstate with
6199 | Mnone -> updateunder x y
6200 | Mpan _ | Msel _ | Mzoom _ | Mscrolly | Mscrollx | Mzoomrect _ ->
6202 end;
6203 state.uioh
6205 method infochanged _ = ()
6207 method scrollph =
6208 let maxy = state.maxy - (if conf.maxhfit then state.winh else 0) in
6209 let p, h =
6210 if maxy = 0
6211 then 0.0, float state.winh
6212 else scrollph state.y maxy
6214 state.scrollw, p, h
6216 method scrollpw =
6217 let winw = state.winw - state.scrollw - 1 in
6218 let fwinw = float winw in
6219 let sw =
6220 let sw = fwinw /. float state.w in
6221 let sw = fwinw *. sw in
6222 max sw (float conf.scrollh)
6224 let position, sw =
6225 let f = state.w+winw in
6226 let r = float (winw-state.x) /. float f in
6227 let p = fwinw *. r in
6228 p-.sw/.2., sw
6230 let sw =
6231 if position +. sw > fwinw
6232 then fwinw -. position
6233 else sw
6235 state.hscrollh, position, sw
6237 method modehash =
6238 let modename =
6239 match state.mode with
6240 | LinkNav _ -> "links"
6241 | Textentry _ -> "textentry"
6242 | Birdseye _ -> "birdseye"
6243 | View -> "view"
6245 findkeyhash conf modename
6247 method eformsgs = true
6248 end;;
6250 module Config =
6251 struct
6252 open Parser
6254 let fontpath = ref "";;
6256 module KeyMap =
6257 Map.Make (struct type t = (int * int) let compare = compare end);;
6259 let unent s =
6260 let l = String.length s in
6261 let b = Buffer.create l in
6262 unent b s 0 l;
6263 Buffer.contents b;
6266 let home =
6267 try Sys.getenv "HOME"
6268 with exn ->
6269 prerr_endline
6270 ("Can not determine home directory location: " ^ exntos exn);
6274 let modifier_of_string = function
6275 | "alt" -> Wsi.altmask
6276 | "shift" -> Wsi.shiftmask
6277 | "ctrl" | "control" -> Wsi.ctrlmask
6278 | "meta" -> Wsi.metamask
6279 | _ -> 0
6282 let key_of_string =
6283 let r = Str.regexp "-" in
6284 fun s ->
6285 let elems = Str.full_split r s in
6286 let f n k m =
6287 let g s =
6288 let m1 = modifier_of_string s in
6289 if m1 = 0
6290 then (Wsi.namekey s, m)
6291 else (k, m lor m1)
6292 in function
6293 | Str.Delim s when n land 1 = 0 -> g s
6294 | Str.Text s -> g s
6295 | Str.Delim _ -> (k, m)
6297 let rec loop n k m = function
6298 | [] -> (k, m)
6299 | x :: xs ->
6300 let k, m = f n k m x in
6301 loop (n+1) k m xs
6303 loop 0 0 0 elems
6306 let keys_of_string =
6307 let r = Str.regexp "[ \t]" in
6308 fun s ->
6309 let elems = Str.split r s in
6310 List.map key_of_string elems
6313 let copykeyhashes c =
6314 List.map (fun (k, v) -> k, Hashtbl.copy v) c.keyhashes;
6317 let config_of c attrs =
6318 let apply c k v =
6320 match k with
6321 | "scroll-bar-width" -> { c with scrollbw = max 0 (int_of_string v) }
6322 | "scroll-handle-height" -> { c with scrollh = max 0 (int_of_string v) }
6323 | "case-insensitive-search" -> { c with icase = bool_of_string v }
6324 | "preload" -> { c with preload = bool_of_string v }
6325 | "page-bias" -> { c with pagebias = int_of_string v }
6326 | "scroll-step" -> { c with scrollstep = max 1 (int_of_string v) }
6327 | "horizontal-scroll-step" ->
6328 { c with hscrollstep = max (int_of_string v) 1 }
6329 | "auto-scroll-step" ->
6330 { c with autoscrollstep = max 0 (int_of_string v) }
6331 | "max-height-fit" -> { c with maxhfit = bool_of_string v }
6332 | "crop-hack" -> { c with crophack = bool_of_string v }
6333 | "throttle" ->
6334 let mw =
6335 match String.lowercase v with
6336 | "true" -> Some infinity
6337 | "false" -> None
6338 | f -> Some (float_of_string f)
6340 { c with maxwait = mw}
6341 | "highlight-links" -> { c with hlinks = bool_of_string v }
6342 | "under-cursor-info" -> { c with underinfo = bool_of_string v }
6343 | "vertical-margin" ->
6344 { c with interpagespace = max 0 (int_of_string v) }
6345 | "zoom" ->
6346 let zoom = float_of_string v /. 100. in
6347 let zoom = max zoom 0.0 in
6348 { c with zoom = zoom }
6349 | "presentation" -> { c with presentation = bool_of_string v }
6350 | "rotation-angle" -> { c with angle = int_of_string v }
6351 | "width" -> { c with cwinw = max 20 (int_of_string v) }
6352 | "height" -> { c with cwinh = max 20 (int_of_string v) }
6353 | "persistent-bookmarks" -> { c with savebmarks = bool_of_string v }
6354 | "proportional-display" ->
6355 let fm =
6356 if bool_of_string v
6357 then FitProportional
6358 else FitWidth
6360 { c with fitmodel = fm }
6361 | "fit-model" -> { c with fitmodel = fitmodel_of_string v }
6362 | "pixmap-cache-size" ->
6363 { c with memlimit = max 2 (int_of_string_with_suffix v) }
6364 | "tex-count" -> { c with texcount = max 1 (int_of_string v) }
6365 | "slice-height" -> { c with sliceheight = max 2 (int_of_string v) }
6366 | "thumbnail-width" -> { c with thumbw = max 2 (int_of_string v) }
6367 | "persistent-location" -> { c with jumpback = bool_of_string v }
6368 | "background-color" -> { c with bgcolor = color_of_string v }
6369 | "scrollbar-in-presentation" ->
6370 { c with scrollbarinpm = bool_of_string v }
6371 | "tile-width" -> { c with tilew = max 2 (int_of_string v) }
6372 | "tile-height" -> { c with tileh = max 2 (int_of_string v) }
6373 | "mupdf-store-size" ->
6374 { c with mustoresize = max 1024 (int_of_string_with_suffix v) }
6375 | "checkers" -> { c with checkers = bool_of_string v }
6376 | "aalevel" -> { c with aalevel = max 0 (int_of_string v) }
6377 | "trim-margins" -> { c with trimmargins = bool_of_string v }
6378 | "trim-fuzz" -> { c with trimfuzz = irect_of_string v }
6379 | "uri-launcher" -> { c with urilauncher = unent v }
6380 | "path-launcher" -> { c with pathlauncher = unent v }
6381 | "color-space" -> { c with colorspace = colorspace_of_string v }
6382 | "invert-colors" -> { c with invert = bool_of_string v }
6383 | "brightness" -> { c with colorscale = float_of_string v }
6384 | "redirectstderr" -> { c with redirectstderr = bool_of_string v }
6385 | "ghyllscroll" ->
6386 { c with ghyllscroll = Some (ghyllscroll_of_string v) }
6387 | "columns" ->
6388 let (n, _, _) as nab = multicolumns_of_string v in
6389 if n < 0
6390 then { c with columns = Csplit (-n, [||]) }
6391 else { c with columns = Cmulti (nab, [||]) }
6392 | "birds-eye-columns" ->
6393 { c with beyecolumns = Some (max (int_of_string v) 2) }
6394 | "selection-command" -> { c with selcmd = unent v }
6395 | "synctex-command" -> { c with stcmd = unent v }
6396 | "update-cursor" -> { c with updatecurs = bool_of_string v }
6397 | "hint-font-size" -> { c with hfsize = bound (int_of_string v) 5 100 }
6398 | "page-scroll-scale" -> { c with pgscale = float_of_string v }
6399 | "use-pbo" -> { c with usepbo = bool_of_string v }
6400 | "wheel-scrolls-pages" -> { c with wheelbypage = bool_of_string v }
6401 | _ -> c
6402 with exn ->
6403 prerr_endline ("Error processing attribute (`" ^
6404 k ^ "'=`" ^ v ^ "'): " ^ exntos exn);
6407 let rec fold c = function
6408 | [] -> c
6409 | (k, v) :: rest ->
6410 let c = apply c k v in
6411 fold c rest
6413 fold { c with keyhashes = copykeyhashes c } attrs;
6416 let fromstring f pos n v d =
6417 try f v
6418 with exn ->
6419 dolog "Error processing attribute (%S=%S) at %d\n%s"
6420 n v pos (exntos exn)
6425 let bookmark_of attrs =
6426 let rec fold title page rely visy = function
6427 | ("title", v) :: rest -> fold v page rely visy rest
6428 | ("page", v) :: rest -> fold title v rely visy rest
6429 | ("rely", v) :: rest -> fold title page v visy rest
6430 | ("visy", v) :: rest -> fold title page rely v rest
6431 | _ :: rest -> fold title page rely visy rest
6432 | [] -> title, page, rely, visy
6434 fold "invalid" "0" "0" "0" attrs
6437 let doc_of attrs =
6438 let rec fold path page rely pan visy = function
6439 | ("path", v) :: rest -> fold v page rely pan visy rest
6440 | ("page", v) :: rest -> fold path v rely pan visy rest
6441 | ("rely", v) :: rest -> fold path page v pan visy rest
6442 | ("pan", v) :: rest -> fold path page rely v visy rest
6443 | ("visy", v) :: rest -> fold path page rely pan v rest
6444 | _ :: rest -> fold path page rely pan visy rest
6445 | [] -> path, page, rely, pan, visy
6447 fold "" "0" "0" "0" "0" attrs
6450 let map_of attrs =
6451 let rec fold rs ls = function
6452 | ("out", v) :: rest -> fold v ls rest
6453 | ("in", v) :: rest -> fold rs v rest
6454 | _ :: rest -> fold ls rs rest
6455 | [] -> ls, rs
6457 fold "" "" attrs
6460 let setconf dst src =
6461 dst.scrollbw <- src.scrollbw;
6462 dst.scrollh <- src.scrollh;
6463 dst.icase <- src.icase;
6464 dst.preload <- src.preload;
6465 dst.pagebias <- src.pagebias;
6466 dst.verbose <- src.verbose;
6467 dst.scrollstep <- src.scrollstep;
6468 dst.maxhfit <- src.maxhfit;
6469 dst.crophack <- src.crophack;
6470 dst.autoscrollstep <- src.autoscrollstep;
6471 dst.maxwait <- src.maxwait;
6472 dst.hlinks <- src.hlinks;
6473 dst.underinfo <- src.underinfo;
6474 dst.interpagespace <- src.interpagespace;
6475 dst.zoom <- src.zoom;
6476 dst.presentation <- src.presentation;
6477 dst.angle <- src.angle;
6478 dst.cwinw <- src.cwinw;
6479 dst.cwinh <- src.cwinh;
6480 dst.savebmarks <- src.savebmarks;
6481 dst.memlimit <- src.memlimit;
6482 dst.fitmodel <- src.fitmodel;
6483 dst.texcount <- src.texcount;
6484 dst.sliceheight <- src.sliceheight;
6485 dst.thumbw <- src.thumbw;
6486 dst.jumpback <- src.jumpback;
6487 dst.bgcolor <- src.bgcolor;
6488 dst.scrollbarinpm <- src.scrollbarinpm;
6489 dst.tilew <- src.tilew;
6490 dst.tileh <- src.tileh;
6491 dst.mustoresize <- src.mustoresize;
6492 dst.checkers <- src.checkers;
6493 dst.aalevel <- src.aalevel;
6494 dst.trimmargins <- src.trimmargins;
6495 dst.trimfuzz <- src.trimfuzz;
6496 dst.urilauncher <- src.urilauncher;
6497 dst.colorspace <- src.colorspace;
6498 dst.invert <- src.invert;
6499 dst.colorscale <- src.colorscale;
6500 dst.redirectstderr <- src.redirectstderr;
6501 dst.ghyllscroll <- src.ghyllscroll;
6502 dst.columns <- src.columns;
6503 dst.beyecolumns <- src.beyecolumns;
6504 dst.selcmd <- src.selcmd;
6505 dst.updatecurs <- src.updatecurs;
6506 dst.pathlauncher <- src.pathlauncher;
6507 dst.keyhashes <- copykeyhashes src;
6508 dst.hfsize <- src.hfsize;
6509 dst.hscrollstep <- src.hscrollstep;
6510 dst.pgscale <- src.pgscale;
6511 dst.usepbo <- src.usepbo;
6512 dst.wheelbypage <- src.wheelbypage;
6513 dst.stcmd <- src.stcmd;
6516 let get s =
6517 let h = Hashtbl.create 10 in
6518 let dc = { defconf with angle = defconf.angle } in
6519 let rec toplevel v t spos _ =
6520 match t with
6521 | Vdata | Vcdata | Vend -> v
6522 | Vopen ("llppconfig", _, closed) ->
6523 if closed
6524 then v
6525 else { v with f = llppconfig }
6526 | Vopen _ ->
6527 error "unexpected subelement at top level" s spos
6528 | Vclose _ -> error "unexpected close at top level" s spos
6530 and llppconfig v t spos _ =
6531 match t with
6532 | Vdata | Vcdata -> v
6533 | Vend -> error "unexpected end of input in llppconfig" s spos
6534 | Vopen ("defaults", attrs, closed) ->
6535 let c = config_of dc attrs in
6536 setconf dc c;
6537 if closed
6538 then v
6539 else { v with f = defaults }
6541 | Vopen ("ui-font", attrs, closed) ->
6542 let rec getsize size = function
6543 | [] -> size
6544 | ("size", v) :: rest ->
6545 let size =
6546 fromstring int_of_string spos "size" v fstate.fontsize in
6547 getsize size rest
6548 | l -> getsize size l
6550 fstate.fontsize <- getsize fstate.fontsize attrs;
6551 if closed
6552 then v
6553 else { v with f = uifont (Buffer.create 10) }
6555 | Vopen ("doc", attrs, closed) ->
6556 let pathent, spage, srely, span, svisy = doc_of attrs in
6557 let path = unent pathent
6558 and pageno = fromstring int_of_string spos "page" spage 0
6559 and rely = fromstring float_of_string spos "rely" srely 0.0
6560 and pan = fromstring int_of_string spos "pan" span 0
6561 and visy = fromstring float_of_string spos "visy" svisy 0.0 in
6562 let c = config_of dc attrs in
6563 let anchor = (pageno, rely, visy) in
6564 if closed
6565 then (Hashtbl.add h path (c, [], pan, anchor); v)
6566 else { v with f = doc path pan anchor c [] }
6568 | Vopen _ ->
6569 error "unexpected subelement in llppconfig" s spos
6571 | Vclose "llppconfig" -> { v with f = toplevel }
6572 | Vclose _ -> error "unexpected close in llppconfig" s spos
6574 and defaults v t spos _ =
6575 match t with
6576 | Vdata | Vcdata -> v
6577 | Vend -> error "unexpected end of input in defaults" s spos
6578 | Vopen ("keymap", attrs, closed) ->
6579 let modename =
6580 try List.assoc "mode" attrs
6581 with Not_found -> "global" in
6582 if closed
6583 then v
6584 else
6585 let ret keymap =
6586 let h = findkeyhash dc modename in
6587 KeyMap.iter (Hashtbl.replace h) keymap;
6588 defaults
6590 { v with f = pkeymap ret KeyMap.empty }
6592 | Vopen (_, _, _) ->
6593 error "unexpected subelement in defaults" s spos
6595 | Vclose "defaults" ->
6596 { v with f = llppconfig }
6598 | Vclose _ -> error "unexpected close in defaults" s spos
6600 and uifont b v t spos epos =
6601 match t with
6602 | Vdata | Vcdata ->
6603 Buffer.add_substring b s spos (epos - spos);
6605 | Vopen (_, _, _) ->
6606 error "unexpected subelement in ui-font" s spos
6607 | Vclose "ui-font" ->
6608 if String.length !fontpath = 0
6609 then fontpath := Buffer.contents b;
6610 { v with f = llppconfig }
6611 | Vclose _ -> error "unexpected close in ui-font" s spos
6612 | Vend -> error "unexpected end of input in ui-font" s spos
6614 and doc path pan anchor c bookmarks v t spos _ =
6615 match t with
6616 | Vdata | Vcdata -> v
6617 | Vend -> error "unexpected end of input in doc" s spos
6618 | Vopen ("bookmarks", _, closed) ->
6619 if closed
6620 then v
6621 else { v with f = pbookmarks path pan anchor c bookmarks }
6623 | Vopen ("keymap", attrs, closed) ->
6624 let modename =
6625 try List.assoc "mode" attrs
6626 with Not_found -> "global"
6628 if closed
6629 then v
6630 else
6631 let ret keymap =
6632 let h = findkeyhash c modename in
6633 KeyMap.iter (Hashtbl.replace h) keymap;
6634 doc path pan anchor c bookmarks
6636 { v with f = pkeymap ret KeyMap.empty }
6638 | Vopen (_, _, _) ->
6639 error "unexpected subelement in doc" s spos
6641 | Vclose "doc" ->
6642 Hashtbl.add h path (c, List.rev bookmarks, pan, anchor);
6643 { v with f = llppconfig }
6645 | Vclose _ -> error "unexpected close in doc" s spos
6647 and pkeymap ret keymap v t spos _ =
6648 match t with
6649 | Vdata | Vcdata -> v
6650 | Vend -> error "unexpected end of input in keymap" s spos
6651 | Vopen ("map", attrs, closed) ->
6652 let r, l = map_of attrs in
6653 let kss = fromstring keys_of_string spos "in" r [] in
6654 let lss = fromstring keys_of_string spos "out" l [] in
6655 let keymap =
6656 match kss with
6657 | [] -> keymap
6658 | ks :: [] -> KeyMap.add ks (KMinsrl lss) keymap
6659 | ks :: rest -> KeyMap.add ks (KMmulti (rest, lss)) keymap
6661 if closed
6662 then { v with f = pkeymap ret keymap }
6663 else
6664 let f () = v in
6665 { v with f = skip "map" f }
6667 | Vopen _ ->
6668 error "unexpected subelement in keymap" s spos
6670 | Vclose "keymap" ->
6671 { v with f = ret keymap }
6673 | Vclose _ -> error "unexpected close in keymap" s spos
6675 and pbookmarks path pan anchor c bookmarks v t spos _ =
6676 match t with
6677 | Vdata | Vcdata -> v
6678 | Vend -> error "unexpected end of input in bookmarks" s spos
6679 | Vopen ("item", attrs, closed) ->
6680 let titleent, spage, srely, svisy = bookmark_of attrs in
6681 let page = fromstring int_of_string spos "page" spage 0
6682 and rely = fromstring float_of_string spos "rely" srely 0.0
6683 and visy = fromstring float_of_string spos "visy" svisy 0.0 in
6684 let bookmarks =
6685 (unent titleent, 0, (page, rely, visy)) :: bookmarks
6687 if closed
6688 then { v with f = pbookmarks path pan anchor c bookmarks }
6689 else
6690 let f () = v in
6691 { v with f = skip "item" f }
6693 | Vopen _ ->
6694 error "unexpected subelement in bookmarks" s spos
6696 | Vclose "bookmarks" ->
6697 { v with f = doc path pan anchor c bookmarks }
6699 | Vclose _ -> error "unexpected close in bookmarks" s spos
6701 and skip tag f v t spos _ =
6702 match t with
6703 | Vdata | Vcdata -> v
6704 | Vend ->
6705 error ("unexpected end of input in skipped " ^ tag) s spos
6706 | Vopen (tag', _, closed) ->
6707 if closed
6708 then v
6709 else
6710 let f' () = { v with f = skip tag f } in
6711 { v with f = skip tag' f' }
6712 | Vclose ctag ->
6713 if tag = ctag
6714 then f ()
6715 else error ("unexpected close in skipped " ^ tag) s spos
6718 parse { f = toplevel; accu = () } s;
6719 h, dc;
6722 let do_load f ic =
6724 let len = in_channel_length ic in
6725 let s = String.create len in
6726 really_input ic s 0 len;
6727 f s;
6728 with
6729 | Parse_error (msg, s, pos) ->
6730 let subs = subs s pos in
6731 let s = Printf.sprintf "%s: at %d [..%s..]" msg pos subs in
6732 failwith ("parse error: " ^ s)
6734 | exn ->
6735 failwith ("config load error: " ^ exntos exn)
6738 let defconfpath =
6739 let dir =
6741 let dir = Filename.concat home ".config" in
6742 if Sys.is_directory dir then dir else home
6743 with _ -> home
6745 Filename.concat dir "llpp.conf"
6748 let confpath = ref defconfpath;;
6750 let load1 f =
6751 if Sys.file_exists !confpath
6752 then
6753 match
6754 (try Some (open_in_bin !confpath)
6755 with exn ->
6756 prerr_endline
6757 ("Error opening configuration file `" ^ !confpath ^ "': " ^
6758 exntos exn);
6759 None
6761 with
6762 | Some ic ->
6763 let success =
6765 f (do_load get ic)
6766 with exn ->
6767 prerr_endline
6768 ("Error loading configuration from `" ^ !confpath ^ "': " ^
6769 exntos exn);
6770 false
6772 close_in ic;
6773 success
6775 | None -> false
6776 else
6777 f (Hashtbl.create 0, defconf)
6780 let load () =
6781 let f (h, dc) =
6782 let pc, pb, px, pa =
6784 let key =
6785 if String.length state.origin = 0
6786 then state.path
6787 else state.origin
6789 Hashtbl.find h (Filename.basename key)
6790 with Not_found -> dc, [], 0, emptyanchor
6792 setconf defconf dc;
6793 setconf conf pc;
6794 state.bookmarks <- pb;
6795 state.x <- px;
6796 state.scrollw <- conf.scrollbw;
6797 if conf.jumpback
6798 then state.anchor <- pa;
6799 cbput state.hists.nav pa;
6800 true
6802 load1 f
6805 let add_attrs bb always dc c =
6806 let ob s a b =
6807 if always || a != b
6808 then Printf.bprintf bb "\n %s='%b'" s a
6809 and oi s a b =
6810 if always || a != b
6811 then Printf.bprintf bb "\n %s='%d'" s a
6812 and oI s a b =
6813 if always || a != b
6814 then Printf.bprintf bb "\n %s='%s'" s (string_with_suffix_of_int a)
6815 and oz s a b =
6816 if always || a <> b
6817 then Printf.bprintf bb "\n %s='%g'" s (a*.100.)
6818 and oF s a b =
6819 if always || a <> b
6820 then Printf.bprintf bb "\n %s='%f'" s a
6821 and oc s a b =
6822 if always || a <> b
6823 then
6824 Printf.bprintf bb "\n %s='%s'" s (color_to_string a)
6825 and oC s a b =
6826 if always || a <> b
6827 then
6828 Printf.bprintf bb "\n %s='%s'" s (colorspace_to_string a)
6829 and oR s a b =
6830 if always || a <> b
6831 then
6832 Printf.bprintf bb "\n %s='%s'" s (irect_to_string a)
6833 and os s a b =
6834 if always || a <> b
6835 then
6836 Printf.bprintf bb "\n %s='%s'" s (enent a 0 (String.length a))
6837 and og s a b =
6838 if always || a <> b
6839 then
6840 match a with
6841 | None -> ()
6842 | Some (_N, _A, _B) ->
6843 Printf.bprintf bb "\n %s='%u,%u,%u'" s _N _A _B
6844 and oW s a b =
6845 if always || a <> b
6846 then
6847 let v =
6848 match a with
6849 | None -> "false"
6850 | Some f ->
6851 if f = infinity
6852 then "true"
6853 else string_of_float f
6855 Printf.bprintf bb "\n %s='%s'" s v
6856 and oco s a b =
6857 if always || a <> b
6858 then
6859 match a with
6860 | Cmulti ((n, a, b), _) when n > 1 ->
6861 Printf.bprintf bb "\n %s='%d,%d,%d'" s n a b
6862 | Csplit (n, _) when n > 1 ->
6863 Printf.bprintf bb "\n %s='%d'" s ~-n
6864 | _ -> ()
6865 and obeco s a b =
6866 if always || a <> b
6867 then
6868 match a with
6869 | Some c when c > 1 -> Printf.bprintf bb "\n %s='%d'" s c
6870 | _ -> ()
6871 and oFm s a b =
6872 if always || a <> b
6873 then
6874 Printf.bprintf bb "\n %s='%s'" s (fitmodel_to_string a)
6876 oi "width" c.cwinw dc.cwinw;
6877 oi "height" c.cwinh dc.cwinh;
6878 oi "scroll-bar-width" c.scrollbw dc.scrollbw;
6879 oi "scroll-handle-height" c.scrollh dc.scrollh;
6880 ob "case-insensitive-search" c.icase dc.icase;
6881 ob "preload" c.preload dc.preload;
6882 oi "page-bias" c.pagebias dc.pagebias;
6883 oi "scroll-step" c.scrollstep dc.scrollstep;
6884 oi "auto-scroll-step" c.autoscrollstep dc.autoscrollstep;
6885 ob "max-height-fit" c.maxhfit dc.maxhfit;
6886 ob "crop-hack" c.crophack dc.crophack;
6887 oW "throttle" c.maxwait dc.maxwait;
6888 ob "highlight-links" c.hlinks dc.hlinks;
6889 ob "under-cursor-info" c.underinfo dc.underinfo;
6890 oi "vertical-margin" c.interpagespace dc.interpagespace;
6891 oz "zoom" c.zoom dc.zoom;
6892 ob "presentation" c.presentation dc.presentation;
6893 oi "rotation-angle" c.angle dc.angle;
6894 ob "persistent-bookmarks" c.savebmarks dc.savebmarks;
6895 oFm "fit-model" c.fitmodel dc.fitmodel;
6896 oI "pixmap-cache-size" c.memlimit dc.memlimit;
6897 oi "tex-count" c.texcount dc.texcount;
6898 oi "slice-height" c.sliceheight dc.sliceheight;
6899 oi "thumbnail-width" c.thumbw dc.thumbw;
6900 ob "persistent-location" c.jumpback dc.jumpback;
6901 oc "background-color" c.bgcolor dc.bgcolor;
6902 ob "scrollbar-in-presentation" c.scrollbarinpm dc.scrollbarinpm;
6903 oi "tile-width" c.tilew dc.tilew;
6904 oi "tile-height" c.tileh dc.tileh;
6905 oI "mupdf-store-size" c.mustoresize dc.mustoresize;
6906 ob "checkers" c.checkers dc.checkers;
6907 oi "aalevel" c.aalevel dc.aalevel;
6908 ob "trim-margins" c.trimmargins dc.trimmargins;
6909 oR "trim-fuzz" c.trimfuzz dc.trimfuzz;
6910 os "uri-launcher" c.urilauncher dc.urilauncher;
6911 os "path-launcher" c.pathlauncher dc.pathlauncher;
6912 oC "color-space" c.colorspace dc.colorspace;
6913 ob "invert-colors" c.invert dc.invert;
6914 oF "brightness" c.colorscale dc.colorscale;
6915 ob "redirectstderr" c.redirectstderr dc.redirectstderr;
6916 og "ghyllscroll" c.ghyllscroll dc.ghyllscroll;
6917 oco "columns" c.columns dc.columns;
6918 obeco "birds-eye-columns" c.beyecolumns dc.beyecolumns;
6919 os "selection-command" c.selcmd dc.selcmd;
6920 os "synctex-command" c.stcmd dc.stcmd;
6921 ob "update-cursor" c.updatecurs dc.updatecurs;
6922 oi "hint-font-size" c.hfsize dc.hfsize;
6923 oi "horizontal-scroll-step" c.hscrollstep dc.hscrollstep;
6924 oF "page-scroll-scale" c.pgscale dc.pgscale;
6925 ob "use-pbo" c.usepbo dc.usepbo;
6926 ob "wheel-scrolls-pages" c.wheelbypage dc.wheelbypage;
6929 let keymapsbuf always dc c =
6930 let bb = Buffer.create 16 in
6931 let rec loop = function
6932 | [] -> ()
6933 | (modename, h) :: rest ->
6934 let dh = findkeyhash dc modename in
6935 if always || h <> dh
6936 then (
6937 if Hashtbl.length h > 0
6938 then (
6939 if Buffer.length bb > 0
6940 then Buffer.add_char bb '\n';
6941 Printf.bprintf bb "<keymap mode='%s'>\n" modename;
6942 Hashtbl.iter (fun i o ->
6943 let isdifferent = always ||
6945 let dO = Hashtbl.find dh i in
6946 dO <> o
6947 with Not_found -> true
6949 if isdifferent
6950 then
6951 let addkm (k, m) =
6952 if Wsi.withctrl m then Buffer.add_string bb "ctrl-";
6953 if Wsi.withalt m then Buffer.add_string bb "alt-";
6954 if Wsi.withshift m then Buffer.add_string bb "shift-";
6955 if Wsi.withmeta m then Buffer.add_string bb "meta-";
6956 Buffer.add_string bb (Wsi.keyname k);
6958 let addkms l =
6959 let rec loop = function
6960 | [] -> ()
6961 | km :: [] -> addkm km
6962 | km :: rest -> addkm km; Buffer.add_char bb ' '; loop rest
6964 loop l
6966 Buffer.add_string bb "<map in='";
6967 addkm i;
6968 match o with
6969 | KMinsrt km ->
6970 Buffer.add_string bb "' out='";
6971 addkm km;
6972 Buffer.add_string bb "'/>\n"
6974 | KMinsrl kms ->
6975 Buffer.add_string bb "' out='";
6976 addkms kms;
6977 Buffer.add_string bb "'/>\n"
6979 | KMmulti (ins, kms) ->
6980 Buffer.add_char bb ' ';
6981 addkms ins;
6982 Buffer.add_string bb "' out='";
6983 addkms kms;
6984 Buffer.add_string bb "'/>\n"
6985 ) h;
6986 Buffer.add_string bb "</keymap>";
6989 loop rest
6991 loop c.keyhashes;
6995 let save () =
6996 let uifontsize = fstate.fontsize in
6997 let bb = Buffer.create 32768 in
6998 let w, h =
6999 List.fold_left
7000 (fun (w, h) ws ->
7001 match ws with
7002 | Wsi.Fullscreen -> (conf.cwinw, conf.cwinh)
7003 | Wsi.MaxVert -> (w, conf.cwinh)
7004 | Wsi.MaxHorz -> (conf.cwinw, h)
7006 (state.winw, state.winh) state.winstate
7008 conf.cwinw <- w;
7009 conf.cwinh <- h;
7010 let f (h, dc) =
7011 let dc = if conf.bedefault then conf else dc in
7012 Buffer.add_string bb "<llppconfig>\n";
7014 if String.length !fontpath > 0
7015 then
7016 Printf.bprintf bb "<ui-font size='%d'><![CDATA[%s]]></ui-font>\n"
7017 uifontsize
7018 !fontpath
7019 else (
7020 if uifontsize <> 14
7021 then
7022 Printf.bprintf bb "<ui-font size='%d'/>\n" uifontsize
7025 Buffer.add_string bb "<defaults ";
7026 add_attrs bb true dc dc;
7027 let kb = keymapsbuf true dc dc in
7028 if Buffer.length kb > 0
7029 then (
7030 Buffer.add_string bb ">\n";
7031 Buffer.add_buffer bb kb;
7032 Buffer.add_string bb "\n</defaults>\n";
7034 else Buffer.add_string bb "/>\n";
7036 let adddoc path pan anchor c bookmarks =
7037 if bookmarks == [] && c = dc && anchor = emptyanchor
7038 then ()
7039 else (
7040 Printf.bprintf bb "<doc path='%s'"
7041 (enent path 0 (String.length path));
7043 if anchor <> emptyanchor
7044 then (
7045 let n, rely, visy = anchor in
7046 Printf.bprintf bb " page='%d'" n;
7047 if rely > 1e-6
7048 then
7049 Printf.bprintf bb " rely='%f'" rely
7051 if abs_float visy > 1e-6
7052 then
7053 Printf.bprintf bb " visy='%f'" visy
7057 if pan != 0
7058 then Printf.bprintf bb " pan='%d'" pan;
7060 add_attrs bb false dc c;
7061 let kb = keymapsbuf false dc c in
7063 begin match bookmarks with
7064 | [] ->
7065 if Buffer.length kb > 0
7066 then (
7067 Buffer.add_string bb ">\n";
7068 Buffer.add_buffer bb kb;
7069 Buffer.add_string bb "\n</doc>\n";
7071 else Buffer.add_string bb "/>\n"
7072 | _ ->
7073 Buffer.add_string bb ">\n<bookmarks>\n";
7074 List.iter (fun (title, _level, (page, rely, visy)) ->
7075 Printf.bprintf bb
7076 "<item title='%s' page='%d'"
7077 (enent title 0 (String.length title))
7078 page
7080 if rely > 1e-6
7081 then
7082 Printf.bprintf bb " rely='%f'" rely
7084 if abs_float visy > 1e-6
7085 then
7086 Printf.bprintf bb " visy='%f'" visy
7088 Buffer.add_string bb "/>\n";
7089 ) bookmarks;
7090 Buffer.add_string bb "</bookmarks>";
7091 if Buffer.length kb > 0
7092 then (
7093 Buffer.add_string bb "\n";
7094 Buffer.add_buffer bb kb;
7096 Buffer.add_string bb "\n</doc>\n";
7097 end;
7101 let pan, conf =
7102 match state.mode with
7103 | Birdseye (c, pan, _, _, _) ->
7104 let beyecolumns =
7105 match conf.columns with
7106 | Cmulti ((c, _, _), _) -> Some c
7107 | Csingle _ -> None
7108 | Csplit _ -> None
7109 and columns =
7110 match c.columns with
7111 | Cmulti (c, _) -> Cmulti (c, [||])
7112 | Csingle _ -> Csingle [||]
7113 | Csplit _ -> failwith "quit from bird's eye while split"
7115 pan, { c with beyecolumns = beyecolumns; columns = columns }
7116 | _ -> state.x, conf
7118 let basename = Filename.basename
7119 (if String.length state.origin = 0 then state.path else state.origin)
7121 adddoc basename pan (getanchor ())
7122 (let conf =
7123 let autoscrollstep =
7124 match state.autoscroll with
7125 | Some step -> step
7126 | None -> conf.autoscrollstep
7128 match state.mode with
7129 | Birdseye (bc, _, _, _, _) ->
7130 { conf with
7131 zoom = bc.zoom;
7132 presentation = bc.presentation;
7133 interpagespace = bc.interpagespace;
7134 maxwait = bc.maxwait;
7135 autoscrollstep = autoscrollstep }
7136 | _ -> { conf with autoscrollstep = autoscrollstep }
7137 in conf)
7138 (if conf.savebmarks then state.bookmarks else []);
7140 Hashtbl.iter (fun path (c, bookmarks, x, anchor) ->
7141 if basename <> path
7142 then adddoc path x anchor c bookmarks
7143 ) h;
7144 Buffer.add_string bb "</llppconfig>\n";
7145 true;
7147 if load1 f && Buffer.length bb > 0
7148 then
7150 let tmp = !confpath ^ ".tmp" in
7151 let oc = open_out_bin tmp in
7152 Buffer.output_buffer oc bb;
7153 close_out oc;
7154 Unix.rename tmp !confpath;
7155 with exn ->
7156 prerr_endline
7157 ("error while saving configuration: " ^ exntos exn)
7159 end;;
7161 let adderrmsg src msg =
7162 Buffer.add_string state.errmsgs msg;
7163 state.newerrmsgs <- true;
7164 G.postRedisplay src
7167 let adderrfmt src fmt =
7168 Format.kprintf (fun s -> adderrmsg src s) fmt;
7171 let ract cmds =
7172 let cl = splitatspace cmds in
7173 let scan s fmt f =
7174 try Scanf.sscanf s fmt f
7175 with exn ->
7176 adderrfmt "remote exec"
7177 "error processing '%S': %s\n" cmds (exntos exn)
7179 match cl with
7180 | "reload" :: [] -> reload ()
7181 | "goto" :: args :: [] ->
7182 scan args "%u %f %f"
7183 (fun pageno x y ->
7184 let cmd, _ = state.geomcmds in
7185 if String.length cmd = 0
7186 then gotopagexy pageno x y
7187 else
7188 let f prevf () =
7189 gotopagexy pageno x y;
7190 prevf ()
7192 state.reprf <- f state.reprf
7194 | "goto1" :: args :: [] -> scan args "%u %f" gotopage
7195 | "rect" :: args :: [] ->
7196 scan args "%u %u %f %f %f %f"
7197 (fun pageno color x0 y0 x1 y1 ->
7198 onpagerect pageno (fun w h ->
7199 let _,w1,h1,_ = getpagedim pageno in
7200 let sw = float w1 /. w
7201 and sh = float h1 /. h in
7202 let x0s = x0 *. sw
7203 and x1s = x1 *. sw
7204 and y0s = y0 *. sh
7205 and y1s = y1 *. sh in
7206 let rect = (x0s,y0s,x1s,y0s,x1s,y1s,x0s,y1s) in
7207 debugrect rect;
7208 state.rects <- (pageno, color, rect) :: state.rects;
7209 G.postRedisplay "rect";
7212 | "activatewin" :: [] -> Wsi.activatewin ()
7213 | "quit" :: [] -> raise Quit
7214 | _ ->
7215 adderrfmt "remote command"
7216 "error processing remote command: %S\n" cmds;
7219 let remote =
7220 let scratch = String.create 80 in
7221 let buf = Buffer.create 80 in
7222 fun fd ->
7223 let rec tempfr () =
7224 try Some (Unix.read fd scratch 0 80)
7225 with
7226 | Unix.Unix_error (Unix.EAGAIN, _, _) -> None
7227 | Unix.Unix_error (Unix.EINTR, _, _) -> tempfr ()
7228 | exn -> raise exn
7230 match tempfr () with
7231 | None -> Some fd
7232 | Some n ->
7233 if n = 0
7234 then (
7235 Unix.close fd;
7236 if Buffer.length buf > 0
7237 then (
7238 let s = Buffer.contents buf in
7239 Buffer.clear buf;
7240 ract s;
7242 None
7244 else
7245 let rec eat ppos =
7246 let nlpos =
7248 let pos = String.index_from scratch ppos '\n' in
7249 if pos >= n then -1 else pos
7250 with Not_found -> -1
7252 if nlpos >= 0
7253 then (
7254 Buffer.add_substring buf scratch ppos (nlpos-ppos);
7255 let s = Buffer.contents buf in
7256 Buffer.clear buf;
7257 ract s;
7258 eat (nlpos+1);
7260 else (
7261 Buffer.add_substring buf scratch ppos (n-ppos);
7262 Some fd
7264 in eat 0
7267 let remoteopen path =
7268 try Some (Unix.openfile path [Unix.O_NONBLOCK; Unix.O_RDONLY] 0o0)
7269 with exn ->
7270 adderrfmt "remoteopen" "error opening %S: %s" path (exntos exn);
7271 None
7274 let () =
7275 let trimcachepath = ref "" in
7276 let rcmdpath = ref "" in
7277 Arg.parse
7278 (Arg.align
7279 [("-p", Arg.String (fun s -> state.password <- s),
7280 "<password> Set password");
7282 ("-f", Arg.String (fun s -> Config.fontpath := s),
7283 "<path> Set path to the user interface font");
7285 ("-c", Arg.String (fun s -> Config.confpath := s),
7286 "<path> Set path to the configuration file");
7288 ("-tcf", Arg.String (fun s -> trimcachepath := s),
7289 "<path> Set path to the trim cache file");
7291 ("-dest", Arg.String (fun s -> state.nameddest <- s),
7292 "<named-destination> Set named destination");
7294 ("-wtmode", Arg.Set wtmode, " Operate in wt mode");
7296 ("-remote", Arg.String (fun s -> rcmdpath := s),
7297 "<path> Set path to the remote commands source");
7299 ("-origin", Arg.String (fun s -> state.origin <- s),
7300 "<original path> Set original path");
7302 ("-v", Arg.Unit (fun () ->
7303 Printf.printf
7304 "%s\nconfiguration path: %s\n"
7305 (version ())
7306 Config.defconfpath
7308 exit 0), " Print version and exit");
7311 (fun s -> state.path <- s)
7312 ("Usage: " ^ Sys.argv.(0) ^ " [options] some.pdf\nOptions:")
7314 if String.length state.path = 0
7315 then (prerr_endline "file name missing"; exit 1);
7317 if not (Config.load ())
7318 then prerr_endline "failed to load configuration";
7320 let globalkeyhash = findkeyhash conf "global" in
7321 let wsfd, winw, winh = Wsi.init (object
7322 method expose =
7323 if nogeomcmds state.geomcmds || platform == Posx
7324 then display ()
7325 else (
7326 GlClear.color (scalecolor2 conf.bgcolor);
7327 GlClear.clear [`color];
7329 method display = display ()
7330 method reshape w h = reshape w h
7331 method mouse b d x y m = mouse b d x y m
7332 method motion x y = state.mpos <- (x, y); motion x y
7333 method pmotion x y = state.mpos <- (x, y); pmotion x y
7334 method key k m =
7335 let mascm = m land (
7336 Wsi.altmask + Wsi.shiftmask + Wsi.ctrlmask + Wsi.metamask
7337 ) in
7338 match state.keystate with
7339 | KSnone ->
7340 let km = k, mascm in
7341 begin
7342 match
7343 let modehash = state.uioh#modehash in
7344 try Hashtbl.find modehash km
7345 with Not_found ->
7346 try Hashtbl.find globalkeyhash km
7347 with Not_found -> KMinsrt (k, m)
7348 with
7349 | KMinsrt (k, m) -> keyboard k m
7350 | KMinsrl l -> List.iter (fun (k, m) -> keyboard k m) l
7351 | KMmulti (l, r) -> state.keystate <- KSinto (l, r)
7353 | KSinto ((k', m') :: [], insrt) when k'=k && m' land mascm = m' ->
7354 List.iter (fun (k, m) -> keyboard k m) insrt;
7355 state.keystate <- KSnone
7356 | KSinto ((k', m') :: keys, insrt) when k'=k && m' land mascm = m' ->
7357 state.keystate <- KSinto (keys, insrt)
7358 | _ ->
7359 state.keystate <- KSnone
7361 method enter x y = state.mpos <- (x, y); pmotion x y
7362 method leave = state.mpos <- (-1, -1)
7363 method winstate wsl = state.winstate <- wsl
7364 method quit = raise Quit
7365 end) conf.cwinw conf.cwinh (platform = Posx) in
7367 state.wsfd <- wsfd;
7369 if not (
7370 List.exists GlMisc.check_extension
7371 [ "GL_ARB_texture_rectangle"
7372 ; "GL_EXT_texture_recangle"
7373 ; "GL_NV_texture_rectangle" ]
7375 then (prerr_endline "OpenGL does not suppport rectangular textures"; exit 1);
7377 let cr, sw =
7378 match Ne.pipe () with
7379 | Ne.Exn exn ->
7380 Printf.eprintf "pipe/crsw failed: %s" (exntos exn);
7381 exit 1
7382 | Ne.Res rw -> rw
7383 and sr, cw =
7384 match Ne.pipe () with
7385 | Ne.Exn exn ->
7386 Printf.eprintf "pipe/srcw failed: %s" (exntos exn);
7387 exit 1
7388 | Ne.Res rw -> rw
7391 cloexec cr;
7392 cloexec sw;
7393 cloexec sr;
7394 cloexec cw;
7396 setcheckers conf.checkers;
7397 redirectstderr ();
7399 init (cr, cw) (
7400 conf.angle, conf.fitmodel, (conf.trimmargins, conf.trimfuzz),
7401 conf.texcount, conf.sliceheight, conf.mustoresize, conf.colorspace,
7402 !Config.fontpath, !trimcachepath,
7403 GlMisc.check_extension "GL_ARB_pixel_buffer_object"
7405 state.sr <- sr;
7406 state.sw <- sw;
7407 state.text <- "Opening " ^ (mbtoutf8 state.path);
7408 reshape winw winh;
7409 opendoc state.path state.password;
7410 state.uioh <- uioh;
7412 Sys.set_signal Sys.sighup (Sys.Signal_handle (fun _ -> reload ()));
7413 let optrfd =
7414 ref (
7415 if String.length !rcmdpath > 0
7416 then remoteopen !rcmdpath
7417 else None
7421 let rec loop deadline =
7422 let r =
7423 match state.errfd with
7424 | None -> [state.sr; state.wsfd]
7425 | Some fd -> [state.sr; state.wsfd; fd]
7427 let r =
7428 match !optrfd with
7429 | None -> r
7430 | Some fd -> fd :: r
7432 if state.redisplay
7433 then (
7434 state.redisplay <- false;
7435 display ();
7437 let timeout =
7438 let now = now () in
7439 if deadline > now
7440 then (
7441 if deadline = infinity
7442 then ~-.1.0
7443 else max 0.0 (deadline -. now)
7445 else 0.0
7447 let r, _, _ =
7448 try Unix.select r [] [] timeout
7449 with Unix.Unix_error (Unix.EINTR, _, _) -> [], [], []
7451 begin match r with
7452 | [] ->
7453 state.ghyll None;
7454 let newdeadline =
7455 if state.ghyll == noghyll
7456 then
7457 match state.autoscroll with
7458 | Some step when step != 0 ->
7459 let y = state.y + step in
7460 let y =
7461 if y < 0
7462 then state.maxy
7463 else if y >= state.maxy then 0 else y
7465 gotoy y;
7466 if state.mode = View
7467 then state.text <- "";
7468 deadline +. 0.01
7469 | _ -> infinity
7470 else deadline +. 0.01
7472 loop newdeadline
7474 | l ->
7475 let rec checkfds = function
7476 | [] -> ()
7477 | fd :: rest when fd = state.sr ->
7478 let cmd = readcmd state.sr in
7479 act cmd;
7480 checkfds rest
7482 | fd :: rest when fd = state.wsfd ->
7483 Wsi.readresp fd;
7484 checkfds rest
7486 | fd :: rest when Some fd = !optrfd ->
7487 begin match remote fd with
7488 | None -> optrfd := remoteopen !rcmdpath;
7489 | opt -> optrfd := opt
7490 end;
7491 checkfds rest
7493 | fd :: rest ->
7494 let s = String.create 80 in
7495 let n = tempfailureretry (Unix.read fd s 0) 80 in
7496 if conf.redirectstderr
7497 then (
7498 Buffer.add_substring state.errmsgs s 0 n;
7499 state.newerrmsgs <- true;
7500 state.redisplay <- true;
7502 else (
7503 prerr_string (String.sub s 0 n);
7504 flush stderr;
7506 checkfds rest
7508 checkfds l;
7509 let newdeadline =
7510 let deadline1 =
7511 if deadline = infinity
7512 then now () +. 0.01
7513 else deadline
7515 match state.autoscroll with
7516 | Some step when step != 0 -> deadline1
7517 | _ -> if state.ghyll == noghyll then infinity else deadline1
7519 loop newdeadline
7520 end;
7523 loop infinity;
7524 with Quit ->
7525 Config.save ();