Consistency
[llpp/slowscroll.git] / main.ml
blob00e1963ff8945aece7f7eb59ebc879f241e69ddb
1 exception Quit;;
3 let tempfailureretry = Wsi.tempfailureretry;;
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 let dolog fmt = Printf.kprintf prerr_endline fmt;;
17 let now = Unix.gettimeofday;;
19 type params = (angle * proportional * trimparams
20 * texcount * sliceheight * memsize
21 * colorspace * fontpath * trimcachepath
22 * haspbo)
23 and pageno = int
24 and width = int
25 and height = int
26 and leftx = int
27 and opaque = string
28 and recttype = int
29 and pixmapsize = int
30 and angle = int
31 and proportional = bool
32 and trimmargins = bool
33 and interpagespace = int
34 and texcount = int
35 and sliceheight = int
36 and gen = int
37 and top = float
38 and dtop = float
39 and fontpath = string
40 and trimcachepath = string
41 and memsize = int
42 and aalevel = int
43 and irect = (int * int * int * int)
44 and trimparams = (trimmargins * irect)
45 and colorspace = | Rgb | Bgr | Gray
46 and haspbo = bool
49 type link =
50 | Lnotfound
51 | Lfound of int
52 and linkdir =
53 | LDfirst
54 | LDlast
55 | LDfirstvisible of (int * int * int)
56 | LDleft of int
57 | LDright of int
58 | LDdown of int
59 | LDup of int
62 type pagewithlinks =
63 | Pwlnotfound
64 | Pwl of int
67 type keymap =
68 | KMinsrt of key
69 | KMinsrl of key list
70 | KMmulti of key list * key list
71 and key = int * int
72 and keyhash = (key, keymap) Hashtbl.t
73 and keystate =
74 | KSnone
75 | KSinto of (key list * key list)
78 type platform = | Punknown | Plinux | Posx | Psun | Pfreebsd
79 | Pdragonflybsd | Popenbsd | Pnetbsd | Pcygwin;;
81 type pipe = (Unix.file_descr * Unix.file_descr);;
83 external init : pipe -> params -> unit = "ml_init";;
84 external seltext : string -> (int * int * int * int) -> unit = "ml_seltext";;
85 external copysel : Unix.file_descr -> opaque -> unit = "ml_copysel";;
86 external getpdimrect : int -> float array = "ml_getpdimrect";;
87 external whatsunder : string -> int -> int -> under = "ml_whatsunder";;
88 external zoomforh : int -> int -> int -> int -> float = "ml_zoom_for_height";;
89 external drawstr : int -> int -> int -> string -> float = "ml_draw_string";;
90 external measurestr : int -> string -> float = "ml_measure_string";;
91 external getmaxw : unit -> float = "ml_getmaxw";;
92 external postprocess :
93 opaque -> int -> int -> int -> (int * string * int) -> int = "ml_postprocess";;
94 external pagebbox : opaque -> (int * int * int * int) = "ml_getpagebox";;
95 external platform : unit -> platform = "ml_platform";;
96 external setaalevel : int -> unit = "ml_setaalevel";;
97 external realloctexts : int -> bool = "ml_realloctexts";;
98 external cloexec : Unix.file_descr -> unit = "ml_cloexec";;
99 external findlink : opaque -> linkdir -> link = "ml_findlink";;
100 external getlink : opaque -> int -> under = "ml_getlink";;
101 external getlinkrect : opaque -> int -> irect = "ml_getlinkrect";;
102 external getlinkcount : opaque -> int = "ml_getlinkcount";;
103 external findpwl : int -> int -> pagewithlinks = "ml_find_page_with_links"
104 external popen : string -> (Unix.file_descr * int) list -> unit = "ml_popen";;
105 external mbtoutf8 : string -> string = "ml_mbtoutf8";;
106 external getpbo : width -> height -> colorspace -> string = "ml_getpbo";;
107 external freepbo : string -> unit = "ml_freepbo";;
108 external unmappbo : string -> unit = "ml_unmappbo";;
109 external pbousable : unit -> bool = "ml_pbo_usable";;
111 let platform_to_string = function
112 | Punknown -> "unknown"
113 | Plinux -> "Linux"
114 | Posx -> "OSX"
115 | Psun -> "Sun"
116 | Pfreebsd -> "FreeBSD"
117 | Pdragonflybsd -> "DragonflyBSD"
118 | Popenbsd -> "OpenBSD"
119 | Pnetbsd -> "NetBSD"
120 | Pcygwin -> "Cygwin"
123 let platform = platform ();;
125 let popen cmd fda =
126 if platform = Pcygwin
127 then (
128 let sh = "/bin/sh" in
129 let args = [|sh; "-c"; cmd|] in
130 let rec std si so se = function
131 | [] -> si, so, se
132 | (fd, 0) :: rest -> std fd so se rest
133 | (fd, -1) :: rest ->
134 Unix.set_close_on_exec fd;
135 std si so se rest
136 | (_, n) :: _ ->
137 failwith ("unexpected fdn in cygwin popen " ^ string_of_int n)
139 let si, so, se = std Unix.stdin Unix.stdout Unix.stderr fda in
140 ignore (Unix.create_process sh args si so se)
142 else popen cmd fda;
145 type x = int
146 and y = int
147 and tilex = int
148 and tiley = int
149 and tileparams = (x * y * width * height * tilex * tiley)
152 external drawtile : tileparams -> opaque -> unit = "ml_drawtile";;
154 type mpos = int * int
155 and mstate =
156 | Msel of (mpos * mpos)
157 | Mpan of mpos
158 | Mscrolly | Mscrollx
159 | Mzoom of (int * int)
160 | Mzoomrect of (mpos * mpos)
161 | Mnone
164 type textentry = string * string * onhist option * onkey * ondone * cancelonempty
165 and onkey = string -> int -> te
166 and ondone = string -> unit
167 and histcancel = unit -> unit
168 and onhist = ((histcmd -> string) * histcancel)
169 and histcmd = HCnext | HCprev | HCfirst | HClast
170 and cancelonempty = bool
171 and te =
172 | TEstop
173 | TEdone of string
174 | TEcont of string
175 | TEswitch of textentry
178 type 'a circbuf =
179 { store : 'a array
180 ; mutable rc : int
181 ; mutable wc : int
182 ; mutable len : int
186 let bound v minv maxv =
187 max minv (min maxv v);
190 let cbnew n v =
191 { store = Array.create n v
192 ; rc = 0
193 ; wc = 0
194 ; len = 0
198 let cbcap b = Array.length b.store;;
200 let cbput b v =
201 let cap = cbcap b in
202 b.store.(b.wc) <- v;
203 b.wc <- (b.wc + 1) mod cap;
204 b.rc <- b.wc;
205 b.len <- min (b.len + 1) cap;
208 let cbempty b = b.len = 0;;
210 let cbgetg b circular dir =
211 if cbempty b
212 then b.store.(0)
213 else
214 let rc = b.rc + dir in
215 let rc =
216 if circular
217 then (
218 if rc = -1
219 then b.len-1
220 else (
221 if rc >= b.len
222 then 0
223 else rc
226 else bound rc 0 (b.len-1)
228 b.rc <- rc;
229 b.store.(rc);
232 let cbget b = cbgetg b false;;
233 let cbgetc b = cbgetg b true;;
235 let drawstring size x y s =
236 Gl.enable `blend;
237 Gl.enable `texture_2d;
238 GlFunc.blend_func `src_alpha `one_minus_src_alpha;
239 ignore (drawstr size x y s);
240 Gl.disable `blend;
241 Gl.disable `texture_2d;
244 let drawstring1 size x y s =
245 drawstr size x y s;
248 let drawstring2 size x y fmt =
249 Printf.kprintf (drawstring size (x+1) (y+size+1)) fmt
252 type page =
253 { pageno : int
254 ; pagedimno : int
255 ; pagew : int
256 ; pageh : int
257 ; pagex : int
258 ; pagey : int
259 ; pagevw : int
260 ; pagevh : int
261 ; pagedispx : int
262 ; pagedispy : int
263 ; pagecol : int
267 let debugl l =
268 dolog "l %d dim=%d {" l.pageno l.pagedimno;
269 dolog " WxH %dx%d" l.pagew l.pageh;
270 dolog " vWxH %dx%d" l.pagevw l.pagevh;
271 dolog " pagex,y %d,%d" l.pagex l.pagey;
272 dolog " dispx,y %d,%d" l.pagedispx l.pagedispy;
273 dolog " column %d" l.pagecol;
274 dolog "}";
277 let debugrect (x0, y0, x1, y1, x2, y2, x3, y3) =
278 dolog "rect {";
279 dolog " x0,y0=(% f, % f)" x0 y0;
280 dolog " x1,y1=(% f, % f)" x1 y1;
281 dolog " x2,y2=(% f, % f)" x2 y2;
282 dolog " x3,y3=(% f, % f)" x3 y3;
283 dolog "}";
286 type multicolumns = multicol * pagegeom
287 and singlecolumn = pagegeom
288 and splitcolumns = columncount * pagegeom
289 and pagegeom = ((pdimno * x * y * (pageno * width * height * leftx)) array)
290 and multicol = columncount * covercount * covercount
291 and pdimno = int
292 and columncount = int
293 and covercount = int;;
295 type conf =
296 { mutable scrollbw : int
297 ; mutable scrollh : int
298 ; mutable icase : bool
299 ; mutable preload : bool
300 ; mutable pagebias : int
301 ; mutable verbose : bool
302 ; mutable debug : bool
303 ; mutable scrollstep : int
304 ; mutable hscrollstep : int
305 ; mutable maxhfit : bool
306 ; mutable crophack : bool
307 ; mutable autoscrollstep : int
308 ; mutable maxwait : float option
309 ; mutable hlinks : bool
310 ; mutable underinfo : bool
311 ; mutable interpagespace : interpagespace
312 ; mutable zoom : float
313 ; mutable presentation : bool
314 ; mutable angle : angle
315 ; mutable winw : int
316 ; mutable winh : int
317 ; mutable savebmarks : bool
318 ; mutable proportional : proportional
319 ; mutable trimmargins : trimmargins
320 ; mutable trimfuzz : irect
321 ; mutable memlimit : memsize
322 ; mutable texcount : texcount
323 ; mutable sliceheight : sliceheight
324 ; mutable thumbw : width
325 ; mutable jumpback : bool
326 ; mutable bgcolor : float * float * float
327 ; mutable bedefault : bool
328 ; mutable scrollbarinpm : bool
329 ; mutable tilew : int
330 ; mutable tileh : int
331 ; mutable mustoresize : memsize
332 ; mutable checkers : bool
333 ; mutable aalevel : int
334 ; mutable urilauncher : string
335 ; mutable pathlauncher : string
336 ; mutable colorspace : colorspace
337 ; mutable invert : bool
338 ; mutable colorscale : float
339 ; mutable redirectstderr : bool
340 ; mutable ghyllscroll : (int * int * int) option
341 ; mutable columns : columns
342 ; mutable beyecolumns : columncount option
343 ; mutable selcmd : string
344 ; mutable updatecurs : bool
345 ; mutable keyhashes : (string * keyhash) list
346 ; mutable hfsize : int
347 ; mutable pgscale : float
348 ; mutable usepbo : bool
349 ; mutable wheelbypage : bool
351 and columns =
352 | Csingle of singlecolumn
353 | Cmulti of multicolumns
354 | Csplit of splitcolumns
357 type anchor = pageno * top * dtop;;
359 type outline = string * int * anchor;;
361 type rect = float * float * float * float * float * float * float * float;;
363 type tile = opaque * pixmapsize * elapsed
364 and elapsed = float;;
365 type pagemapkey = pageno * gen;;
366 type tilemapkey = pageno * gen * colorspace * angle * width * height * col * row
367 and row = int
368 and col = int;;
370 let emptyanchor = (0, 0.0, 0.0);;
372 type infochange = | Memused | Docinfo | Pdim;;
374 class type uioh = object
375 method display : unit
376 method key : int -> int -> uioh
377 method button : int -> bool -> int -> int -> int -> uioh
378 method motion : int -> int -> uioh
379 method pmotion : int -> int -> uioh
380 method infochanged : infochange -> unit
381 method scrollpw : (int * float * float)
382 method scrollph : (int * float * float)
383 method modehash : keyhash
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 end;;
427 type state =
428 { mutable sr : Unix.file_descr
429 ; mutable sw : Unix.file_descr
430 ; mutable wsfd : Unix.file_descr
431 ; mutable errfd : Unix.file_descr option
432 ; mutable stderr : Unix.file_descr
433 ; mutable errmsgs : Buffer.t
434 ; mutable newerrmsgs : bool
435 ; mutable w : int
436 ; mutable x : int
437 ; mutable y : int
438 ; mutable scrollw : int
439 ; mutable hscrollh : int
440 ; mutable anchor : anchor
441 ; mutable ranchors : (string * string * anchor) list
442 ; mutable maxy : int
443 ; mutable layout : page list
444 ; pagemap : (pagemapkey, opaque) Hashtbl.t
445 ; tilemap : (tilemapkey, tile) Hashtbl.t
446 ; tilelru : (tilemapkey * opaque * pixmapsize) Queue.t
447 ; mutable pdims : (pageno * width * height * leftx) list
448 ; mutable pagecount : int
449 ; mutable currently : currently
450 ; mutable mstate : mstate
451 ; mutable searchpattern : string
452 ; mutable rects : (pageno * recttype * rect) list
453 ; mutable rects1 : (pageno * recttype * rect) list
454 ; mutable text : string
455 ; mutable fullscreen : (width * height) option
456 ; mutable mode : mode
457 ; mutable uioh : uioh
458 ; mutable outlines : outline array
459 ; mutable bookmarks : outline list
460 ; mutable path : string
461 ; mutable password : string
462 ; mutable nameddest : string
463 ; mutable geomcmds : (string * ((string * (unit -> unit)) list))
464 ; mutable memused : memsize
465 ; mutable gen : gen
466 ; mutable throttle : (page list * int * float) option
467 ; mutable autoscroll : int option
468 ; mutable ghyll : (int option -> unit)
469 ; mutable help : helpitem array
470 ; mutable docinfo : (int * string) list
471 ; mutable texid : GlTex.texture_id option
472 ; hists : hists
473 ; mutable prevzoom : float
474 ; mutable progress : float
475 ; mutable redisplay : bool
476 ; mutable mpos : mpos
477 ; mutable keystate : keystate
478 ; mutable glinks : bool
479 ; mutable prevcolumns : (columns * float) option
480 ; mutable wthack : bool
482 and hists =
483 { pat : string circbuf
484 ; pag : string circbuf
485 ; nav : anchor circbuf
486 ; sel : string circbuf
490 let defconf =
491 { scrollbw = 7
492 ; scrollh = 12
493 ; icase = true
494 ; preload = true
495 ; pagebias = 0
496 ; verbose = false
497 ; debug = false
498 ; scrollstep = 24
499 ; hscrollstep = 24
500 ; maxhfit = true
501 ; crophack = false
502 ; autoscrollstep = 2
503 ; maxwait = None
504 ; hlinks = false
505 ; underinfo = false
506 ; interpagespace = 2
507 ; zoom = 1.0
508 ; presentation = false
509 ; angle = 0
510 ; winw = 900
511 ; winh = 900
512 ; savebmarks = true
513 ; proportional = true
514 ; trimmargins = false
515 ; trimfuzz = (0,0,0,0)
516 ; memlimit = 32 lsl 20
517 ; texcount = 256
518 ; sliceheight = 24
519 ; thumbw = 76
520 ; jumpback = true
521 ; bgcolor = (0.5, 0.5, 0.5)
522 ; bedefault = false
523 ; scrollbarinpm = true
524 ; tilew = 2048
525 ; tileh = 2048
526 ; mustoresize = 256 lsl 20
527 ; checkers = true
528 ; aalevel = 8
529 ; urilauncher =
530 (match platform with
531 | Plinux | Pfreebsd | Pdragonflybsd
532 | Popenbsd | Pnetbsd | Psun -> "xdg-open \"%s\""
533 | Posx -> "open \"%s\""
534 | Pcygwin -> "cygstart \"%s\""
535 | Punknown -> "echo %s")
536 ; pathlauncher = "lp \"%s\""
537 ; selcmd =
538 (match platform with
539 | Plinux | Pfreebsd | Pdragonflybsd
540 | Popenbsd | Pnetbsd | Psun -> "xsel -i"
541 | Posx -> "pbcopy"
542 | Pcygwin -> "wsel"
543 | Punknown -> "cat")
544 ; colorspace = Rgb
545 ; invert = false
546 ; colorscale = 1.0
547 ; redirectstderr = false
548 ; ghyllscroll = None
549 ; columns = Csingle [||]
550 ; beyecolumns = None
551 ; updatecurs = false
552 ; hfsize = 12
553 ; pgscale = 1.0
554 ; usepbo = false
555 ; wheelbypage = false
556 ; keyhashes =
557 let mk n = (n, Hashtbl.create 1) in
558 [ mk "global"
559 ; mk "info"
560 ; mk "help"
561 ; mk "outline"
562 ; mk "listview"
563 ; mk "birdseye"
564 ; mk "textentry"
565 ; mk "links"
566 ; mk "view"
571 let wtmode = ref false;;
573 let findkeyhash c name =
574 try List.assoc name c.keyhashes
575 with Not_found -> failwith ("invalid mode name `" ^ name ^ "'")
578 let conf = { defconf with angle = defconf.angle };;
580 let pgscale h = truncate (float h *. conf.pgscale);;
582 type fontstate =
583 { mutable fontsize : int
584 ; mutable wwidth : float
585 ; mutable maxrows : int
589 let fstate =
590 { fontsize = 14
591 ; wwidth = nan
592 ; maxrows = -1
596 let setfontsize n =
597 fstate.fontsize <- n;
598 fstate.wwidth <- measurestr fstate.fontsize "w";
599 fstate.maxrows <- (conf.winh - fstate.fontsize - 1) / (fstate.fontsize + 1);
602 let geturl s =
603 let colonpos = try String.index s ':' with Not_found -> -1 in
604 let len = String.length s in
605 if colonpos >= 0 && colonpos + 3 < len
606 then (
607 if s.[colonpos+1] = '/' && s.[colonpos+2] = '/'
608 then
609 let schemestartpos =
610 try String.rindex_from s colonpos ' '
611 with Not_found -> -1
613 let scheme =
614 String.sub s (schemestartpos+1) (colonpos-1-schemestartpos)
616 match scheme with
617 | "http" | "ftp" | "mailto" ->
618 let epos =
619 try String.index_from s colonpos ' '
620 with Not_found -> len
622 String.sub s (schemestartpos+1) (epos-1-schemestartpos)
623 | _ -> ""
624 else ""
626 else ""
629 let gotouri uri =
630 if String.length conf.urilauncher = 0
631 then print_endline uri
632 else (
633 let url = geturl uri in
634 if String.length url = 0
635 then print_endline uri
636 else
637 let re = Str.regexp "%s" in
638 let command = Str.global_replace re url conf.urilauncher in
639 try popen command []
640 with exn ->
641 Printf.eprintf
642 "failed to execute `%s': %s\n" command (Printexc.to_string exn);
643 flush stderr;
647 let version () =
648 Printf.sprintf "llpp version %s (%s/%dbit, ocaml %s)" Help.version
649 (platform_to_string platform) Sys.word_size Sys.ocaml_version
652 let makehelp () =
653 let strings = version () :: "" :: Help.keys in
654 Array.of_list (
655 List.map (fun s ->
656 let url = geturl s in
657 if String.length url > 0
658 then (s, 0, Action (fun u -> gotouri url; u))
659 else (s, 0, Noaction)
660 ) strings);
663 let noghyll _ = ();;
664 let firstgeomcmds = "", [];;
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 ; fullscreen = None
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 ; wthack = false
728 let vlog fmt =
729 if conf.verbose
730 then
731 Printf.kprintf prerr_endline fmt
732 else
733 Printf.kprintf ignore fmt
736 let launchpath () =
737 if String.length conf.pathlauncher = 0
738 then print_endline state.path
739 else (
740 let re = Str.regexp "%s" in
741 let command = Str.global_replace re state.path conf.pathlauncher in
742 try popen command []
743 with exn ->
744 Printf.eprintf
745 "failed to execute `%s': %s\n" command (Printexc.to_string exn);
746 flush stderr;
750 module Ne = struct
751 type 'a t = | Res of 'a | Exn of exn;;
753 let pipe () =
754 try Res (Unix.pipe ())
755 with exn -> Exn exn
758 let clo fd f =
759 try tempfailureretry Unix.close fd
760 with exn -> f (Printexc.to_string exn)
763 let dup fd =
764 try Res (tempfailureretry Unix.dup fd)
765 with exn -> Exn exn
768 let dup2 fd1 fd2 =
769 try Res (tempfailureretry (Unix.dup2 fd1) fd2)
770 with exn -> Exn exn
772 end;;
774 let redirectstderr () =
775 let clofail what errmsg = dolog "failed to close %s: %s" what errmsg in
776 if conf.redirectstderr
777 then
778 match Ne.pipe () with
779 | Ne.Exn exn ->
780 dolog "failed to create stderr redirection pipes: %s"
781 (Printexc.to_string exn)
783 | Ne.Res (r, w) ->
784 begin match Ne.dup Unix.stderr with
785 | Ne.Exn exn ->
786 dolog "failed to dup stderr: %s" (Printexc.to_string exn);
787 Ne.clo r (clofail "pipe/r");
788 Ne.clo w (clofail "pipe/w");
790 | Ne.Res dupstderr ->
791 begin match Ne.dup2 w Unix.stderr with
792 | Ne.Exn exn ->
793 dolog "failed to dup2 to stderr: %s"
794 (Printexc.to_string exn);
795 Ne.clo dupstderr (clofail "stderr duplicate");
796 Ne.clo r (clofail "redir pipe/r");
797 Ne.clo w (clofail "redir pipe/w");
799 | Ne.Res () ->
800 state.stderr <- dupstderr;
801 state.errfd <- Some r;
802 end;
804 else (
805 state.newerrmsgs <- false;
806 begin match state.errfd with
807 | Some fd ->
808 begin match Ne.dup2 state.stderr Unix.stderr with
809 | Ne.Exn exn ->
810 dolog "failed to dup2 original stderr: %s"
811 (Printexc.to_string exn)
812 | Ne.Res () ->
813 Ne.clo fd (clofail "dup of stderr");
814 state.errfd <- None;
815 end;
816 | None -> ()
817 end;
818 prerr_string (Buffer.contents state.errmsgs);
819 flush stderr;
820 Buffer.clear state.errmsgs;
824 module G =
825 struct
826 let postRedisplay who =
827 if conf.verbose
828 then prerr_endline ("redisplay for " ^ who);
829 state.redisplay <- true;
831 end;;
833 let getopaque pageno =
834 try Some (Hashtbl.find state.pagemap (pageno, state.gen))
835 with Not_found -> None
838 let putopaque pageno opaque =
839 Hashtbl.replace state.pagemap (pageno, state.gen) opaque
842 let pagetranslatepoint l x y =
843 let dy = y - l.pagedispy in
844 let y = dy + l.pagey in
845 let dx = x - l.pagedispx in
846 let x = dx + l.pagex in
847 (x, y);
850 let getunder x y =
851 let rec f = function
852 | l :: rest ->
853 begin match getopaque l.pageno with
854 | Some opaque ->
855 let x0 = l.pagedispx in
856 let x1 = x0 + l.pagevw in
857 let y0 = l.pagedispy in
858 let y1 = y0 + l.pagevh in
859 if y >= y0 && y <= y1 && x >= x0 && x <= x1
860 then
861 let px, py = pagetranslatepoint l x y in
862 match whatsunder opaque px py with
863 | Unone -> f rest
864 | under -> under
865 else f rest
866 | _ ->
867 f rest
869 | [] -> Unone
871 f state.layout
874 let showtext c s =
875 state.text <- Printf.sprintf "%c%s" c s;
876 G.postRedisplay "showtext";
879 let undertext = function
880 | Unone -> "none"
881 | Ulinkuri s -> s
882 | Ulinkgoto (pageno, _) -> Printf.sprintf "%s: page %d" state.path (pageno+1)
883 | Utext s -> "font: " ^ s
884 | Uunexpected s -> "unexpected: " ^ s
885 | Ulaunch s -> "launch: " ^ s
886 | Unamed s -> "named: " ^ s
887 | Uremote (filename, pageno) ->
888 Printf.sprintf "%s: page %d" filename (pageno+1)
891 let updateunder x y =
892 match getunder x y with
893 | Unone -> Wsi.setcursor Wsi.CURSOR_INHERIT
894 | Ulinkuri uri ->
895 if conf.underinfo then showtext 'u' ("ri: " ^ uri);
896 Wsi.setcursor Wsi.CURSOR_INFO
897 | Ulinkgoto (pageno, _) ->
898 if conf.underinfo
899 then showtext 'p' ("age: " ^ string_of_int (pageno+1));
900 Wsi.setcursor Wsi.CURSOR_INFO
901 | Utext s ->
902 if conf.underinfo then showtext 'f' ("ont: " ^ s);
903 Wsi.setcursor Wsi.CURSOR_TEXT
904 | Uunexpected s ->
905 if conf.underinfo then showtext 'u' ("nexpected: " ^ s);
906 Wsi.setcursor Wsi.CURSOR_INHERIT
907 | Ulaunch s ->
908 if conf.underinfo then showtext 'l' ("aunch: " ^ s);
909 Wsi.setcursor Wsi.CURSOR_INHERIT
910 | Unamed s ->
911 if conf.underinfo then showtext 'n' ("amed: " ^ s);
912 Wsi.setcursor Wsi.CURSOR_INHERIT
913 | Uremote (filename, pageno) ->
914 if conf.underinfo then showtext 'r'
915 (Printf.sprintf "emote: %s (%d)" filename (pageno+1));
916 Wsi.setcursor Wsi.CURSOR_INFO
919 let showlinktype under =
920 if conf.underinfo
921 then
922 match under with
923 | Unone -> ()
924 | under ->
925 let s = undertext under in
926 showtext ' ' s
929 let addchar s c =
930 let b = Buffer.create (String.length s + 1) in
931 Buffer.add_string b s;
932 Buffer.add_char b c;
933 Buffer.contents b;
936 let colorspace_of_string s =
937 match String.lowercase s with
938 | "rgb" -> Rgb
939 | "bgr" -> Bgr
940 | "gray" -> Gray
941 | _ -> failwith "invalid colorspace"
944 let int_of_colorspace = function
945 | Rgb -> 0
946 | Bgr -> 1
947 | Gray -> 2
950 let colorspace_of_int = function
951 | 0 -> Rgb
952 | 1 -> Bgr
953 | 2 -> Gray
954 | n -> failwith ("invalid colorspace index " ^ string_of_int n)
957 let colorspace_to_string = function
958 | Rgb -> "rgb"
959 | Bgr -> "bgr"
960 | Gray -> "gray"
963 let intentry_with_suffix text key =
964 let c =
965 if key >= 32 && key < 127
966 then Char.chr key
967 else '\000'
969 match Char.lowercase c with
970 | '0' .. '9' ->
971 let text = addchar text c in
972 TEcont text
974 | 'k' | 'm' | 'g' ->
975 let text = addchar text c in
976 TEcont text
978 | _ ->
979 state.text <- Printf.sprintf "invalid char (%d, `%c')" key c;
980 TEcont text
983 let multicolumns_to_string (n, a, b) =
984 if a = 0 && b = 0
985 then Printf.sprintf "%d" n
986 else Printf.sprintf "%d,%d,%d" n a b;
989 let multicolumns_of_string s =
991 (int_of_string s, 0, 0)
992 with _ ->
993 Scanf.sscanf s "%u,%u,%u" (fun n a b ->
994 if a > 1 || b > 1
995 then failwith "subtly broken"; (n, a, b)
999 let readcmd fd =
1000 let s = "xxxx" in
1001 let n = tempfailureretry (Unix.read fd s 0) 4 in
1002 if n != 4 then failwith "incomplete read(len)";
1003 let len = 0
1004 lor (Char.code s.[0] lsl 24)
1005 lor (Char.code s.[1] lsl 16)
1006 lor (Char.code s.[2] lsl 8)
1007 lor (Char.code s.[3] lsl 0)
1009 let s = String.create len in
1010 let n = tempfailureretry (Unix.read fd s 0) len in
1011 if n != len then failwith "incomplete read(data)";
1015 let btod b = if b then 1 else 0;;
1017 let wcmd fmt =
1018 let b = Buffer.create 16 in
1019 Buffer.add_string b "llll";
1020 Printf.kbprintf
1021 (fun b ->
1022 let s = Buffer.contents b in
1023 let n = String.length s in
1024 let len = n - 4 in
1025 (* dolog "wcmd %S" (String.sub s 4 len); *)
1026 s.[0] <- Char.chr ((len lsr 24) land 0xff);
1027 s.[1] <- Char.chr ((len lsr 16) land 0xff);
1028 s.[2] <- Char.chr ((len lsr 8) land 0xff);
1029 s.[3] <- Char.chr (len land 0xff);
1030 let n' = tempfailureretry (Unix.write state.sw s 0) n in
1031 if n' != n then failwith "write failed";
1032 ) b fmt;
1035 let calcips h =
1036 let d = conf.winh - h in
1037 max conf.interpagespace ((d + 1) / 2)
1040 let rowyh (c, coverA, coverB) b n =
1041 if c = 1 || (n < coverA || n >= state.pagecount - coverB)
1042 then
1043 let _, _, vy, (_, _, h, _) = b.(n) in
1044 (vy, h)
1045 else
1046 let n' = n - coverA in
1047 let d = n' mod c in
1048 let s = n - d in
1049 let e = min state.pagecount (s + c) in
1050 let rec find m miny maxh = if m = e then miny, maxh else
1051 let _, _, y, (_, _, h, _) = b.(m) in
1052 let miny = min miny y in
1053 let maxh = max maxh h in
1054 find (m+1) miny maxh
1055 in find s max_int 0
1058 let calcheight () =
1059 match conf.columns with
1060 | Cmulti ((_, _, _) as cl, b) ->
1061 if Array.length b > 0
1062 then
1063 let y, h = rowyh cl b (Array.length b - 1) in
1064 y + h + (if conf.presentation then calcips h else 0)
1065 else 0
1066 | Csingle b ->
1067 if Array.length b > 0
1068 then
1069 let (_, _, y, (_, _, h, _)) = b.(Array.length b - 1) in
1070 y + h + (if conf.presentation then calcips h else 0)
1071 else 0
1072 | Csplit (_, b) ->
1073 if Array.length b > 0
1074 then
1075 let (_, _, y, (_, _, h, _)) = b.(Array.length b - 1) in
1076 y + h
1077 else 0
1080 let getpageyh pageno =
1081 let pageno = bound pageno 0 (state.pagecount-1) in
1082 match conf.columns with
1083 | Csingle b ->
1084 if Array.length b = 0
1085 then 0, 0
1086 else
1087 let (_, _, y, (_, _, h, _)) = b.(pageno) in
1088 let y =
1089 if conf.presentation
1090 then y - calcips h
1091 else y
1093 y, h
1094 | Cmulti (cl, b) ->
1095 if Array.length b = 0
1096 then 0, 0
1097 else
1098 let y, h = rowyh cl b pageno in
1099 let y =
1100 if conf.presentation
1101 then y - calcips h
1102 else y
1104 y, h
1105 | Csplit (c, b) ->
1106 if Array.length b = 0
1107 then 0, 0
1108 else
1109 let n = pageno*c in
1110 let (_, _, y, (_, _, h, _)) = b.(n) in
1111 y, h
1114 let getpagedim pageno =
1115 let rec f ppdim l =
1116 match l with
1117 | (n, _, _, _) as pdim :: rest ->
1118 if n >= pageno
1119 then (if n = pageno then pdim else ppdim)
1120 else f pdim rest
1122 | [] -> ppdim
1124 f (-1, -1, -1, -1) state.pdims
1127 let getpagey pageno = fst (getpageyh pageno);;
1129 let nogeomcmds cmds =
1130 match cmds with
1131 | s, [] -> String.length s = 0
1132 | _ -> false
1135 let page_of_y y =
1136 let ((c, coverA, coverB) as cl), b =
1137 match conf.columns with
1138 | Csingle b -> (1, 0, 0), b
1139 | Cmulti (c, b) -> c, b
1140 | Csplit (_, b) -> (1, 0, 0), b
1142 let rec bsearch nmin nmax =
1143 if nmin > nmax
1144 then bound nmin 0 (state.pagecount-1)
1145 else
1146 let n = (nmax + nmin) / 2 in
1147 let vy, h = rowyh cl b n in
1148 let y0, y1 =
1149 if conf.presentation
1150 then
1151 let ips = calcips h in
1152 let y0 = vy - ips in
1153 let y1 = vy + h + ips in
1154 y0, y1
1155 else (
1156 if n = 0
1157 then 0, vy + h + conf.interpagespace
1158 else
1159 let y0 = vy - conf.interpagespace in
1160 y0, y0 + h + conf.interpagespace
1163 if y >= y0 && y < y1
1164 then (
1165 if c = 1
1166 then n
1167 else (
1168 if n > coverA
1169 then
1170 if n < state.pagecount - coverB
1171 then ((n-coverA)/c)*c + coverA
1172 else n
1173 else n
1176 else (
1177 if y > y0
1178 then bsearch (n+1) nmax
1179 else bsearch nmin (n-1)
1182 let r = bsearch 0 (state.pagecount-1) in
1186 let layoutN ((columns, coverA, coverB), b) y sh =
1187 let sh = sh - state.hscrollh in
1188 let rec fold accu n =
1189 if n = Array.length b
1190 then accu
1191 else
1192 let pdimno, dx, vy, (_, w, h, xoff) = b.(n) in
1193 if (vy - y) > sh &&
1194 (n = coverA - 1
1195 || n = state.pagecount - coverB
1196 || (n - coverA) mod columns = columns - 1)
1197 then accu
1198 else
1199 let accu =
1200 if vy + h > y
1201 then
1202 let pagey = max 0 (y - vy) in
1203 let pagedispy = if pagey > 0 then 0 else vy - y in
1204 let pagedispx, pagex =
1205 let pdx =
1206 if n = coverA - 1 || n = state.pagecount - coverB
1207 then state.x + (conf.winw - state.scrollw - w) / 2
1208 else dx + xoff + state.x
1210 if pdx < 0
1211 then 0, -pdx
1212 else pdx, 0
1214 let pagevw =
1215 let vw = conf.winw - state.scrollw - pagedispx in
1216 let pw = w - pagex in
1217 min vw pw
1219 let pagevh = min (h - pagey) (sh - pagedispy) in
1220 if pagevw > 0 && pagevh > 0
1221 then
1222 let e =
1223 { pageno = n
1224 ; pagedimno = pdimno
1225 ; pagew = w
1226 ; pageh = h
1227 ; pagex = pagex
1228 ; pagey = pagey
1229 ; pagevw = pagevw
1230 ; pagevh = pagevh
1231 ; pagedispx = pagedispx
1232 ; pagedispy = pagedispy
1233 ; pagecol = 0
1236 e :: accu
1237 else
1238 accu
1239 else
1240 accu
1242 fold accu (n+1)
1244 List.rev (fold [] (page_of_y y));
1247 let layoutS (columns, b) y sh =
1248 let sh = sh - state.hscrollh in
1249 let rec fold accu n =
1250 if n = Array.length b
1251 then accu
1252 else
1253 let pdimno, px, vy, (_, pagew, pageh, xoff) = b.(n) in
1254 if (vy - y) > sh
1255 then accu
1256 else
1257 let accu =
1258 if vy + pageh > y
1259 then
1260 let x = xoff + state.x in
1261 let pagey = max 0 (y - vy) in
1262 let pagedispy = if pagey > 0 then 0 else vy - y in
1263 let pagedispx, pagex =
1264 if px = 0
1265 then (
1266 if x < 0
1267 then 0, -x
1268 else x, 0
1270 else (
1271 let px = px - x in
1272 if px < 0
1273 then -px, 0
1274 else 0, px
1277 let pagecolw = pagew/columns in
1278 let pagedispx =
1279 if pagecolw < conf.winw
1280 then pagedispx + ((conf.winw - state.scrollw - pagecolw) / 2)
1281 else pagedispx
1283 let pagevw =
1284 let vw = conf.winw - pagedispx - state.scrollw in
1285 let pw = pagew - pagex in
1286 min vw pw
1288 let pagevw = min pagevw pagecolw in
1289 let pagevh = min (pageh - pagey) (sh - pagedispy) in
1290 if pagevw > 0 && pagevh > 0
1291 then
1292 let e =
1293 { pageno = n/columns
1294 ; pagedimno = pdimno
1295 ; pagew = pagew
1296 ; pageh = pageh
1297 ; pagex = pagex
1298 ; pagey = pagey
1299 ; pagevw = pagevw
1300 ; pagevh = pagevh
1301 ; pagedispx = pagedispx
1302 ; pagedispy = pagedispy
1303 ; pagecol = n mod columns
1306 e :: accu
1307 else
1308 accu
1309 else
1310 accu
1312 fold accu (n+1)
1314 List.rev (fold [] 0)
1317 let layout y sh =
1318 if nogeomcmds state.geomcmds
1319 then
1320 match conf.columns with
1321 | Csingle b -> layoutN ((1, 0, 0), b) y sh
1322 | Cmulti c -> layoutN c y sh
1323 | Csplit s -> layoutS s y sh
1324 else []
1327 let clamp incr =
1328 let y = state.y + incr in
1329 let y = max 0 y in
1330 let y = min y (state.maxy - (if conf.maxhfit then conf.winh else 0)) in
1334 let itertiles l f =
1335 let tilex = l.pagex mod conf.tilew in
1336 let tiley = l.pagey mod conf.tileh in
1338 let col = l.pagex / conf.tilew in
1339 let row = l.pagey / conf.tileh in
1341 let rec rowloop row y0 dispy h =
1342 if h = 0
1343 then ()
1344 else (
1345 let dh = conf.tileh - y0 in
1346 let dh = min h dh in
1347 let rec colloop col x0 dispx w =
1348 if w = 0
1349 then ()
1350 else (
1351 let dw = conf.tilew - x0 in
1352 let dw = min w dw in
1354 f col row dispx dispy x0 y0 dw dh;
1355 colloop (col+1) 0 (dispx+dw) (w-dw)
1358 colloop col tilex l.pagedispx l.pagevw;
1359 rowloop (row+1) 0 (dispy+dh) (h-dh)
1362 if l.pagevw > 0 && l.pagevh > 0
1363 then rowloop row tiley l.pagedispy l.pagevh;
1366 let gettileopaque l col row =
1367 let key =
1368 l.pageno, state.gen, conf.colorspace, conf.angle, l.pagew, l.pageh, col, row
1370 try Some (Hashtbl.find state.tilemap key)
1371 with Not_found -> None
1374 let puttileopaque l col row gen colorspace angle opaque size elapsed =
1375 let key = l.pageno, gen, colorspace, angle, l.pagew, l.pageh, col, row in
1376 Hashtbl.add state.tilemap key (opaque, size, elapsed)
1379 let drawtiles l color =
1380 GlDraw.color color;
1381 let f col row x y tilex tiley w h =
1382 match gettileopaque l col row with
1383 | Some (opaque, _, t) ->
1384 let params = x, y, w, h, tilex, tiley in
1385 if conf.invert
1386 then (
1387 Gl.enable `blend;
1388 GlFunc.blend_func `zero `one_minus_src_color;
1390 drawtile params opaque;
1391 if conf.invert
1392 then Gl.disable `blend;
1393 if conf.debug
1394 then (
1395 let s = Printf.sprintf
1396 "%d[%d,%d] %f sec"
1397 l.pageno col row t
1399 let w = measurestr fstate.fontsize s in
1400 GlMisc.push_attrib [`current];
1401 GlDraw.color (0.0, 0.0, 0.0);
1402 GlDraw.rect
1403 (float (x-2), float (y-2))
1404 (float (x+2) +. w, float (y + fstate.fontsize + 2));
1405 GlDraw.color (1.0, 1.0, 1.0);
1406 drawstring fstate.fontsize x (y + fstate.fontsize - 1) s;
1407 GlMisc.pop_attrib ();
1410 | _ ->
1411 let w =
1412 let lw = conf.winw - state.scrollw - x in
1413 min lw w
1414 and h =
1415 let lh = conf.winh - y in
1416 min lh h
1418 begin match state.texid with
1419 | Some id ->
1420 Gl.enable `texture_2d;
1421 GlTex.bind_texture `texture_2d id;
1422 let x0 = float x
1423 and y0 = float y
1424 and x1 = float (x+w)
1425 and y1 = float (y+h) in
1427 let tw = float w /. 16.0
1428 and th = float h /. 16.0 in
1429 let tx0 = float tilex /. 16.0
1430 and ty0 = float tiley /. 16.0 in
1431 let tx1 = tx0 +. tw
1432 and ty1 = ty0 +. th in
1433 GlDraw.begins `quads;
1434 GlTex.coord2 (tx0, ty0); GlDraw.vertex2 (x0, y0);
1435 GlTex.coord2 (tx0, ty1); GlDraw.vertex2 (x0, y1);
1436 GlTex.coord2 (tx1, ty1); GlDraw.vertex2 (x1, y1);
1437 GlTex.coord2 (tx1, ty0); GlDraw.vertex2 (x1, y0);
1438 GlDraw.ends ();
1440 Gl.disable `texture_2d;
1441 | None ->
1442 GlDraw.color (1.0, 1.0, 1.0);
1443 GlDraw.rect
1444 (float x, float y)
1445 (float (x+w), float (y+h));
1446 end;
1447 if w > 128 && h > fstate.fontsize + 10
1448 then (
1449 GlDraw.color (0.0, 0.0, 0.0);
1450 let c, r =
1451 if conf.verbose
1452 then (col*conf.tilew, row*conf.tileh)
1453 else col, row
1455 drawstring2 fstate.fontsize x y "Loading %d [%d,%d]" l.pageno c r;
1457 GlDraw.color color;
1459 itertiles l f
1462 let pagevisible layout n = List.exists (fun l -> l.pageno = n) layout;;
1464 let tilevisible1 l x y =
1465 let ax0 = l.pagex
1466 and ax1 = l.pagex + l.pagevw
1467 and ay0 = l.pagey
1468 and ay1 = l.pagey + l.pagevh in
1470 let bx0 = x
1471 and by0 = y in
1472 let bx1 = min (bx0 + conf.tilew) l.pagew
1473 and by1 = min (by0 + conf.tileh) l.pageh in
1475 let rx0 = max ax0 bx0
1476 and ry0 = max ay0 by0
1477 and rx1 = min ax1 bx1
1478 and ry1 = min ay1 by1 in
1480 let nonemptyintersection = rx1 > rx0 && ry1 > ry0 in
1481 nonemptyintersection
1484 let tilevisible layout n x y =
1485 let rec findpageinlayout m = function
1486 | l :: rest when l.pageno = n ->
1487 tilevisible1 l x y || (
1488 match conf.columns with
1489 | Csplit (c, _) when c > m -> findpageinlayout (m+1) rest
1490 | _ -> false
1492 | _ :: rest -> findpageinlayout 0 rest
1493 | [] -> false
1495 findpageinlayout 0 layout;
1498 let tileready l x y =
1499 tilevisible1 l x y &&
1500 gettileopaque l (x/conf.tilew) (y/conf.tileh) != None
1503 let tilepage n p layout =
1504 let rec loop = function
1505 | l :: rest ->
1506 if l.pageno = n
1507 then
1508 let f col row _ _ _ _ _ _ =
1509 if state.currently = Idle
1510 then
1511 match gettileopaque l col row with
1512 | Some _ -> ()
1513 | None ->
1514 let x = col*conf.tilew
1515 and y = row*conf.tileh in
1516 let w =
1517 let w = l.pagew - x in
1518 min w conf.tilew
1520 let h =
1521 let h = l.pageh - y in
1522 min h conf.tileh
1524 let pbo =
1525 if conf.usepbo
1526 then getpbo w h conf.colorspace
1527 else "0"
1529 wcmd "tile %s %d %d %d %d %s" p x y w h pbo;
1530 state.currently <-
1531 Tiling (
1532 l, p, conf.colorspace, conf.angle, state.gen, col, row,
1533 conf.tilew, conf.tileh
1536 itertiles l f;
1537 else
1538 loop rest
1540 | [] -> ()
1542 if nogeomcmds state.geomcmds
1543 then loop layout;
1546 let preloadlayout y =
1547 let y = if y < conf.winh then 0 else y - conf.winh in
1548 let h = conf.winh*3 in
1549 layout y h;
1552 let load pages =
1553 let rec loop pages =
1554 if state.currently != Idle
1555 then ()
1556 else
1557 match pages with
1558 | l :: rest ->
1559 begin match getopaque l.pageno with
1560 | None ->
1561 wcmd "page %d %d" l.pageno l.pagedimno;
1562 state.currently <- Loading (l, state.gen);
1563 | Some opaque ->
1564 tilepage l.pageno opaque pages;
1565 loop rest
1566 end;
1567 | _ -> ()
1569 if nogeomcmds state.geomcmds
1570 then loop pages
1573 let preload pages =
1574 load pages;
1575 if conf.preload && state.currently = Idle
1576 then load (preloadlayout state.y);
1579 let layoutready layout =
1580 let rec fold all ls =
1581 all && match ls with
1582 | l :: rest ->
1583 let seen = ref false in
1584 let allvisible = ref true in
1585 let foo col row _ _ _ _ _ _ =
1586 seen := true;
1587 allvisible := !allvisible &&
1588 begin match gettileopaque l col row with
1589 | Some _ -> true
1590 | None -> false
1593 itertiles l foo;
1594 fold (!seen && !allvisible) rest
1595 | [] -> true
1597 let alltilesvisible = fold true layout in
1598 alltilesvisible;
1601 let gotoy y =
1602 state.wthack <- false;
1603 let y = bound y 0 state.maxy in
1604 let y, layout, proceed =
1605 match conf.maxwait with
1606 | Some time when state.ghyll == noghyll ->
1607 begin match state.throttle with
1608 | None ->
1609 let layout = layout y conf.winh in
1610 let ready = layoutready layout in
1611 if not ready
1612 then (
1613 load layout;
1614 state.throttle <- Some (layout, y, now ());
1616 else G.postRedisplay "gotoy showall (None)";
1617 y, layout, ready
1618 | Some (_, _, started) ->
1619 let dt = now () -. started in
1620 if dt > time
1621 then (
1622 state.throttle <- None;
1623 let layout = layout y conf.winh in
1624 load layout;
1625 G.postRedisplay "maxwait";
1626 y, layout, true
1628 else -1, [], false
1631 | _ ->
1632 let layout = layout y conf.winh in
1633 G.postRedisplay "gotoy ready";
1634 y, layout, true
1636 if proceed
1637 then (
1638 state.y <- y;
1639 state.layout <- layout;
1640 begin match state.mode with
1641 | LinkNav (Ltexact (pageno, linkno)) ->
1642 let rec loop = function
1643 | [] ->
1644 state.mode <- LinkNav (Ltgendir 0)
1645 | l :: _ when l.pageno = pageno ->
1646 begin match getopaque pageno with
1647 | None ->
1648 state.mode <- LinkNav (Ltgendir 0)
1649 | Some opaque ->
1650 let x0, y0, x1, y1 = getlinkrect opaque linkno in
1651 if not (x0 >= l.pagex && x1 <= l.pagex + l.pagevw
1652 && y0 >= l.pagey && y1 <= l.pagey + l.pagevh)
1653 then state.mode <- LinkNav (Ltgendir 0)
1655 | _ :: rest -> loop rest
1657 loop layout
1658 | _ -> ()
1659 end;
1660 begin match state.mode with
1661 | Birdseye (conf, leftx, pageno, hooverpageno, anchor) ->
1662 if not (pagevisible layout pageno)
1663 then (
1664 match state.layout with
1665 | [] -> ()
1666 | l :: _ ->
1667 state.mode <- Birdseye (
1668 conf, leftx, l.pageno, hooverpageno, anchor
1671 | LinkNav (Ltgendir dir as lt) ->
1672 let linknav =
1673 let rec loop = function
1674 | [] -> lt
1675 | l :: rest ->
1676 match getopaque l.pageno with
1677 | None -> loop rest
1678 | Some opaque ->
1679 let link =
1680 let ld =
1681 if dir = 0
1682 then LDfirstvisible (l.pagex, l.pagey, dir)
1683 else (
1684 if dir > 0 then LDfirst else LDlast
1687 findlink opaque ld
1689 match link with
1690 | Lnotfound -> loop rest
1691 | Lfound n ->
1692 showlinktype (getlink opaque n);
1693 Ltexact (l.pageno, n)
1695 loop state.layout
1697 state.mode <- LinkNav linknav
1698 | _ -> ()
1699 end;
1700 preload layout;
1702 state.ghyll <- noghyll;
1703 if conf.updatecurs
1704 then (
1705 let mx, my = state.mpos in
1706 updateunder mx my;
1710 let conttiling pageno opaque =
1711 tilepage pageno opaque
1712 (if conf.preload then preloadlayout state.y else state.layout)
1715 let gotoy_and_clear_text y =
1716 if not conf.verbose then state.text <- "";
1717 gotoy y;
1720 let getanchor1 l =
1721 let top =
1722 let coloff = l.pagecol * l.pageh in
1723 float (l.pagey + coloff) /. float l.pageh
1725 let dtop =
1726 if l.pagedispy = 0
1727 then
1729 else
1730 if conf.presentation
1731 then float l.pagedispy /. float (calcips l.pageh)
1732 else float l.pagedispy /. float conf.interpagespace
1734 (l.pageno, top, dtop)
1737 let getanchor () =
1738 match state.layout with
1739 | l :: _ -> getanchor1 l
1740 | [] ->
1741 let n = page_of_y state.y in
1742 let y, h = getpageyh n in
1743 let dy = y - state.y in
1744 let dtop =
1745 if conf.presentation
1746 then
1747 let ips = calcips h in
1748 float (dy + ips) /. float ips
1749 else
1750 float dy /. float conf.interpagespace
1752 (n, 0.0, dtop)
1755 let getanchory (n, top, dtop) =
1756 let y, h = getpageyh n in
1757 if conf.presentation
1758 then
1759 let ips = calcips h in
1760 y + truncate (top*.float h -. dtop*.float ips) + ips;
1761 else
1762 y + truncate (top*.float h -. dtop*.float conf.interpagespace)
1765 let gotoanchor anchor =
1766 gotoy (getanchory anchor);
1769 let addnav () =
1770 cbput state.hists.nav (getanchor ());
1773 let getnav dir =
1774 let anchor = cbgetc state.hists.nav dir in
1775 getanchory anchor;
1778 let gotoghyll y =
1779 let scroll f n a b =
1780 (* http://devmaster.net/forums/topic/9796-ease-in-ease-out-algorithm/ *)
1781 let snake f a b =
1782 let s x = 3.0*.x**2.0 -. 2.0*.x**3.0 in
1783 if f < a
1784 then s (float f /. float a)
1785 else (
1786 if f > b
1787 then 1.0 -. s ((float (f-b) /. float (n-b)))
1788 else 1.0
1791 snake f a b
1792 and summa f n a b =
1793 (* courtesy:
1794 http://integrals.wolfram.com/index.jsp?expr=3x%5E2-2x%5E3&random=false *)
1795 let iv x = -.((-.2.0 +. x)*.x**3.0)/.2.0 in
1796 let iv1 = iv f in
1797 let ins = float a *. iv1
1798 and outs = float (n-b) *. iv1 in
1799 let ones = b - a in
1800 ins +. outs +. float ones
1802 let rec set (_N, _A, _B) y sy =
1803 let sum = summa 1.0 _N _A _B in
1804 let dy = float (y - sy) in
1805 state.ghyll <- (
1806 let rec gf n y1 o =
1807 if n >= _N
1808 then state.ghyll <- noghyll
1809 else
1810 let go n =
1811 let s = scroll n _N _A _B in
1812 let y1 = y1 +. ((s *. dy) /. sum) in
1813 gotoy_and_clear_text (truncate y1);
1814 state.ghyll <- gf (n+1) y1;
1816 match o with
1817 | None -> go n
1818 | Some y' -> set (_N/2, 1, 1) y' state.y
1820 gf 0 (float state.y)
1823 match conf.ghyllscroll with
1824 | None ->
1825 gotoy_and_clear_text y
1826 | Some nab ->
1827 if state.ghyll == noghyll
1828 then set nab y state.y
1829 else state.ghyll (Some y)
1832 let gotopage n top =
1833 let y, h = getpageyh n in
1834 let y = y + (truncate (top *. float h)) in
1835 gotoghyll y
1838 let gotopage1 n top =
1839 let y = getpagey n in
1840 let y = y + top in
1841 gotoghyll y
1844 let invalidate s f =
1845 state.layout <- [];
1846 state.pdims <- [];
1847 state.rects <- [];
1848 state.rects1 <- [];
1849 match state.geomcmds with
1850 | ps, [] when String.length ps = 0 ->
1851 f ();
1852 state.geomcmds <- s, [];
1854 | ps, [] ->
1855 state.geomcmds <- ps, [s, f];
1857 | ps, (s', _) :: rest when s' = s ->
1858 state.geomcmds <- ps, ((s, f) :: rest);
1860 | ps, cmds ->
1861 state.geomcmds <- ps, ((s, f) :: cmds);
1864 let flushpages () =
1865 Hashtbl.iter (fun _ opaque ->
1866 wcmd "freepage %s" opaque;
1867 ) state.pagemap;
1868 Hashtbl.clear state.pagemap;
1871 let opendoc path password =
1872 state.path <- path;
1873 state.password <- password;
1874 state.gen <- state.gen + 1;
1875 state.docinfo <- [];
1877 flushpages ();
1878 setaalevel conf.aalevel;
1879 Wsi.settitle ("llpp " ^ (mbtoutf8 (Filename.basename path)));
1880 wcmd "open %d %s\000%s\000" (btod state.wthack) path password;
1881 invalidate "reqlayout"
1882 (fun () ->
1883 wcmd "reqlayout %d %d %s\000"
1884 conf.angle (btod conf.proportional) state.nameddest;
1888 let reload () =
1889 state.anchor <- getanchor ();
1890 state.wthack <- !wtmode;
1891 opendoc state.path state.password;
1894 let scalecolor c =
1895 let c = c *. conf.colorscale in
1896 (c, c, c);
1899 let scalecolor2 (r, g, b) =
1900 (r *. conf.colorscale, g *. conf.colorscale, b *. conf.colorscale);
1903 let docolumns = function
1904 | Csingle _ ->
1905 let a = Array.make state.pagecount (-1, -1, -1, (-1, -1, -1, -1)) in
1906 let rec loop pageno pdimno pdim y ph pdims =
1907 if pageno = state.pagecount
1908 then ()
1909 else
1910 let pdimno, ((_, w, h, xoff) as pdim), pdims =
1911 match pdims with
1912 | ((pageno', _, _, _) as pdim) :: rest when pageno' = pageno ->
1913 pdimno+1, pdim, rest
1914 | _ ->
1915 pdimno, pdim, pdims
1917 let x = max 0 (((conf.winw - state.scrollw - w) / 2) - xoff) in
1918 let y = y +
1919 (if conf.presentation
1920 then (if pageno = 0 then calcips h else calcips ph + calcips h)
1921 else (if pageno = 0 then 0 else conf.interpagespace)
1924 a.(pageno) <- (pdimno, x, y, pdim);
1925 loop (pageno+1) pdimno pdim (y + h) h pdims
1927 loop 0 ~-1 (-1,-1,-1,-1) 0 0 state.pdims;
1928 conf.columns <- Csingle a;
1930 | Cmulti ((columns, coverA, coverB), _) ->
1931 let a = Array.make state.pagecount (-1, -1, -1, (-1, -1, -1, -1)) in
1932 let rec loop pageno pdimno pdim x y rowh pdims =
1933 let rec fixrow m = if m = pageno then () else
1934 let (pdimno, x, y, ((_, _, h, _) as pdim)) = a.(m) in
1935 if h < rowh
1936 then (
1937 let y = y + (rowh - h) / 2 in
1938 a.(m) <- (pdimno, x, y, pdim);
1940 fixrow (m+1)
1942 if pageno = state.pagecount
1943 then fixrow (((pageno - 1) / columns) * columns)
1944 else
1945 let pdimno, ((_, w, h, xoff) as pdim), pdims =
1946 match pdims with
1947 | ((pageno', _, _, _) as pdim) :: rest when pageno' = pageno ->
1948 pdimno+1, pdim, rest
1949 | _ ->
1950 pdimno, pdim, pdims
1952 let x, y, rowh' =
1953 if pageno = coverA - 1 || pageno = state.pagecount - coverB
1954 then (
1955 let x = (conf.winw - state.scrollw - w) / 2 in
1956 let ips =
1957 if conf.presentation then calcips h else conf.interpagespace in
1958 x, y + ips + rowh, h
1960 else (
1961 if (pageno - coverA) mod columns = 0
1962 then (
1963 let x = max 0 (conf.winw - state.scrollw - state.w) / 2 in
1964 let y =
1965 if conf.presentation
1966 then
1967 let ips = calcips h in
1968 y + (if pageno = 0 then 0 else calcips rowh + ips)
1969 else
1970 y + (if pageno = 0 then 0 else conf.interpagespace)
1972 x, y + rowh, h
1974 else x, y, max rowh h
1977 let y =
1978 if pageno > 1 && (pageno - coverA) mod columns = 0
1979 then (
1980 let y =
1981 if pageno = columns && conf.presentation
1982 then (
1983 let ips = calcips rowh in
1984 for i = 0 to pred columns
1986 let (pdimno, x, y, pdim) = a.(i) in
1987 a.(i) <- (pdimno, x, y+ips, pdim)
1988 done;
1989 y+ips;
1991 else y
1993 fixrow (pageno - columns);
1996 else y
1998 a.(pageno) <- (pdimno, x, y, pdim);
1999 let x = x + w + xoff*2 + conf.interpagespace in
2000 loop (pageno+1) pdimno pdim x y rowh' pdims
2002 loop 0 ~-1 (-1,-1,-1,-1) 0 0 0 state.pdims;
2003 conf.columns <- Cmulti ((columns, coverA, coverB), a);
2005 | Csplit (c, _) ->
2006 let a = Array.make (state.pagecount*c) (-1, -1, -1, (-1, -1, -1, -1)) in
2007 let rec loop pageno pdimno pdim y pdims =
2008 if pageno = state.pagecount
2009 then ()
2010 else
2011 let pdimno, ((_, w, h, _) as pdim), pdims =
2012 match pdims with
2013 | ((pageno', _, _, _) as pdim) :: rest when pageno' = pageno ->
2014 pdimno+1, pdim, rest
2015 | _ ->
2016 pdimno, pdim, pdims
2018 let cw = w / c in
2019 let rec loop1 n x y =
2020 if n = c then y else (
2021 a.(pageno*c + n) <- (pdimno, x, y, pdim);
2022 loop1 (n+1) (x+cw) (y + h + conf.interpagespace)
2025 let y = loop1 0 0 y in
2026 loop (pageno+1) pdimno pdim y pdims
2028 loop 0 ~-1 (-1,-1,-1,-1) 0 state.pdims;
2029 conf.columns <- Csplit (c, a);
2032 let represent () =
2033 docolumns conf.columns;
2034 state.maxy <- calcheight ();
2035 state.hscrollh <-
2036 if state.w <= conf.winw - state.scrollw
2037 then 0
2038 else state.scrollw
2040 let wthack = state.wthack in
2041 begin match state.mode with
2042 | Birdseye (_, _, pageno, _, _) ->
2043 let y, h = getpageyh pageno in
2044 let top = (conf.winh - h) / 2 in
2045 gotoy (max 0 (y - top))
2046 | _ -> gotoanchor state.anchor
2047 end;
2048 state.wthack <- wthack;
2051 let reshape w h =
2052 state.wthack <- false;
2053 GlDraw.viewport 0 0 w h;
2054 let firsttime = state.geomcmds == firstgeomcmds in
2055 if not firsttime && nogeomcmds state.geomcmds
2056 then state.anchor <- getanchor ();
2058 conf.winw <- w;
2059 let w = truncate (float w *. conf.zoom) - state.scrollw in
2060 let w = max w 2 in
2061 conf.winh <- h;
2062 setfontsize fstate.fontsize;
2063 GlMat.mode `modelview;
2064 GlMat.load_identity ();
2066 GlMat.mode `projection;
2067 GlMat.load_identity ();
2068 GlMat.rotate ~x:1.0 ~angle:180.0 ();
2069 GlMat.translate ~x:~-.1.0 ~y:~-.1.0 ();
2070 GlMat.scale3 (2.0 /. float conf.winw, 2.0 /. float conf.winh, 1.0);
2072 let relx =
2073 if conf.zoom <= 1.0
2074 then 0.0
2075 else float state.x /. float state.w
2077 invalidate "geometry"
2078 (fun () ->
2079 state.w <- w;
2080 if not firsttime
2081 then state.x <- truncate (relx *. float w);
2082 let w =
2083 match conf.columns with
2084 | Csingle _ -> w
2085 | Cmulti ((c, _, _), _) -> (w - (c-1)*conf.interpagespace) / c
2086 | Csplit (c, _) -> w * c
2088 wcmd "geometry %d %d" w h);
2091 let enttext () =
2092 let len = String.length state.text in
2093 let drawstring s =
2094 let hscrollh =
2095 match state.mode with
2096 | Textentry _
2097 | View ->
2098 let h, _, _ = state.uioh#scrollpw in
2100 | _ -> 0
2102 let rect x w =
2103 GlDraw.rect
2104 (x, float (conf.winh - (fstate.fontsize + 4) - hscrollh))
2105 (x+.w, float (conf.winh - hscrollh))
2108 let w = float (conf.winw - state.scrollw - 1) in
2109 if state.progress >= 0.0 && state.progress < 1.0
2110 then (
2111 GlDraw.color (0.3, 0.3, 0.3);
2112 let w1 = w *. state.progress in
2113 rect 0.0 w1;
2114 GlDraw.color (0.0, 0.0, 0.0);
2115 rect w1 (w-.w1)
2117 else (
2118 GlDraw.color (0.0, 0.0, 0.0);
2119 rect 0.0 w;
2122 GlDraw.color (1.0, 1.0, 1.0);
2123 drawstring fstate.fontsize
2124 (if len > 0 then 8 else 2) (conf.winh - hscrollh - 5) s;
2126 let s =
2127 match state.mode with
2128 | Textentry ((prefix, text, _, _, _, _), _) ->
2129 let s =
2130 if len > 0
2131 then
2132 Printf.sprintf "%s%s_ [%s]" prefix text state.text
2133 else
2134 Printf.sprintf "%s%s_" prefix text
2138 | _ -> state.text
2140 let s =
2141 if state.newerrmsgs
2142 then (
2143 if not (istextentry state.mode)
2144 then
2145 let s1 = "(press 'e' to review error messasges)" in
2146 if String.length s > 0 then s ^ " " ^ s1 else s1
2147 else s
2149 else s
2151 if String.length s > 0
2152 then drawstring s
2155 let gctiles () =
2156 let len = Queue.length state.tilelru in
2157 let layout = lazy (
2158 match state.throttle with
2159 | None ->
2160 if conf.preload
2161 then preloadlayout state.y
2162 else state.layout
2163 | Some (layout, _, _) ->
2164 layout
2165 ) in
2166 let rec loop qpos =
2167 if state.memused <= conf.memlimit
2168 then ()
2169 else (
2170 if qpos < len
2171 then
2172 let (k, p, s) as lruitem = Queue.pop state.tilelru in
2173 let n, gen, colorspace, angle, pagew, pageh, col, row = k in
2174 let (_, pw, ph, _) = getpagedim n in
2176 gen = state.gen
2177 && colorspace = conf.colorspace
2178 && angle = conf.angle
2179 && pagew = pw
2180 && pageh = ph
2181 && (
2182 let x = col*conf.tilew
2183 and y = row*conf.tileh in
2184 tilevisible (Lazy.force_val layout) n x y
2186 then Queue.push lruitem state.tilelru
2187 else (
2188 freepbo p;
2189 wcmd "freetile %s" p;
2190 state.memused <- state.memused - s;
2191 state.uioh#infochanged Memused;
2192 Hashtbl.remove state.tilemap k;
2194 loop (qpos+1)
2197 loop 0
2200 let flushtiles () =
2201 Queue.iter (fun (k, p, s) ->
2202 wcmd "freetile %s" p;
2203 state.memused <- state.memused - s;
2204 state.uioh#infochanged Memused;
2205 Hashtbl.remove state.tilemap k;
2206 ) state.tilelru;
2207 Queue.clear state.tilelru;
2208 load state.layout;
2211 let logcurrently = function
2212 | Idle -> dolog "Idle"
2213 | Loading (l, gen) ->
2214 dolog "Loading %d gen=%d curgen=%d" l.pageno gen state.gen
2215 | Tiling (l, pageopaque, colorspace, angle, gen, col, row, tilew, tileh) ->
2216 dolog
2217 "Tiling %d[%d,%d] page=%s cs=%s angle"
2218 l.pageno col row pageopaque
2219 (colorspace_to_string colorspace)
2221 dolog "gen=(%d,%d) (%d,%d) tile=(%d,%d) (%d,%d)"
2222 angle gen conf.angle state.gen
2223 tilew tileh
2224 conf.tilew conf.tileh
2226 | Outlining _ ->
2227 dolog "outlining"
2230 let act cmds =
2231 (* dolog "%S" cmds; *)
2232 let op, args =
2233 let spacepos =
2234 try String.index cmds ' '
2235 with Not_found -> -1
2237 if spacepos = -1
2238 then cmds, ""
2239 else
2240 let l = String.length cmds in
2241 let op = String.sub cmds 0 spacepos in
2242 op, begin
2243 if l - spacepos < 2 then ""
2244 else String.sub cmds (spacepos+1) (l-spacepos-1)
2247 match op with
2248 | "clear" ->
2249 state.uioh#infochanged Pdim;
2250 state.pdims <- [];
2252 | "clearrects" ->
2253 state.rects <- state.rects1;
2254 G.postRedisplay "clearrects";
2256 | "continue" ->
2257 let n =
2258 try Scanf.sscanf args "%u" (fun n -> n)
2259 with exn ->
2260 dolog "error processing 'continue' %S: %s"
2261 cmds (Printexc.to_string exn);
2262 exit 1;
2264 state.pagecount <- n;
2265 begin match state.currently with
2266 | Outlining l ->
2267 state.currently <- Idle;
2268 state.outlines <- Array.of_list (List.rev l)
2269 | _ -> ()
2270 end;
2272 let cur, cmds = state.geomcmds in
2273 if String.length cur = 0
2274 then failwith "umpossible";
2276 begin match List.rev cmds with
2277 | [] ->
2278 state.geomcmds <- "", [];
2279 represent ();
2280 | (s, f) :: rest ->
2281 f ();
2282 state.geomcmds <- s, List.rev rest;
2283 end;
2284 if conf.maxwait = None
2285 then G.postRedisplay "continue";
2287 | "title" ->
2288 Wsi.settitle args
2290 | "msg" ->
2291 showtext ' ' args
2293 | "vmsg" ->
2294 if conf.verbose
2295 then showtext ' ' args
2297 | "emsg" ->
2298 Buffer.add_string state.errmsgs args;
2299 state.newerrmsgs <- true;
2300 G.postRedisplay "error message"
2302 | "progress" ->
2303 let progress, text =
2305 Scanf.sscanf args "%f %n"
2306 (fun f pos ->
2307 f, String.sub args pos (String.length args - pos))
2308 with exn ->
2309 dolog "error processing 'progress' %S: %s"
2310 cmds (Printexc.to_string exn);
2311 exit 1;
2313 state.text <- text;
2314 state.progress <- progress;
2315 G.postRedisplay "progress"
2317 | "firstmatch" ->
2318 let pageno, c, x0, y0, x1, y1, x2, y2, x3, y3 =
2320 Scanf.sscanf args "%u %d %f %f %f %f %f %f %f %f"
2321 (fun p c x0 y0 x1 y1 x2 y2 x3 y3 ->
2322 (p, c, x0, y0, x1, y1, x2, y2, x3, y3))
2323 with exn ->
2324 dolog "error processing 'firstmatch' %S: %s"
2325 cmds (Printexc.to_string exn);
2326 exit 1;
2328 let y = (getpagey pageno) + truncate y0 in
2329 addnav ();
2330 gotoy y;
2331 state.rects1 <- [pageno, c, (x0, y0, x1, y1, x2, y2, x3, y3)]
2333 | "match" ->
2334 let pageno, c, x0, y0, x1, y1, x2, y2, x3, y3 =
2336 Scanf.sscanf args "%u %d %f %f %f %f %f %f %f %f"
2337 (fun p c x0 y0 x1 y1 x2 y2 x3 y3 ->
2338 (p, c, x0, y0, x1, y1, x2, y2, x3, y3))
2339 with exn ->
2340 dolog "error processing 'match' %S: %s"
2341 cmds (Printexc.to_string exn);
2342 exit 1;
2344 state.rects1 <-
2345 (pageno, c, (x0, y0, x1, y1, x2, y2, x3, y3)) :: state.rects1
2347 | "page" ->
2348 let pageopaque, t =
2350 Scanf.sscanf args "%s %f" (fun p t -> p, t)
2351 with exn ->
2352 dolog "error processing 'page' %S: %s"
2353 cmds (Printexc.to_string exn);
2354 exit 1;
2356 begin match state.currently with
2357 | Loading (l, gen) ->
2358 vlog "page %d took %f sec" l.pageno t;
2359 Hashtbl.replace state.pagemap (l.pageno, gen) pageopaque;
2360 begin match state.throttle with
2361 | None ->
2362 let preloadedpages =
2363 if conf.preload
2364 then preloadlayout state.y
2365 else state.layout
2367 let evict () =
2368 let module IntSet =
2369 Set.Make (struct type t = int let compare = (-) end) in
2370 let set =
2371 List.fold_left (fun s l -> IntSet.add l.pageno s)
2372 IntSet.empty preloadedpages
2374 let evictedpages =
2375 Hashtbl.fold (fun ((pageno, _) as key) opaque accu ->
2376 if not (IntSet.mem pageno set)
2377 then (
2378 wcmd "freepage %s" opaque;
2379 key :: accu
2381 else accu
2382 ) state.pagemap []
2384 List.iter (Hashtbl.remove state.pagemap) evictedpages;
2386 evict ();
2387 state.currently <- Idle;
2388 if gen = state.gen
2389 then (
2390 tilepage l.pageno pageopaque state.layout;
2391 load state.layout;
2392 load preloadedpages;
2393 if pagevisible state.layout l.pageno
2394 && layoutready state.layout
2395 then G.postRedisplay "page";
2398 | Some (layout, _, _) ->
2399 state.currently <- Idle;
2400 tilepage l.pageno pageopaque layout;
2401 load state.layout
2402 end;
2404 | _ ->
2405 dolog "Inconsistent loading state";
2406 logcurrently state.currently;
2407 exit 1
2410 | "tile" ->
2411 let (x, y, opaque, size, t) =
2413 Scanf.sscanf args "%u %u %s %u %f"
2414 (fun x y p size t -> (x, y, p, size, t))
2415 with exn ->
2416 dolog "error processing 'tile' %S: %s"
2417 cmds (Printexc.to_string exn);
2418 exit 1;
2420 begin match state.currently with
2421 | Tiling (l, pageopaque, cs, angle, gen, col, row, tilew, tileh) ->
2422 vlog "tile %d [%d,%d] took %f sec" l.pageno col row t;
2424 unmappbo opaque;
2425 if tilew != conf.tilew || tileh != conf.tileh
2426 then (
2427 wcmd "freetile %s" opaque;
2428 state.currently <- Idle;
2429 load state.layout;
2431 else (
2432 puttileopaque l col row gen cs angle opaque size t;
2433 state.memused <- state.memused + size;
2434 state.uioh#infochanged Memused;
2435 gctiles ();
2436 Queue.push ((l.pageno, gen, cs, angle, l.pagew, l.pageh, col, row),
2437 opaque, size) state.tilelru;
2439 let layout =
2440 match state.throttle with
2441 | None -> state.layout
2442 | Some (layout, _, _) -> layout
2445 state.currently <- Idle;
2446 if gen = state.gen
2447 && conf.colorspace = cs
2448 && conf.angle = angle
2449 && tilevisible layout l.pageno x y
2450 then conttiling l.pageno pageopaque;
2452 begin match state.throttle with
2453 | None ->
2454 if state.wthack
2455 then state.wthack <- not (layoutready state.layout);
2456 preload state.layout;
2457 if gen = state.gen
2458 && conf.colorspace = cs
2459 && conf.angle = angle
2460 && tilevisible state.layout l.pageno x y
2461 then G.postRedisplay "tile nothrottle";
2463 | Some (layout, y, _) ->
2464 let ready = layoutready layout in
2465 if ready
2466 then (
2467 state.wthack <- false;
2468 state.y <- y;
2469 state.layout <- layout;
2470 state.throttle <- None;
2471 G.postRedisplay "throttle";
2473 else load layout;
2474 end;
2477 | _ ->
2478 dolog "Inconsistent tiling state";
2479 logcurrently state.currently;
2480 exit 1
2483 | "pdim" ->
2484 let pdim =
2486 Scanf.sscanf args "%u %u %u %u" (fun n w h x -> n, w, h, x)
2487 with exn ->
2488 dolog "error processing 'pdim' %S: %s"
2489 cmds (Printexc.to_string exn);
2490 exit 1;
2492 state.uioh#infochanged Pdim;
2493 state.pdims <- pdim :: state.pdims
2495 | "o" ->
2496 let (l, n, t, h, pos) =
2498 Scanf.sscanf args "%u %u %d %u %n"
2499 (fun l n t h pos -> l, n, t, h, pos)
2500 with exn ->
2501 dolog "error processing 'o' %S: %s"
2502 cmds (Printexc.to_string exn);
2503 exit 1;
2505 let s = String.sub args pos (String.length args - pos) in
2506 let outline = (s, l, (n, float t /. float h, 0.0)) in
2507 begin match state.currently with
2508 | Outlining outlines ->
2509 state.currently <- Outlining (outline :: outlines)
2510 | Idle ->
2511 state.currently <- Outlining [outline]
2512 | currently ->
2513 dolog "invalid outlining state";
2514 logcurrently currently
2517 | "a" ->
2518 let (n, t, h) =
2520 Scanf.sscanf args "%u %u %d"
2521 (fun n t h -> n, t, h)
2522 with exn ->
2523 dolog "error processing 'a' %S: %s"
2524 cmds (Printexc.to_string exn);
2525 exit 1;
2527 let top, dtop =
2528 if conf.presentation
2529 then (0.0, 1.0)
2530 else float t /. float h, 0.0
2532 state.anchor <- (n, top, dtop)
2534 | "info" ->
2535 state.docinfo <- (1, args) :: state.docinfo
2537 | "infoend" ->
2538 state.uioh#infochanged Docinfo;
2539 state.docinfo <- List.rev state.docinfo
2541 | _ ->
2542 dolog "unknown cmd `%S'" cmds
2545 let onhist cb =
2546 let rc = cb.rc in
2547 let action = function
2548 | HCprev -> cbget cb ~-1
2549 | HCnext -> cbget cb 1
2550 | HCfirst -> cbget cb ~-(cb.rc)
2551 | HClast -> cbget cb (cb.len - 1 - cb.rc)
2552 and cancel () = cb.rc <- rc
2553 in (action, cancel)
2556 let search pattern forward =
2557 if String.length pattern > 0
2558 then
2559 let pn, py =
2560 match state.layout with
2561 | [] -> 0, 0
2562 | l :: _ ->
2563 l.pageno, (l.pagey + if forward then 0 else 0*l.pagevh)
2565 wcmd "search %d %d %d %d,%s\000"
2566 (btod conf.icase) pn py (btod forward) pattern;
2569 let intentry text key =
2570 let c =
2571 if key >= 32 && key < 127
2572 then Char.chr key
2573 else '\000'
2575 match c with
2576 | '0' .. '9' ->
2577 let text = addchar text c in
2578 TEcont text
2580 | _ ->
2581 state.text <- Printf.sprintf "invalid char (%d, `%c')" key c;
2582 TEcont text
2585 let linknentry text key =
2586 let c =
2587 if key >= 32 && key < 127
2588 then Char.chr key
2589 else '\000'
2591 match c with
2592 | 'a' .. 'z' ->
2593 let text = addchar text c in
2594 TEcont text
2596 | _ ->
2597 state.text <- Printf.sprintf "invalid char (%d, `%c')" key c;
2598 TEcont text
2601 let linkndone f s =
2602 if String.length s > 0
2603 then (
2604 let n =
2605 let l = String.length s in
2606 let rec loop pos n = if pos = l then n else
2607 let m = Char.code s.[pos] - (if pos = 0 && l > 1 then 96 else 97) in
2608 loop (pos+1) (n*26 + m)
2609 in loop 0 0
2611 let rec loop n = function
2612 | [] -> ()
2613 | l :: rest ->
2614 match getopaque l.pageno with
2615 | None -> loop n rest
2616 | Some opaque ->
2617 let m = getlinkcount opaque in
2618 if n < m
2619 then (
2620 let under = getlink opaque n in
2621 f under
2623 else loop (n-m) rest
2625 loop n state.layout;
2629 let textentry text key =
2630 if key land 0xff00 = 0xff00
2631 then TEcont text
2632 else TEcont (text ^ Wsi.toutf8 key)
2635 let reqlayout angle proportional =
2636 match state.throttle with
2637 | None ->
2638 if nogeomcmds state.geomcmds
2639 then state.anchor <- getanchor ();
2640 conf.angle <- angle mod 360;
2641 if conf.angle != 0
2642 then (
2643 match state.mode with
2644 | LinkNav _ -> state.mode <- View
2645 | _ -> ()
2647 conf.proportional <- proportional;
2648 invalidate "reqlayout"
2649 (fun () -> wcmd "reqlayout %d %d" conf.angle (btod proportional));
2650 | _ -> ()
2653 let settrim trimmargins trimfuzz =
2654 if nogeomcmds state.geomcmds
2655 then state.anchor <- getanchor ();
2656 conf.trimmargins <- trimmargins;
2657 conf.trimfuzz <- trimfuzz;
2658 let x0, y0, x1, y1 = trimfuzz in
2659 invalidate "settrim"
2660 (fun () ->
2661 wcmd "settrim %d %d %d %d %d" (btod conf.trimmargins) x0 y0 x1 y1);
2662 flushpages ();
2665 let setzoom zoom =
2666 match state.throttle with
2667 | None ->
2668 let zoom = max 0.01 zoom in
2669 if zoom <> conf.zoom
2670 then (
2671 state.prevzoom <- conf.zoom;
2672 conf.zoom <- zoom;
2673 reshape conf.winw conf.winh;
2674 state.text <- Printf.sprintf "zoom is now %-5.1f" (zoom *. 100.0);
2677 | Some (layout, y, started) ->
2678 let time =
2679 match conf.maxwait with
2680 | None -> 0.0
2681 | Some t -> t
2683 let dt = now () -. started in
2684 if dt > time
2685 then (
2686 state.y <- y;
2687 load layout;
2691 let setcolumns mode columns coverA coverB =
2692 state.prevcolumns <- Some (conf.columns, conf.zoom);
2693 if columns < 0
2694 then (
2695 if isbirdseye mode
2696 then showtext '!' "split mode doesn't work in bird's eye"
2697 else (
2698 conf.columns <- Csplit (-columns, [||]);
2699 state.x <- 0;
2700 conf.zoom <- 1.0;
2703 else (
2704 if columns < 2
2705 then (
2706 conf.columns <- Csingle [||];
2707 state.x <- 0;
2708 setzoom 1.0;
2710 else (
2711 conf.columns <- Cmulti ((columns, coverA, coverB), [||]);
2712 conf.zoom <- 1.0;
2715 reshape conf.winw conf.winh;
2718 let enterbirdseye () =
2719 let zoom = float conf.thumbw /. float conf.winw in
2720 let birdseyepageno =
2721 let cy = conf.winh / 2 in
2722 let fold = function
2723 | [] -> 0
2724 | l :: rest ->
2725 let rec fold best = function
2726 | [] -> best.pageno
2727 | l :: rest ->
2728 let d = cy - (l.pagedispy + l.pagevh/2)
2729 and dbest = cy - (best.pagedispy + best.pagevh/2) in
2730 if abs d < abs dbest
2731 then fold l rest
2732 else best.pageno
2733 in fold l rest
2735 fold state.layout
2737 state.mode <- Birdseye (
2738 { conf with zoom = conf.zoom }, state.x, birdseyepageno, -1, getanchor ()
2740 conf.zoom <- zoom;
2741 conf.presentation <- false;
2742 conf.interpagespace <- 10;
2743 conf.hlinks <- false;
2744 state.x <- 0;
2745 state.mstate <- Mnone;
2746 conf.maxwait <- None;
2747 conf.columns <- (
2748 match conf.beyecolumns with
2749 | Some c ->
2750 conf.zoom <- 1.0;
2751 Cmulti ((c, 0, 0), [||])
2752 | None -> Csingle [||]
2754 Wsi.setcursor Wsi.CURSOR_INHERIT;
2755 if conf.verbose
2756 then
2757 state.text <- Printf.sprintf "birds eye mode on (zoom %3.1f%%)"
2758 (100.0*.zoom)
2759 else
2760 state.text <- ""
2762 reshape conf.winw conf.winh;
2765 let leavebirdseye (c, leftx, pageno, _, anchor) goback =
2766 state.mode <- View;
2767 conf.zoom <- c.zoom;
2768 conf.presentation <- c.presentation;
2769 conf.interpagespace <- c.interpagespace;
2770 conf.maxwait <- c.maxwait;
2771 conf.hlinks <- c.hlinks;
2772 conf.beyecolumns <- (
2773 match conf.columns with
2774 | Cmulti ((c, _, _), _) -> Some c
2775 | Csingle _ -> None
2776 | Csplit _ -> failwith "leaving bird's eye split mode"
2778 conf.columns <- (
2779 match c.columns with
2780 | Cmulti (c, _) -> Cmulti (c, [||])
2781 | Csingle _ -> Csingle [||]
2782 | Csplit (c, _) -> Csplit (c, [||])
2784 state.x <- leftx;
2785 if conf.verbose
2786 then
2787 state.text <- Printf.sprintf "birds eye mode off (zoom %3.1f%%)"
2788 (100.0*.conf.zoom)
2790 reshape conf.winw conf.winh;
2791 state.anchor <- if goback then anchor else (pageno, 0.0, 1.0);
2794 let togglebirdseye () =
2795 match state.mode with
2796 | Birdseye vals -> leavebirdseye vals true
2797 | View -> enterbirdseye ()
2798 | _ -> ()
2801 let upbirdseye incr (conf, leftx, pageno, hooverpageno, anchor) =
2802 let pageno = max 0 (pageno - incr) in
2803 let rec loop = function
2804 | [] -> gotopage1 pageno 0
2805 | l :: _ when l.pageno = pageno ->
2806 if l.pagedispy >= 0 && l.pagey = 0
2807 then G.postRedisplay "upbirdseye"
2808 else gotopage1 pageno 0
2809 | _ :: rest -> loop rest
2811 loop state.layout;
2812 state.mode <- Birdseye (conf, leftx, pageno, hooverpageno, anchor)
2815 let downbirdseye incr (conf, leftx, pageno, hooverpageno, anchor) =
2816 let pageno = min (state.pagecount - 1) (pageno + incr) in
2817 state.mode <- Birdseye (conf, leftx, pageno, hooverpageno, anchor);
2818 let rec loop = function
2819 | [] ->
2820 let y, h = getpageyh pageno in
2821 let dy = (y - state.y) - (conf.winh - h - conf.interpagespace) in
2822 gotoy (clamp dy)
2823 | l :: _ when l.pageno = pageno ->
2824 if l.pagevh != l.pageh
2825 then gotoy (clamp (l.pageh - l.pagevh + conf.interpagespace))
2826 else G.postRedisplay "downbirdseye"
2827 | _ :: rest -> loop rest
2829 loop state.layout
2832 let optentry mode _ key =
2833 let btos b = if b then "on" else "off" in
2834 if key >= 32 && key < 127
2835 then
2836 let c = Char.chr key in
2837 match c with
2838 | 's' ->
2839 let ondone s =
2840 try conf.scrollstep <- int_of_string s with exc ->
2841 state.text <- Printf.sprintf "bad integer `%s': %s"
2842 s (Printexc.to_string exc)
2844 TEswitch ("scroll step: ", "", None, intentry, ondone, true)
2846 | 'A' ->
2847 let ondone s =
2849 conf.autoscrollstep <- int_of_string s;
2850 if state.autoscroll <> None
2851 then state.autoscroll <- Some conf.autoscrollstep
2852 with exc ->
2853 state.text <- Printf.sprintf "bad integer `%s': %s"
2854 s (Printexc.to_string exc)
2856 TEswitch ("auto scroll step: ", "", None, intentry, ondone, true)
2858 | 'C' ->
2859 let ondone s =
2861 let n, a, b = multicolumns_of_string s in
2862 setcolumns mode n a b;
2863 with exc ->
2864 state.text <- Printf.sprintf "bad columns `%s': %s"
2865 s (Printexc.to_string exc)
2867 TEswitch ("columns: ", "", None, textentry, ondone, true)
2869 | 'Z' ->
2870 let ondone s =
2872 let zoom = float (int_of_string s) /. 100.0 in
2873 setzoom zoom
2874 with exc ->
2875 state.text <- Printf.sprintf "bad integer `%s': %s"
2876 s (Printexc.to_string exc)
2878 TEswitch ("zoom: ", "", None, intentry, ondone, true)
2880 | 't' ->
2881 let ondone s =
2883 conf.thumbw <- bound (int_of_string s) 2 4096;
2884 state.text <-
2885 Printf.sprintf "thumbnail width is set to %d" conf.thumbw;
2886 begin match mode with
2887 | Birdseye beye ->
2888 leavebirdseye beye false;
2889 enterbirdseye ();
2890 | _ -> ();
2892 with exc ->
2893 state.text <- Printf.sprintf "bad integer `%s': %s"
2894 s (Printexc.to_string exc)
2896 TEswitch ("thumbnail width: ", "", None, intentry, ondone, true)
2898 | 'R' ->
2899 let ondone s =
2900 match try
2901 Some (int_of_string s)
2902 with exc ->
2903 state.text <- Printf.sprintf "bad integer `%s': %s"
2904 s (Printexc.to_string exc);
2905 None
2906 with
2907 | Some angle -> reqlayout angle conf.proportional
2908 | None -> ()
2910 TEswitch ("rotation: ", "", None, intentry, ondone, true)
2912 | 'i' ->
2913 conf.icase <- not conf.icase;
2914 TEdone ("case insensitive search " ^ (btos conf.icase))
2916 | 'p' ->
2917 conf.preload <- not conf.preload;
2918 gotoy state.y;
2919 TEdone ("preload " ^ (btos conf.preload))
2921 | 'v' ->
2922 conf.verbose <- not conf.verbose;
2923 TEdone ("verbose " ^ (btos conf.verbose))
2925 | 'd' ->
2926 conf.debug <- not conf.debug;
2927 TEdone ("debug " ^ (btos conf.debug))
2929 | 'h' ->
2930 conf.maxhfit <- not conf.maxhfit;
2931 state.maxy <- calcheight ();
2932 TEdone ("maxhfit " ^ (btos conf.maxhfit))
2934 | 'c' ->
2935 conf.crophack <- not conf.crophack;
2936 TEdone ("crophack " ^ btos conf.crophack)
2938 | 'a' ->
2939 let s =
2940 match conf.maxwait with
2941 | None ->
2942 conf.maxwait <- Some infinity;
2943 "always wait for page to complete"
2944 | Some _ ->
2945 conf.maxwait <- None;
2946 "show placeholder if page is not ready"
2948 TEdone s
2950 | 'f' ->
2951 conf.underinfo <- not conf.underinfo;
2952 TEdone ("underinfo " ^ btos conf.underinfo)
2954 | 'P' ->
2955 conf.savebmarks <- not conf.savebmarks;
2956 TEdone ("persistent bookmarks " ^ btos conf.savebmarks)
2958 | 'S' ->
2959 let ondone s =
2961 let pageno, py =
2962 match state.layout with
2963 | [] -> 0, 0
2964 | l :: _ ->
2965 l.pageno, l.pagey
2967 conf.interpagespace <- int_of_string s;
2968 docolumns conf.columns;
2969 state.maxy <- calcheight ();
2970 let y = getpagey pageno in
2971 gotoy (y + py)
2972 with exc ->
2973 state.text <- Printf.sprintf "bad integer `%s': %s"
2974 s (Printexc.to_string exc)
2976 TEswitch ("vertical margin: ", "", None, intentry, ondone, true)
2978 | 'l' ->
2979 reqlayout conf.angle (not conf.proportional);
2980 TEdone ("proportional display " ^ btos conf.proportional)
2982 | 'T' ->
2983 settrim (not conf.trimmargins) conf.trimfuzz;
2984 TEdone ("trim margins " ^ btos conf.trimmargins)
2986 | 'I' ->
2987 conf.invert <- not conf.invert;
2988 TEdone ("invert colors " ^ btos conf.invert)
2990 | 'x' ->
2991 let ondone s =
2992 cbput state.hists.sel s;
2993 conf.selcmd <- s;
2995 TEswitch ("selection command: ", "", Some (onhist state.hists.sel),
2996 textentry, ondone, true)
2998 | _ ->
2999 state.text <- Printf.sprintf "bad option %d `%c'" key c;
3000 TEstop
3001 else
3002 TEcont state.text
3005 class type lvsource = object
3006 method getitemcount : int
3007 method getitem : int -> (string * int)
3008 method hasaction : int -> bool
3009 method exit :
3010 uioh:uioh ->
3011 cancel:bool ->
3012 active:int ->
3013 first:int ->
3014 pan:int ->
3015 qsearch:string ->
3016 uioh option
3017 method getactive : int
3018 method getfirst : int
3019 method getqsearch : string
3020 method setqsearch : string -> unit
3021 method getpan : int
3022 end;;
3024 class virtual lvsourcebase = object
3025 val mutable m_active = 0
3026 val mutable m_first = 0
3027 val mutable m_qsearch = ""
3028 val mutable m_pan = 0
3029 method getactive = m_active
3030 method getfirst = m_first
3031 method getqsearch = m_qsearch
3032 method getpan = m_pan
3033 method setqsearch s = m_qsearch <- s
3034 end;;
3036 let withoutlastutf8 s =
3037 let len = String.length s in
3038 if len = 0
3039 then s
3040 else
3041 let rec find pos =
3042 if pos = 0
3043 then pos
3044 else
3045 let b = Char.code s.[pos] in
3046 if b land 0b11000000 = 0b11000000
3047 then pos
3048 else find (pos-1)
3050 let first =
3051 if Char.code s.[len-1] land 0x80 = 0
3052 then len-1
3053 else find (len-1)
3055 String.sub s 0 first;
3058 let textentrykeyboard
3059 key _mask ((c, text, opthist, onkey, ondone, cancelonempty), onleave) =
3060 let key =
3061 if key >= 0xffb0 && key <= 0xffb9
3062 then key - 0xffb0 + 48 else key
3064 let enttext te =
3065 state.mode <- Textentry (te, onleave);
3066 state.text <- "";
3067 enttext ();
3068 G.postRedisplay "textentrykeyboard enttext";
3070 let histaction cmd =
3071 match opthist with
3072 | None -> ()
3073 | Some (action, _) ->
3074 state.mode <- Textentry (
3075 (c, action cmd, opthist, onkey, ondone, cancelonempty), onleave
3077 G.postRedisplay "textentry histaction"
3079 match key with
3080 | 0xff08 -> (* backspace *)
3081 let s = withoutlastutf8 text in
3082 let len = String.length s in
3083 if cancelonempty && len = 0
3084 then (
3085 onleave Cancel;
3086 G.postRedisplay "textentrykeyboard after cancel";
3088 else (
3089 enttext (c, s, opthist, onkey, ondone, cancelonempty)
3092 | 0xff0d | 0xff8d -> (* (kp) enter *)
3093 ondone text;
3094 onleave Confirm;
3095 G.postRedisplay "textentrykeyboard after confirm"
3097 | 0xff52 | 0xff97 -> histaction HCprev (* (kp) up *)
3098 | 0xff54 | 0xff99 -> histaction HCnext (* (kp) down *)
3099 | 0xff50 | 0xff95 -> histaction HCfirst (* (kp) home) *)
3100 | 0xff57 | 0xff9c -> histaction HClast (* (kp) end *)
3102 | 0xff1b -> (* escape*)
3103 if String.length text = 0
3104 then (
3105 begin match opthist with
3106 | None -> ()
3107 | Some (_, onhistcancel) -> onhistcancel ()
3108 end;
3109 onleave Cancel;
3110 state.text <- "";
3111 G.postRedisplay "textentrykeyboard after cancel2"
3113 else (
3114 enttext (c, "", opthist, onkey, ondone, cancelonempty)
3117 | 0xff9f | 0xffff -> () (* delete *)
3119 | _ when key != 0
3120 && key land 0xff00 != 0xff00 (* keyboard *)
3121 && key land 0xfe00 != 0xfe00 (* xkb *)
3122 && key land 0xfd00 != 0xfd00 (* 3270 *)
3124 begin match onkey text key with
3125 | TEdone text ->
3126 ondone text;
3127 onleave Confirm;
3128 G.postRedisplay "textentrykeyboard after confirm2";
3130 | TEcont text ->
3131 enttext (c, text, opthist, onkey, ondone, cancelonempty);
3133 | TEstop ->
3134 onleave Cancel;
3135 G.postRedisplay "textentrykeyboard after cancel3"
3137 | TEswitch te ->
3138 state.mode <- Textentry (te, onleave);
3139 G.postRedisplay "textentrykeyboard switch";
3140 end;
3142 | _ ->
3143 vlog "unhandled key %s" (Wsi.keyname key)
3146 let firstof first active =
3147 if first > active || abs (first - active) > fstate.maxrows - 1
3148 then max 0 (active - (fstate.maxrows/2))
3149 else first
3152 let calcfirst first active =
3153 if active > first
3154 then
3155 let rows = active - first in
3156 if rows > fstate.maxrows then active - fstate.maxrows else first
3157 else active
3160 let scrollph y maxy =
3161 let sh = (float (maxy + conf.winh) /. float conf.winh) in
3162 let sh = float conf.winh /. sh in
3163 let sh = max sh (float conf.scrollh) in
3165 let percent =
3166 if y = state.maxy
3167 then 1.0
3168 else float y /. float maxy
3170 let position = (float conf.winh -. sh) *. percent in
3172 let position =
3173 if position +. sh > float conf.winh
3174 then float conf.winh -. sh
3175 else position
3177 position, sh;
3180 let coe s = (s :> uioh);;
3182 class listview ~(source:lvsource) ~trusted ~modehash =
3183 object (self)
3184 val m_pan = source#getpan
3185 val m_first = source#getfirst
3186 val m_active = source#getactive
3187 val m_qsearch = source#getqsearch
3188 val m_prev_uioh = state.uioh
3190 method private elemunder y =
3191 let n = y / (fstate.fontsize+1) in
3192 if m_first + n < source#getitemcount
3193 then (
3194 if source#hasaction (m_first + n)
3195 then Some (m_first + n)
3196 else None
3198 else None
3200 method display =
3201 Gl.enable `blend;
3202 GlFunc.blend_func `src_alpha `one_minus_src_alpha;
3203 GlDraw.color (0., 0., 0.) ~alpha:0.85;
3204 GlDraw.rect (0., 0.) (float conf.winw, float conf.winh);
3205 GlDraw.color (1., 1., 1.);
3206 Gl.enable `texture_2d;
3207 let fs = fstate.fontsize in
3208 let nfs = fs + 1 in
3209 let ww = fstate.wwidth in
3210 let tabw = 30.0*.ww in
3211 let itemcount = source#getitemcount in
3212 let rec loop row =
3213 if (row - m_first) > fstate.maxrows
3214 then ()
3215 else (
3216 if row >= 0 && row < itemcount
3217 then (
3218 let (s, level) = source#getitem row in
3219 let y = (row - m_first) * nfs in
3220 let x = 5.0 +. float (level + m_pan) *. ww in
3221 if row = m_active
3222 then (
3223 Gl.disable `texture_2d;
3224 GlDraw.polygon_mode `both `line;
3225 GlDraw.color (1., 1., 1.) ~alpha:0.9;
3226 GlDraw.rect (1., float (y + 1))
3227 (float (conf.winw - conf.scrollbw - 1), float (y + fs + 3));
3228 GlDraw.polygon_mode `both `fill;
3229 GlDraw.color (1., 1., 1.);
3230 Gl.enable `texture_2d;
3233 let drawtabularstring s =
3234 let drawstr x s = drawstring1 fs (truncate x) (y+nfs) s in
3235 if trusted
3236 then
3237 let tabpos = try String.index s '\t' with Not_found -> -1 in
3238 if tabpos > 0
3239 then
3240 let len = String.length s - tabpos - 1 in
3241 let s1 = String.sub s 0 tabpos
3242 and s2 = String.sub s (tabpos + 1) len in
3243 let nx = drawstr x s1 in
3244 let sw = nx -. x in
3245 let x = x +. (max tabw sw) in
3246 drawstr x s2
3247 else
3248 drawstr x s
3249 else
3250 drawstr x s
3252 let _ = drawtabularstring s in
3253 loop (row+1)
3257 loop m_first;
3258 Gl.disable `blend;
3259 Gl.disable `texture_2d;
3261 method updownlevel incr =
3262 let len = source#getitemcount in
3263 let curlevel =
3264 if m_active >= 0 && m_active < len
3265 then snd (source#getitem m_active)
3266 else -1
3268 let rec flow i =
3269 if i = len then i-1 else if i = -1 then 0 else
3270 let _, l = source#getitem i in
3271 if l != curlevel then i else flow (i+incr)
3273 let active = flow m_active in
3274 let first = calcfirst m_first active in
3275 G.postRedisplay "outline updownlevel";
3276 {< m_active = active; m_first = first >}
3278 method private key1 key mask =
3279 let set1 active first qsearch =
3280 coe {< m_active = active; m_first = first; m_qsearch = qsearch >}
3282 let search active pattern incr =
3283 let dosearch re =
3284 let rec loop n =
3285 if n >= 0 && n < source#getitemcount
3286 then (
3287 let s, _ = source#getitem n in
3289 (try ignore (Str.search_forward re s 0); true
3290 with Not_found -> false)
3291 then Some n
3292 else loop (n + incr)
3294 else None
3296 loop active
3299 let re = Str.regexp_case_fold pattern in
3300 dosearch re
3301 with Failure s ->
3302 state.text <- s;
3303 None
3305 let itemcount = source#getitemcount in
3306 let find start incr =
3307 let rec find i =
3308 if i = -1 || i = itemcount
3309 then -1
3310 else (
3311 if source#hasaction i
3312 then i
3313 else find (i + incr)
3316 find start
3318 let set active first =
3319 let first = bound first 0 (itemcount - fstate.maxrows) in
3320 state.text <- "";
3321 coe {< m_active = active; m_first = first >}
3323 let navigate incr =
3324 let isvisible first n = n >= first && n - first <= fstate.maxrows in
3325 let active, first =
3326 let incr1 = if incr > 0 then 1 else -1 in
3327 if isvisible m_first m_active
3328 then
3329 let next =
3330 let next = m_active + incr in
3331 let next =
3332 if next < 0 || next >= itemcount
3333 then -1
3334 else find next incr1
3336 if next = -1 || abs (m_active - next) > fstate.maxrows
3337 then -1
3338 else next
3340 if next = -1
3341 then
3342 let first = m_first + incr in
3343 let first = bound first 0 (itemcount - 1) in
3344 let next =
3345 let next = m_active + incr in
3346 let next = bound next 0 (itemcount - 1) in
3347 find next ~-incr1
3349 let active = if next = -1 then m_active else next in
3350 active, first
3351 else
3352 let first = min next m_first in
3353 let first =
3354 if abs (next - first) > fstate.maxrows
3355 then first + incr
3356 else first
3358 next, first
3359 else
3360 let first = m_first + incr in
3361 let first = bound first 0 (itemcount - 1) in
3362 let active =
3363 let next = m_active + incr in
3364 let next = bound next 0 (itemcount - 1) in
3365 let next = find next incr1 in
3366 let active =
3367 if next = -1 || abs (m_active - first) > fstate.maxrows
3368 then (
3369 let active = if m_active = -1 then next else m_active in
3370 active
3372 else next
3374 if isvisible first active
3375 then active
3376 else -1
3378 active, first
3380 G.postRedisplay "listview navigate";
3381 set active first;
3383 match key with
3384 | (0x72|0x73) when Wsi.withctrl mask -> (* ctrl-r/ctlr-s *)
3385 let incr = if key = 0x72 then -1 else 1 in
3386 let active, first =
3387 match search (m_active + incr) m_qsearch incr with
3388 | None ->
3389 state.text <- m_qsearch ^ " [not found]";
3390 m_active, m_first
3391 | Some active ->
3392 state.text <- m_qsearch;
3393 active, firstof m_first active
3395 G.postRedisplay "listview ctrl-r/s";
3396 set1 active first m_qsearch;
3398 | 0xff08 -> (* backspace *)
3399 if String.length m_qsearch = 0
3400 then coe self
3401 else (
3402 let qsearch = withoutlastutf8 m_qsearch in
3403 let len = String.length qsearch in
3404 if len = 0
3405 then (
3406 state.text <- "";
3407 G.postRedisplay "listview empty qsearch";
3408 set1 m_active m_first "";
3410 else
3411 let active, first =
3412 match search m_active qsearch ~-1 with
3413 | None ->
3414 state.text <- qsearch ^ " [not found]";
3415 m_active, m_first
3416 | Some active ->
3417 state.text <- qsearch;
3418 active, firstof m_first active
3420 G.postRedisplay "listview backspace qsearch";
3421 set1 active first qsearch
3424 | key when (key != 0 && key land 0xff00 != 0xff00) ->
3425 let pattern = m_qsearch ^ Wsi.toutf8 key in
3426 let active, first =
3427 match search m_active pattern 1 with
3428 | None ->
3429 state.text <- pattern ^ " [not found]";
3430 m_active, m_first
3431 | Some active ->
3432 state.text <- pattern;
3433 active, firstof m_first active
3435 G.postRedisplay "listview qsearch add";
3436 set1 active first pattern;
3438 | 0xff1b -> (* escape *)
3439 state.text <- "";
3440 if String.length m_qsearch = 0
3441 then (
3442 G.postRedisplay "list view escape";
3443 begin
3444 match
3445 source#exit (coe self) true m_active m_first m_pan m_qsearch
3446 with
3447 | None -> m_prev_uioh
3448 | Some uioh -> uioh
3451 else (
3452 G.postRedisplay "list view kill qsearch";
3453 source#setqsearch "";
3454 coe {< m_qsearch = "" >}
3457 | 0xff0d | 0xff8d -> (* (kp) enter *)
3458 state.text <- "";
3459 let self = {< m_qsearch = "" >} in
3460 source#setqsearch "";
3461 let opt =
3462 G.postRedisplay "listview enter";
3463 if m_active >= 0 && m_active < source#getitemcount
3464 then (
3465 source#exit (coe self) false m_active m_first m_pan "";
3467 else (
3468 source#exit (coe self) true m_active m_first m_pan "";
3471 begin match opt with
3472 | None -> m_prev_uioh
3473 | Some uioh -> uioh
3476 | 0xff9f | 0xffff -> (* (kp) delete *)
3477 coe self
3479 | 0xff52 | 0xff97 -> navigate ~-1 (* (kp) up *)
3480 | 0xff54 | 0xff99 -> navigate 1 (* (kp) down *)
3481 | 0xff55 | 0xff9a -> navigate ~-(fstate.maxrows) (* (kp) prior *)
3482 | 0xff56 | 0xff9b -> navigate fstate.maxrows (* (kp) next *)
3484 | 0xff53 | 0xff98 -> (* (kp) right *)
3485 state.text <- "";
3486 G.postRedisplay "listview right";
3487 coe {< m_pan = m_pan - 1 >}
3489 | 0xff51 | 0xff96 -> (* (kp) left *)
3490 state.text <- "";
3491 G.postRedisplay "listview left";
3492 coe {< m_pan = m_pan + 1 >}
3494 | 0xff50 | 0xff95 -> (* (kp) home *)
3495 let active = find 0 1 in
3496 G.postRedisplay "listview home";
3497 set active 0;
3499 | 0xff57 | 0xff9c -> (* (kp) end *)
3500 let first = max 0 (itemcount - fstate.maxrows) in
3501 let active = find (itemcount - 1) ~-1 in
3502 G.postRedisplay "listview end";
3503 set active first;
3505 | key when (key = 0 || key land 0xff00 = 0xff00) ->
3506 coe self
3508 | _ ->
3509 dolog "listview unknown key %#x" key; coe self
3511 method key key mask =
3512 match state.mode with
3513 | Textentry te -> textentrykeyboard key mask te; coe self
3514 | _ -> self#key1 key mask
3516 method button button down x y _ =
3517 let opt =
3518 match button with
3519 | 1 when x > conf.winw - conf.scrollbw ->
3520 G.postRedisplay "listview scroll";
3521 if down
3522 then
3523 let _, position, sh = self#scrollph in
3524 if y > truncate position && y < truncate (position +. sh)
3525 then (
3526 state.mstate <- Mscrolly;
3527 Some (coe self)
3529 else
3530 let s = float (max 0 (y - conf.scrollh)) /. float conf.winh in
3531 let first = truncate (s *. float source#getitemcount) in
3532 let first = min source#getitemcount first in
3533 Some (coe {< m_first = first; m_active = first >})
3534 else (
3535 state.mstate <- Mnone;
3536 Some (coe self);
3538 | 1 when not down ->
3539 begin match self#elemunder y with
3540 | Some n ->
3541 G.postRedisplay "listview click";
3542 source#exit
3543 (coe {< m_active = n >}) false n m_first m_pan m_qsearch
3544 | _ ->
3545 Some (coe self)
3547 | n when (n == 4 || n == 5) && not down ->
3548 let len = source#getitemcount in
3549 let first =
3550 if n = 5 && m_first + fstate.maxrows >= len
3551 then
3552 m_first
3553 else
3554 let first = m_first + (if n == 4 then -1 else 1) in
3555 bound first 0 (len - 1)
3557 G.postRedisplay "listview wheel";
3558 Some (coe {< m_first = first >})
3559 | n when (n = 6 || n = 7) && not down ->
3560 let inc = m_first + (if n = 7 then -1 else 1) in
3561 G.postRedisplay "listview hwheel";
3562 Some (coe {< m_pan = m_pan + inc >})
3563 | _ ->
3564 Some (coe self)
3566 match opt with
3567 | None -> m_prev_uioh
3568 | Some uioh -> uioh
3570 method motion _ y =
3571 match state.mstate with
3572 | Mscrolly ->
3573 let s = float (max 0 (y - conf.scrollh)) /. float conf.winh in
3574 let first = truncate (s *. float source#getitemcount) in
3575 let first = min source#getitemcount first in
3576 G.postRedisplay "listview motion";
3577 coe {< m_first = first; m_active = first >}
3578 | _ -> coe self
3580 method pmotion x y =
3581 if x < conf.winw - conf.scrollbw
3582 then
3583 let n =
3584 match self#elemunder y with
3585 | None -> Wsi.setcursor Wsi.CURSOR_INHERIT; m_active
3586 | Some n -> Wsi.setcursor Wsi.CURSOR_INFO; n
3588 let o =
3589 if n != m_active
3590 then (G.postRedisplay "listview pmotion"; {< m_active = n >})
3591 else self
3593 coe o
3594 else (
3595 Wsi.setcursor Wsi.CURSOR_INHERIT;
3596 coe self
3599 method infochanged _ = ()
3601 method scrollpw = (0, 0.0, 0.0)
3602 method scrollph =
3603 let nfs = fstate.fontsize + 1 in
3604 let y = m_first * nfs in
3605 let itemcount = source#getitemcount in
3606 let maxi = max 0 (itemcount - fstate.maxrows) in
3607 let maxy = maxi * nfs in
3608 let p, h = scrollph y maxy in
3609 conf.scrollbw, p, h
3611 method modehash = modehash
3612 end;;
3614 class outlinelistview ~source =
3615 object (self)
3616 inherit listview
3617 ~source:(source :> lvsource)
3618 ~trusted:false
3619 ~modehash:(findkeyhash conf "outline")
3620 as super
3622 method key key mask =
3623 let calcfirst first active =
3624 if active > first
3625 then
3626 let rows = active - first in
3627 let maxrows =
3628 if String.length state.text = 0
3629 then fstate.maxrows
3630 else fstate.maxrows - 2
3632 if rows > maxrows then active - maxrows else first
3633 else active
3635 let navigate incr =
3636 let active = m_active + incr in
3637 let active = bound active 0 (source#getitemcount - 1) in
3638 let first = calcfirst m_first active in
3639 G.postRedisplay "outline navigate";
3640 coe {< m_active = active; m_first = first >}
3642 let ctrl = Wsi.withctrl mask in
3643 match key with
3644 | 110 when ctrl -> (* ctrl-n *)
3645 source#narrow m_qsearch;
3646 G.postRedisplay "outline ctrl-n";
3647 coe {< m_first = 0; m_active = 0 >}
3649 | 117 when ctrl -> (* ctrl-u *)
3650 source#denarrow;
3651 G.postRedisplay "outline ctrl-u";
3652 state.text <- "";
3653 coe {< m_first = 0; m_active = 0 >}
3655 | 108 when ctrl -> (* ctrl-l *)
3656 let first = max 0 (m_active - (fstate.maxrows / 2)) in
3657 G.postRedisplay "outline ctrl-l";
3658 coe {< m_first = first >}
3660 | 0xff9f | 0xffff -> (* (kp) delete *)
3661 source#remove m_active;
3662 G.postRedisplay "outline delete";
3663 let active = max 0 (m_active-1) in
3664 coe {< m_first = firstof m_first active;
3665 m_active = active >}
3667 | 0xff52 | 0xff97 -> navigate ~-1 (* (kp) up *)
3668 | 0xff54 | 0xff99 -> navigate 1 (* (kp) down *)
3669 | 0xff55 | 0xff9a -> (* (kp) prior *)
3670 navigate ~-(fstate.maxrows)
3671 | 0xff56 | 0xff9b -> (* (kp) next *)
3672 navigate fstate.maxrows
3674 | 0xff53 | 0xff98 -> (* [ctrl-] (kp) right *)
3675 let o =
3676 if ctrl
3677 then (
3678 G.postRedisplay "outline ctrl right";
3679 {< m_pan = m_pan + 1 >}
3681 else self#updownlevel 1
3683 coe o
3685 | 0xff51 | 0xff96 -> (* [ctrl-] (kp) left *)
3686 let o =
3687 if ctrl
3688 then (
3689 G.postRedisplay "outline ctrl left";
3690 {< m_pan = m_pan - 1 >}
3692 else self#updownlevel ~-1
3694 coe o
3696 | 0xff50 | 0xff95 -> (* (kp) home *)
3697 G.postRedisplay "outline home";
3698 coe {< m_first = 0; m_active = 0 >}
3700 | 0xff57 | 0xff9c -> (* (kp) end *)
3701 let active = source#getitemcount - 1 in
3702 let first = max 0 (active - fstate.maxrows) in
3703 G.postRedisplay "outline end";
3704 coe {< m_active = active; m_first = first >}
3706 | _ -> super#key key mask
3709 let outlinesource usebookmarks =
3710 let empty = [||] in
3711 (object
3712 inherit lvsourcebase
3713 val mutable m_items = empty
3714 val mutable m_orig_items = empty
3715 val mutable m_prev_items = empty
3716 val mutable m_narrow_pattern = ""
3717 val mutable m_hadremovals = false
3719 method getitemcount =
3720 Array.length m_items + (if m_hadremovals then 1 else 0)
3722 method getitem n =
3723 if n == Array.length m_items && m_hadremovals
3724 then
3725 ("[Confirm removal]", 0)
3726 else
3727 let s, n, _ = m_items.(n) in
3728 (s, n)
3730 method exit ~uioh ~cancel ~active ~first ~pan ~qsearch =
3731 ignore (uioh, first, qsearch);
3732 let confrimremoval = m_hadremovals && active = Array.length m_items in
3733 let items =
3734 if String.length m_narrow_pattern = 0
3735 then m_orig_items
3736 else m_items
3738 if not cancel
3739 then (
3740 if not confrimremoval
3741 then(
3742 let _, _, anchor = m_items.(active) in
3743 gotoghyll (getanchory anchor);
3744 m_items <- items;
3746 else (
3747 state.bookmarks <- Array.to_list m_items;
3748 m_orig_items <- m_items;
3751 else m_items <- items;
3752 m_pan <- pan;
3753 None
3755 method hasaction _ = true
3757 method greetmsg =
3758 if Array.length m_items != Array.length m_orig_items
3759 then "Narrowed to " ^ m_narrow_pattern ^ " (ctrl-u to restore)"
3760 else ""
3762 method narrow pattern =
3763 let reopt = try Some (Str.regexp_case_fold pattern) with _ -> None in
3764 match reopt with
3765 | None -> ()
3766 | Some re ->
3767 let rec loop accu n =
3768 if n = -1
3769 then (
3770 m_narrow_pattern <- pattern;
3771 m_items <- Array.of_list accu
3773 else
3774 let (s, _, _) as o = m_items.(n) in
3775 let accu =
3776 if (try ignore (Str.search_forward re s 0); true
3777 with Not_found -> false)
3778 then o :: accu
3779 else accu
3781 loop accu (n-1)
3783 loop [] (Array.length m_items - 1)
3785 method denarrow =
3786 m_orig_items <- (
3787 if usebookmarks
3788 then Array.of_list state.bookmarks
3789 else state.outlines
3791 m_items <- m_orig_items
3793 method remove m =
3794 if usebookmarks
3795 then
3796 if m >= 0 && m < Array.length m_items
3797 then (
3798 m_hadremovals <- true;
3799 m_items <- Array.init (Array.length m_items - 1) (fun n ->
3800 let n = if n >= m then n+1 else n in
3801 m_items.(n)
3805 method reset anchor items =
3806 m_hadremovals <- false;
3807 if m_orig_items == empty || m_prev_items != items
3808 then (
3809 m_orig_items <- items;
3810 if String.length m_narrow_pattern = 0
3811 then m_items <- items;
3813 m_prev_items <- items;
3814 let rely = getanchory anchor in
3815 let active =
3816 let rec loop n best bestd =
3817 if n = Array.length m_items
3818 then best
3819 else
3820 let (_, _, anchor) = m_items.(n) in
3821 let orely = getanchory anchor in
3822 let d = abs (orely - rely) in
3823 if d < bestd
3824 then loop (n+1) n d
3825 else loop (n+1) best bestd
3827 loop 0 ~-1 max_int
3829 m_active <- active;
3830 m_first <- firstof m_first active
3831 end)
3834 let enterselector usebookmarks =
3835 let source = outlinesource usebookmarks in
3836 fun errmsg ->
3837 let outlines =
3838 if usebookmarks
3839 then Array.of_list state.bookmarks
3840 else state.outlines
3842 if Array.length outlines = 0
3843 then (
3844 showtext ' ' errmsg;
3846 else (
3847 state.text <- source#greetmsg;
3848 Wsi.setcursor Wsi.CURSOR_INHERIT;
3849 let anchor = getanchor () in
3850 source#reset anchor outlines;
3851 state.uioh <- coe (new outlinelistview ~source);
3852 G.postRedisplay "enter selector";
3856 let enteroutlinemode =
3857 let f = enterselector false in
3858 fun ()-> f "Document has no outline";
3861 let enterbookmarkmode =
3862 let f = enterselector true in
3863 fun () -> f "Document has no bookmarks (yet)";
3866 let color_of_string s =
3867 Scanf.sscanf s "%d/%d/%d" (fun r g b ->
3868 (float r /. 256.0, float g /. 256.0, float b /. 256.0)
3872 let color_to_string (r, g, b) =
3873 let r = truncate (r *. 256.0)
3874 and g = truncate (g *. 256.0)
3875 and b = truncate (b *. 256.0) in
3876 Printf.sprintf "%d/%d/%d" r g b
3879 let irect_of_string s =
3880 Scanf.sscanf s "%d/%d/%d/%d" (fun x0 y0 x1 y1 -> (x0,y0,x1,y1))
3883 let irect_to_string (x0,y0,x1,y1) =
3884 Printf.sprintf "%d/%d/%d/%d" x0 y0 x1 y1
3887 let makecheckers () =
3888 (* Appropriated from lablGL-1.04/LablGlut/examples/lablGL/checker.ml which had
3889 following to say:
3890 converted by Issac Trotts. July 25, 2002 *)
3891 let image = GlPix.create `ubyte ~format:`luminance ~width:2 ~height:2 in
3892 Raw.sets_string (GlPix.to_raw image) ~pos:0 "\255\200\200\255";
3893 let id = GlTex.gen_texture () in
3894 GlTex.bind_texture `texture_2d id;
3895 GlPix.store (`unpack_alignment 1);
3896 GlTex.image2d image;
3897 List.iter (GlTex.parameter ~target:`texture_2d)
3898 [ `wrap_s `repeat;
3899 `wrap_t `repeat;
3900 `mag_filter `nearest;
3901 `min_filter `nearest ];
3905 let setcheckers enabled =
3906 match state.texid with
3907 | None ->
3908 if enabled then state.texid <- Some (makecheckers ())
3910 | Some texid ->
3911 if not enabled
3912 then (
3913 GlTex.delete_texture texid;
3914 state.texid <- None;
3918 let int_of_string_with_suffix s =
3919 let l = String.length s in
3920 let s1, shift =
3921 if l > 1
3922 then
3923 let suffix = Char.lowercase s.[l-1] in
3924 match suffix with
3925 | 'k' -> String.sub s 0 (l-1), 10
3926 | 'm' -> String.sub s 0 (l-1), 20
3927 | 'g' -> String.sub s 0 (l-1), 30
3928 | _ -> s, 0
3929 else s, 0
3931 let n = int_of_string s1 in
3932 let m = n lsl shift in
3933 if m < 0 || m < n
3934 then raise (Failure "value too large")
3935 else m
3938 let string_with_suffix_of_int n =
3939 if n = 0
3940 then "0"
3941 else
3942 let n, s =
3943 if n land ((1 lsl 30) - 1) = 0
3944 then n lsr 30, "G"
3945 else (
3946 if n land ((1 lsl 20) - 1) = 0
3947 then n lsr 20, "M"
3948 else (
3949 if n land ((1 lsl 10) - 1) = 0
3950 then n lsr 10, "K"
3951 else n, ""
3955 let rec loop s n =
3956 let h = n mod 1000 in
3957 let n = n / 1000 in
3958 if n = 0
3959 then string_of_int h ^ s
3960 else (
3961 let s = Printf.sprintf "_%03d%s" h s in
3962 loop s n
3965 loop "" n ^ s;
3968 let defghyllscroll = (40, 8, 32);;
3969 let ghyllscroll_of_string s =
3970 let (n, a, b) as nab =
3971 if s = "default"
3972 then defghyllscroll
3973 else Scanf.sscanf s "%u,%u,%u" (fun n a b -> n, a, b)
3975 if n <= a || n <= b || a >= b
3976 then failwith "invalid ghyll N,A,B (N <= A, A < B, N <= B)";
3977 nab;
3980 let ghyllscroll_to_string ((n, a, b) as nab) =
3981 if nab = defghyllscroll
3982 then "default"
3983 else Printf.sprintf "%d,%d,%d" n a b;
3986 let describe_location () =
3987 let f (fn, _) l =
3988 if fn = -1 then l.pageno, l.pageno else fn, l.pageno
3990 let fn, ln = List.fold_left f (-1, -1) state.layout in
3991 let maxy = state.maxy - (if conf.maxhfit then conf.winh else 0) in
3992 let percent =
3993 if maxy <= 0
3994 then 100.
3995 else (100. *. (float state.y /. float maxy))
3997 if fn = ln
3998 then
3999 Printf.sprintf "page %d of %d [%.2f%%]"
4000 (fn+1) state.pagecount percent
4001 else
4002 Printf.sprintf
4003 "pages %d-%d of %d [%.2f%%]"
4004 (fn+1) (ln+1) state.pagecount percent
4007 let setpresentationmode v =
4008 let (n, _, _) = getanchor () in
4009 let _, h = getpageyh n in
4010 let ips = if conf.presentation then calcips h else conf.interpagespace in
4011 state.anchor <- (n, 0.0, float ips);
4012 conf.presentation <- v;
4013 if conf.presentation
4014 then (
4015 if not conf.scrollbarinpm
4016 then state.scrollw <- 0;
4018 else state.scrollw <- conf.scrollbw;
4019 represent ();
4022 let enterinfomode =
4023 let btos b = if b then "\xe2\x88\x9a" else "" in
4024 let showextended = ref false in
4025 let leave mode = function
4026 | Confirm -> state.mode <- mode
4027 | Cancel -> state.mode <- mode in
4028 let src =
4029 (object
4030 val mutable m_first_time = true
4031 val mutable m_l = []
4032 val mutable m_a = [||]
4033 val mutable m_prev_uioh = nouioh
4034 val mutable m_prev_mode = View
4036 inherit lvsourcebase
4038 method reset prev_mode prev_uioh =
4039 m_a <- Array.of_list (List.rev m_l);
4040 m_l <- [];
4041 m_prev_mode <- prev_mode;
4042 m_prev_uioh <- prev_uioh;
4043 if m_first_time
4044 then (
4045 let rec loop n =
4046 if n >= Array.length m_a
4047 then ()
4048 else
4049 match m_a.(n) with
4050 | _, _, _, Action _ -> m_active <- n
4051 | _ -> loop (n+1)
4053 loop 0;
4054 m_first_time <- false;
4057 method int name get set =
4058 m_l <-
4059 (name, `int get, 1, Action (
4060 fun u ->
4061 let ondone s =
4062 try set (int_of_string s)
4063 with exn ->
4064 state.text <- Printf.sprintf "bad integer `%s': %s"
4065 s (Printexc.to_string exn)
4067 state.text <- "";
4068 let te = name ^ ": ", "", None, intentry, ondone, true in
4069 state.mode <- Textentry (te, leave m_prev_mode);
4071 )) :: m_l
4073 method int_with_suffix name get set =
4074 m_l <-
4075 (name, `intws get, 1, Action (
4076 fun u ->
4077 let ondone s =
4078 try set (int_of_string_with_suffix s)
4079 with exn ->
4080 state.text <- Printf.sprintf "bad integer `%s': %s"
4081 s (Printexc.to_string exn)
4083 state.text <- "";
4084 let te =
4085 name ^ ": ", "", None, intentry_with_suffix, ondone, true
4087 state.mode <- Textentry (te, leave m_prev_mode);
4089 )) :: m_l
4091 method bool ?(offset=1) ?(btos=btos) name get set =
4092 m_l <-
4093 (name, `bool (btos, get), offset, Action (
4094 fun u ->
4095 let v = get () in
4096 set (not v);
4098 )) :: m_l
4100 method color name get set =
4101 m_l <-
4102 (name, `color get, 1, Action (
4103 fun u ->
4104 let invalid = (nan, nan, nan) in
4105 let ondone s =
4106 let c =
4107 try color_of_string s
4108 with exn ->
4109 state.text <- Printf.sprintf "bad color `%s': %s"
4110 s (Printexc.to_string exn);
4111 invalid
4113 if c <> invalid
4114 then set c;
4116 let te = name ^ ": ", "", None, textentry, ondone, true in
4117 state.text <- color_to_string (get ());
4118 state.mode <- Textentry (te, leave m_prev_mode);
4120 )) :: m_l
4122 method string name get set =
4123 m_l <-
4124 (name, `string get, 1, Action (
4125 fun u ->
4126 let ondone s = set s in
4127 let te = name ^ ": ", "", None, textentry, ondone, true in
4128 state.mode <- Textentry (te, leave m_prev_mode);
4130 )) :: m_l
4132 method colorspace name get set =
4133 m_l <-
4134 (name, `string get, 1, Action (
4135 fun _ ->
4136 let source =
4137 let vals = [| "rgb"; "bgr"; "gray" |] in
4138 (object
4139 inherit lvsourcebase
4141 initializer
4142 m_active <- int_of_colorspace conf.colorspace;
4143 m_first <- 0;
4145 method getitemcount = Array.length vals
4146 method getitem n = (vals.(n), 0)
4147 method exit ~uioh ~cancel ~active ~first ~pan ~qsearch =
4148 ignore (uioh, first, pan, qsearch);
4149 if not cancel then set active;
4150 None
4151 method hasaction _ = true
4152 end)
4154 state.text <- "";
4155 let modehash = findkeyhash conf "info" in
4156 coe (new listview ~source ~trusted:true ~modehash)
4157 )) :: m_l
4159 method caption s offset =
4160 m_l <- (s, `empty, offset, Noaction) :: m_l
4162 method caption2 s f offset =
4163 m_l <- (s, `string f, offset, Noaction) :: m_l
4165 method getitemcount = Array.length m_a
4167 method getitem n =
4168 let tostr = function
4169 | `int f -> string_of_int (f ())
4170 | `intws f -> string_with_suffix_of_int (f ())
4171 | `string f -> f ()
4172 | `color f -> color_to_string (f ())
4173 | `bool (btos, f) -> btos (f ())
4174 | `empty -> ""
4176 let name, t, offset, _ = m_a.(n) in
4177 ((let s = tostr t in
4178 if String.length s > 0
4179 then Printf.sprintf "%s\t%s" name s
4180 else name),
4181 offset)
4183 method exit ~uioh ~cancel ~active ~first ~pan ~qsearch =
4184 let uiohopt =
4185 if not cancel
4186 then (
4187 m_qsearch <- qsearch;
4188 let uioh =
4189 match m_a.(active) with
4190 | _, _, _, Action f -> f uioh
4191 | _ -> uioh
4193 Some uioh
4195 else None
4197 m_active <- active;
4198 m_first <- first;
4199 m_pan <- pan;
4200 uiohopt
4202 method hasaction n =
4203 match m_a.(n) with
4204 | _, _, _, Action _ -> true
4205 | _ -> false
4206 end)
4208 let rec fillsrc prevmode prevuioh =
4209 let sep () = src#caption "" 0 in
4210 let colorp name get set =
4211 src#string name
4212 (fun () -> color_to_string (get ()))
4213 (fun v ->
4215 let c = color_of_string v in
4216 set c
4217 with exn ->
4218 state.text <- Printf.sprintf "bad color `%s': %s"
4219 v (Printexc.to_string exn);
4222 let oldmode = state.mode in
4223 let birdseye = isbirdseye state.mode in
4225 src#caption (if birdseye then "Setup (Bird's eye)" else "Setup") 0;
4227 src#bool "presentation mode"
4228 (fun () -> conf.presentation)
4229 (fun v -> setpresentationmode v);
4231 src#bool "ignore case in searches"
4232 (fun () -> conf.icase)
4233 (fun v -> conf.icase <- v);
4235 src#bool "preload"
4236 (fun () -> conf.preload)
4237 (fun v -> conf.preload <- v);
4239 src#bool "highlight links"
4240 (fun () -> conf.hlinks)
4241 (fun v -> conf.hlinks <- v);
4243 src#bool "under info"
4244 (fun () -> conf.underinfo)
4245 (fun v -> conf.underinfo <- v);
4247 src#bool "persistent bookmarks"
4248 (fun () -> conf.savebmarks)
4249 (fun v -> conf.savebmarks <- v);
4251 src#bool "proportional display"
4252 (fun () -> conf.proportional)
4253 (fun v -> reqlayout conf.angle v);
4255 src#bool "trim margins"
4256 (fun () -> conf.trimmargins)
4257 (fun v -> settrim v conf.trimfuzz; fillsrc prevmode prevuioh);
4259 src#bool "persistent location"
4260 (fun () -> conf.jumpback)
4261 (fun v -> conf.jumpback <- v);
4263 sep ();
4264 src#int "inter-page space"
4265 (fun () -> conf.interpagespace)
4266 (fun n ->
4267 conf.interpagespace <- n;
4268 docolumns conf.columns;
4269 let pageno, py =
4270 match state.layout with
4271 | [] -> 0, 0
4272 | l :: _ ->
4273 l.pageno, l.pagey
4275 state.maxy <- calcheight ();
4276 let y = getpagey pageno in
4277 gotoy (y + py)
4280 src#int "page bias"
4281 (fun () -> conf.pagebias)
4282 (fun v -> conf.pagebias <- v);
4284 src#int "scroll step"
4285 (fun () -> conf.scrollstep)
4286 (fun n -> conf.scrollstep <- n);
4288 src#int "horizontal scroll step"
4289 (fun () -> conf.hscrollstep)
4290 (fun v -> conf.hscrollstep <- v);
4292 src#int "auto scroll step"
4293 (fun () ->
4294 match state.autoscroll with
4295 | Some step -> step
4296 | _ -> conf.autoscrollstep)
4297 (fun n ->
4298 if state.autoscroll <> None
4299 then state.autoscroll <- Some n;
4300 conf.autoscrollstep <- n);
4302 src#int "zoom"
4303 (fun () -> truncate (conf.zoom *. 100.))
4304 (fun v -> setzoom ((float v) /. 100.));
4306 src#int "rotation"
4307 (fun () -> conf.angle)
4308 (fun v -> reqlayout v conf.proportional);
4310 src#int "scroll bar width"
4311 (fun () -> state.scrollw)
4312 (fun v ->
4313 state.scrollw <- v;
4314 conf.scrollbw <- v;
4315 reshape conf.winw conf.winh;
4318 src#int "scroll handle height"
4319 (fun () -> conf.scrollh)
4320 (fun v -> conf.scrollh <- v;);
4322 src#int "thumbnail width"
4323 (fun () -> conf.thumbw)
4324 (fun v ->
4325 conf.thumbw <- min 4096 v;
4326 match oldmode with
4327 | Birdseye beye ->
4328 leavebirdseye beye false;
4329 enterbirdseye ()
4330 | _ -> ()
4333 let mode = state.mode in
4334 src#string "columns"
4335 (fun () ->
4336 match conf.columns with
4337 | Csingle _ -> "1"
4338 | Cmulti (multi, _) -> multicolumns_to_string multi
4339 | Csplit (count, _) -> "-" ^ string_of_int count
4341 (fun v ->
4342 let n, a, b = multicolumns_of_string v in
4343 setcolumns mode n a b);
4345 sep ();
4346 src#caption "Presentation mode" 0;
4347 src#bool "scrollbar visible"
4348 (fun () -> conf.scrollbarinpm)
4349 (fun v ->
4350 if v != conf.scrollbarinpm
4351 then (
4352 conf.scrollbarinpm <- v;
4353 if conf.presentation
4354 then (
4355 state.scrollw <- if v then conf.scrollbw else 0;
4356 reshape conf.winw conf.winh;
4361 sep ();
4362 src#caption "Pixmap cache" 0;
4363 src#int_with_suffix "size (advisory)"
4364 (fun () -> conf.memlimit)
4365 (fun v -> conf.memlimit <- v);
4367 src#caption2 "used"
4368 (fun () -> Printf.sprintf "%s bytes, %d tiles"
4369 (string_with_suffix_of_int state.memused)
4370 (Hashtbl.length state.tilemap)) 1;
4372 sep ();
4373 src#caption "Layout" 0;
4374 src#caption2 "Dimension"
4375 (fun () ->
4376 Printf.sprintf "%dx%d (virtual %dx%d)"
4377 conf.winw conf.winh
4378 state.w state.maxy)
4380 if conf.debug
4381 then
4382 src#caption2 "Position" (fun () ->
4383 Printf.sprintf "%dx%d" state.x state.y
4385 else
4386 src#caption2 "Visible" (fun () -> describe_location ()) 1
4389 sep ();
4390 src#bool ~offset:0 ~btos:(fun v -> if v then "(on)" else "(off)")
4391 "Save these parameters as global defaults at exit"
4392 (fun () -> conf.bedefault)
4393 (fun v -> conf.bedefault <- v)
4396 sep ();
4397 let btos b = if b then "\xc2\xab" else "\xc2\xbb" in
4398 src#bool ~offset:0 ~btos "Extended parameters"
4399 (fun () -> !showextended)
4400 (fun v -> showextended := v; fillsrc prevmode prevuioh);
4401 if !showextended
4402 then (
4403 src#bool "checkers"
4404 (fun () -> conf.checkers)
4405 (fun v -> conf.checkers <- v; setcheckers v);
4406 src#bool "update cursor"
4407 (fun () -> conf.updatecurs)
4408 (fun v -> conf.updatecurs <- v);
4409 src#bool "verbose"
4410 (fun () -> conf.verbose)
4411 (fun v -> conf.verbose <- v);
4412 src#bool "invert colors"
4413 (fun () -> conf.invert)
4414 (fun v -> conf.invert <- v);
4415 src#bool "max fit"
4416 (fun () -> conf.maxhfit)
4417 (fun v -> conf.maxhfit <- v);
4418 src#bool "redirect stderr"
4419 (fun () -> conf.redirectstderr)
4420 (fun v -> conf.redirectstderr <- v; redirectstderr ());
4421 src#string "uri launcher"
4422 (fun () -> conf.urilauncher)
4423 (fun v -> conf.urilauncher <- v);
4424 src#string "path launcher"
4425 (fun () -> conf.pathlauncher)
4426 (fun v -> conf.pathlauncher <- v);
4427 src#string "tile size"
4428 (fun () -> Printf.sprintf "%dx%d" conf.tilew conf.tileh)
4429 (fun v ->
4431 let w, h = Scanf.sscanf v "%dx%d" (fun w h -> w, h) in
4432 conf.tilew <- max 64 w;
4433 conf.tileh <- max 64 h;
4434 flushtiles ();
4435 with exn ->
4436 state.text <- Printf.sprintf "bad tile size `%s': %s"
4437 v (Printexc.to_string exn));
4438 src#int "texture count"
4439 (fun () -> conf.texcount)
4440 (fun v ->
4441 if realloctexts v
4442 then conf.texcount <- v
4443 else showtext '!' " Failed to set texture count please retry later"
4445 src#int "slice height"
4446 (fun () -> conf.sliceheight)
4447 (fun v ->
4448 conf.sliceheight <- v;
4449 wcmd "sliceh %d" conf.sliceheight;
4451 src#int "anti-aliasing level"
4452 (fun () -> conf.aalevel)
4453 (fun v ->
4454 conf.aalevel <- bound v 0 8;
4455 state.anchor <- getanchor ();
4456 opendoc state.path state.password;
4458 src#string "page scroll scaling factor"
4459 (fun () -> string_of_float conf.pgscale)
4460 (fun v ->
4462 let s = float_of_string v in
4463 conf.pgscale <- s
4464 with exn ->
4465 state.text <- Printf.sprintf
4466 "bad page scroll scaling factor `%s': %s"
4467 v (Printexc.to_string exn)
4470 src#int "ui font size"
4471 (fun () -> fstate.fontsize)
4472 (fun v -> setfontsize (bound v 5 100));
4473 src#int "hint font size"
4474 (fun () -> conf.hfsize)
4475 (fun v -> conf.hfsize <- bound v 5 100);
4476 colorp "background color"
4477 (fun () -> conf.bgcolor)
4478 (fun v -> conf.bgcolor <- v);
4479 src#bool "crop hack"
4480 (fun () -> conf.crophack)
4481 (fun v -> conf.crophack <- v);
4482 src#string "trim fuzz"
4483 (fun () -> irect_to_string conf.trimfuzz)
4484 (fun v ->
4486 conf.trimfuzz <- irect_of_string v;
4487 if conf.trimmargins
4488 then settrim true conf.trimfuzz;
4489 with exn ->
4490 state.text <- Printf.sprintf "bad irect `%s': %s"
4491 v (Printexc.to_string exn)
4493 src#string "throttle"
4494 (fun () ->
4495 match conf.maxwait with
4496 | None -> "show place holder if page is not ready"
4497 | Some time ->
4498 if time = infinity
4499 then "wait for page to fully render"
4500 else
4501 "wait " ^ string_of_float time
4502 ^ " seconds before showing placeholder"
4504 (fun v ->
4506 let f = float_of_string v in
4507 if f <= 0.0
4508 then conf.maxwait <- None
4509 else conf.maxwait <- Some f
4510 with exn ->
4511 state.text <- Printf.sprintf "bad time `%s': %s"
4512 v (Printexc.to_string exn)
4514 src#string "ghyll scroll"
4515 (fun () ->
4516 match conf.ghyllscroll with
4517 | None -> ""
4518 | Some nab -> ghyllscroll_to_string nab
4520 (fun v ->
4522 let gs =
4523 if String.length v = 0
4524 then None
4525 else Some (ghyllscroll_of_string v)
4527 conf.ghyllscroll <- gs
4528 with exn ->
4529 state.text <- Printf.sprintf "bad ghyll `%s': %s"
4530 v (Printexc.to_string exn)
4532 src#string "selection command"
4533 (fun () -> conf.selcmd)
4534 (fun v -> conf.selcmd <- v);
4535 src#colorspace "color space"
4536 (fun () -> colorspace_to_string conf.colorspace)
4537 (fun v ->
4538 conf.colorspace <- colorspace_of_int v;
4539 wcmd "cs %d" v;
4540 load state.layout;
4542 if pbousable ()
4543 then
4544 src#bool "use PBO"
4545 (fun () -> conf.usepbo)
4546 (fun v -> conf.usepbo <- v);
4547 src#bool "mouse wheel scrolls pages"
4548 (fun () -> conf.wheelbypage)
4549 (fun v -> conf.wheelbypage <- v);
4552 sep ();
4553 src#caption "Document" 0;
4554 List.iter (fun (_, s) -> src#caption s 1) state.docinfo;
4555 src#caption2 "Pages"
4556 (fun () -> string_of_int state.pagecount) 1;
4557 src#caption2 "Dimensions"
4558 (fun () -> string_of_int (List.length state.pdims)) 1;
4559 if conf.trimmargins
4560 then (
4561 sep ();
4562 src#caption "Trimmed margins" 0;
4563 src#caption2 "Dimensions"
4564 (fun () -> string_of_int (List.length state.pdims)) 1;
4567 sep ();
4568 src#caption "OpenGL" 0;
4569 src#caption (Printf.sprintf "Vendor\t%s" (GlMisc.get_string `vendor)) 1;
4570 src#caption (Printf.sprintf "Renderer\t%s" (GlMisc.get_string `renderer)) 1;
4571 src#reset prevmode prevuioh;
4573 fun () ->
4574 state.text <- "";
4575 let prevmode = state.mode
4576 and prevuioh = state.uioh in
4577 fillsrc prevmode prevuioh;
4578 let source = (src :> lvsource) in
4579 let modehash = findkeyhash conf "info" in
4580 state.uioh <- coe (object (self)
4581 inherit listview ~source ~trusted:true ~modehash as super
4582 val mutable m_prevmemused = 0
4583 method infochanged = function
4584 | Memused ->
4585 if m_prevmemused != state.memused
4586 then (
4587 m_prevmemused <- state.memused;
4588 G.postRedisplay "memusedchanged";
4590 | Pdim -> G.postRedisplay "pdimchanged"
4591 | Docinfo -> fillsrc prevmode prevuioh
4593 method key key mask =
4594 if not (Wsi.withctrl mask)
4595 then
4596 match key with
4597 | 0xff51 | 0xff96 -> coe (self#updownlevel ~-1) (* (kp) left *)
4598 | 0xff53 | 0xff98 -> coe (self#updownlevel 1) (* (kp) right *)
4599 | _ -> super#key key mask
4600 else super#key key mask
4601 end);
4602 G.postRedisplay "info";
4605 let enterhelpmode =
4606 let source =
4607 (object
4608 inherit lvsourcebase
4609 method getitemcount = Array.length state.help
4610 method getitem n =
4611 let s, l, _ = state.help.(n) in
4612 (s, l)
4614 method exit ~uioh ~cancel ~active ~first ~pan ~qsearch =
4615 let optuioh =
4616 if not cancel
4617 then (
4618 m_qsearch <- qsearch;
4619 match state.help.(active) with
4620 | _, _, Action f -> Some (f uioh)
4621 | _ -> Some (uioh)
4623 else None
4625 m_active <- active;
4626 m_first <- first;
4627 m_pan <- pan;
4628 optuioh
4630 method hasaction n =
4631 match state.help.(n) with
4632 | _, _, Action _ -> true
4633 | _ -> false
4635 initializer
4636 m_active <- -1
4637 end)
4638 in fun () ->
4639 let modehash = findkeyhash conf "help" in
4640 state.uioh <- coe (new listview ~source ~trusted:true ~modehash);
4641 G.postRedisplay "help";
4644 let entermsgsmode =
4645 let msgsource =
4646 let re = Str.regexp "[\r\n]" in
4647 (object
4648 inherit lvsourcebase
4649 val mutable m_items = [||]
4651 method getitemcount = 1 + Array.length m_items
4653 method getitem n =
4654 if n = 0
4655 then "[Clear]", 0
4656 else m_items.(n-1), 0
4658 method exit ~uioh ~cancel ~active ~first ~pan ~qsearch =
4659 ignore uioh;
4660 if not cancel
4661 then (
4662 if active = 0
4663 then Buffer.clear state.errmsgs;
4664 m_qsearch <- qsearch;
4666 m_active <- active;
4667 m_first <- first;
4668 m_pan <- pan;
4669 None
4671 method hasaction n =
4672 n = 0
4674 method reset =
4675 state.newerrmsgs <- false;
4676 let l = Str.split re (Buffer.contents state.errmsgs) in
4677 m_items <- Array.of_list l
4679 initializer
4680 m_active <- 0
4681 end)
4682 in fun () ->
4683 state.text <- "";
4684 msgsource#reset;
4685 let source = (msgsource :> lvsource) in
4686 let modehash = findkeyhash conf "listview" in
4687 state.uioh <- coe (object
4688 inherit listview ~source ~trusted:false ~modehash as super
4689 method display =
4690 if state.newerrmsgs
4691 then msgsource#reset;
4692 super#display
4693 end);
4694 G.postRedisplay "msgs";
4697 let quickbookmark ?title () =
4698 match state.layout with
4699 | [] -> ()
4700 | l :: _ ->
4701 let title =
4702 match title with
4703 | None ->
4704 let sec = Unix.gettimeofday () in
4705 let tm = Unix.localtime sec in
4706 Printf.sprintf "Quick (page %d) (bookmarked at %d/%d/%d %d:%d)"
4707 (l.pageno+1)
4708 tm.Unix.tm_mday
4709 tm.Unix.tm_mon
4710 (tm.Unix.tm_year + 1900)
4711 tm.Unix.tm_hour
4712 tm.Unix.tm_min
4713 | Some title -> title
4715 state.bookmarks <- (title, 0, getanchor1 l) :: state.bookmarks
4718 let doreshape w h =
4719 state.fullscreen <- None;
4720 Wsi.reshape w h;
4723 let setautoscrollspeed step goingdown =
4724 let incr = max 1 ((abs step) / 2) in
4725 let incr = if goingdown then incr else -incr in
4726 let astep = step + incr in
4727 state.autoscroll <- Some astep;
4730 let gotounder = function
4731 | Ulinkgoto (pageno, top) ->
4732 if pageno >= 0
4733 then (
4734 addnav ();
4735 gotopage1 pageno top;
4738 | Ulinkuri s ->
4739 gotouri s
4741 | Uremote (filename, pageno) ->
4742 let path =
4743 if Sys.file_exists filename
4744 then filename
4745 else
4746 let dir = Filename.dirname state.path in
4747 let path = Filename.concat dir filename in
4748 if Sys.file_exists path
4749 then path
4750 else ""
4752 if String.length path > 0
4753 then (
4754 let anchor = getanchor () in
4755 let ranchor = state.path, state.password, anchor in
4756 state.anchor <- (pageno, 0.0, 0.0);
4757 state.ranchors <- ranchor :: state.ranchors;
4758 opendoc path "";
4760 else showtext '!' ("Could not find " ^ filename)
4762 | Uunexpected _ | Ulaunch _ | Unamed _ | Utext _ | Unone -> ()
4765 let canpan () =
4766 match conf.columns with
4767 | Csplit _ -> true
4768 | _ -> conf.zoom > 1.0
4771 let existsinrow pageno (columns, coverA, coverB) p =
4772 let last = ((pageno - coverA) mod columns) + columns in
4773 let rec any = function
4774 | [] -> false
4775 | l :: rest ->
4776 if l.pageno = coverA - 1 || l.pageno = state.pagecount - coverB
4777 then p l
4778 else (
4779 if not (p l)
4780 then (if l.pageno = last then false else any rest)
4781 else true
4784 any state.layout
4787 let nextpage () =
4788 match state.layout with
4789 | [] -> ()
4790 | l :: rest ->
4791 match conf.columns with
4792 | Csingle _ ->
4793 if conf.presentation && rest == [] && l.pageh > l.pagey + l.pagevh
4794 then
4795 let y = clamp (pgscale conf.winh) in
4796 gotoghyll y
4797 else
4798 let pageno = min (l.pageno+1) (state.pagecount-1) in
4799 gotoghyll (getpagey pageno)
4800 | Cmulti ((c, _, _) as cl, _) ->
4801 if conf.presentation
4802 && (existsinrow l.pageno cl
4803 (fun l -> l.pageh > l.pagey + l.pagevh))
4804 then
4805 let y = clamp (pgscale conf.winh) in
4806 gotoghyll y
4807 else
4808 let pageno = min (l.pageno+c) (state.pagecount-1) in
4809 gotoghyll (getpagey pageno)
4810 | Csplit (n, _) ->
4811 if l.pageno < state.pagecount - 1 || l.pagecol < n - 1
4812 then
4813 let pagey, pageh = getpageyh l.pageno in
4814 let pagey = pagey + pageh * l.pagecol in
4815 let ips = if l.pagecol = 0 then 0 else conf.interpagespace in
4816 gotoghyll (pagey + pageh + ips)
4819 let prevpage () =
4820 match state.layout with
4821 | [] -> ()
4822 | l :: _ ->
4823 match conf.columns with
4824 | Csingle _ ->
4825 if conf.presentation && l.pagey != 0
4826 then
4827 gotoghyll (clamp (pgscale ~-(conf.winh)))
4828 else
4829 let pageno = max 0 (l.pageno-1) in
4830 gotoghyll (getpagey pageno)
4831 | Cmulti ((c, _, coverB) as cl, _) ->
4832 if conf.presentation &&
4833 (existsinrow l.pageno cl (fun l -> l.pagey != 0))
4834 then
4835 gotoghyll (clamp (pgscale ~-(conf.winh)))
4836 else
4837 let decr =
4838 if l.pageno = state.pagecount - coverB
4839 then 1
4840 else c
4842 let pageno = max 0 (l.pageno-decr) in
4843 gotoghyll (getpagey pageno)
4844 | Csplit (n, _) ->
4845 let y =
4846 if l.pagecol = 0
4847 then
4848 if l.pageno = 0
4849 then l.pagey
4850 else
4851 let pageno = max 0 (l.pageno-1) in
4852 let pagey, pageh = getpageyh pageno in
4853 pagey + (n-1)*pageh
4854 else
4855 let pagey, pageh = getpageyh l.pageno in
4856 pagey + pageh * (l.pagecol-1) - conf.interpagespace
4858 gotoghyll y
4861 let viewkeyboard key mask =
4862 let enttext te =
4863 let mode = state.mode in
4864 state.mode <- Textentry (te, fun _ -> state.mode <- mode);
4865 state.text <- "";
4866 enttext ();
4867 G.postRedisplay "view:enttext"
4869 let ctrl = Wsi.withctrl mask in
4870 let key =
4871 if key >= 0xffb0 && key < 0xffb9 then key - 0xffb0 + 48 else key
4873 match key with
4874 | 81 -> (* Q *)
4875 exit 0
4877 | 0xff63 -> (* insert *)
4878 if conf.angle mod 360 = 0 && not (isbirdseye state.mode)
4879 then (
4880 state.mode <- LinkNav (Ltgendir 0);
4881 gotoy state.y;
4883 else showtext '!' "Keyboard link navigation does not work under rotation"
4885 | 0xff1b | 113 -> (* escape / q *)
4886 begin match state.mstate with
4887 | Mzoomrect _ ->
4888 state.mstate <- Mnone;
4889 Wsi.setcursor Wsi.CURSOR_INHERIT;
4890 G.postRedisplay "kill zoom rect";
4891 | _ ->
4892 begin match state.mode with
4893 | LinkNav _ ->
4894 state.mode <- View;
4895 G.postRedisplay "esc leave linknav"
4896 | _ ->
4897 match state.ranchors with
4898 | [] -> raise Quit
4899 | (path, password, anchor) :: rest ->
4900 state.ranchors <- rest;
4901 state.anchor <- anchor;
4902 opendoc path password
4903 end;
4904 end;
4906 | 0xff08 -> (* backspace *)
4907 gotoghyll (getnav ~-1)
4909 | 111 -> (* o *)
4910 enteroutlinemode ()
4912 | 117 -> (* u *)
4913 state.rects <- [];
4914 state.text <- "";
4915 G.postRedisplay "dehighlight";
4917 | 47 | 63 -> (* / ? *)
4918 let ondone isforw s =
4919 cbput state.hists.pat s;
4920 state.searchpattern <- s;
4921 search s isforw
4923 let s = String.create 1 in
4924 s.[0] <- Char.chr key;
4925 enttext (s, "", Some (onhist state.hists.pat),
4926 textentry, ondone (key = 47), true)
4928 | 43 | 0xffab | 61 when ctrl -> (* ctrl-+ or ctrl-= *)
4929 let incr = if conf.zoom +. 0.01 > 0.1 then 0.1 else 0.01 in
4930 setzoom (conf.zoom +. incr)
4932 | 43 | 0xffab -> (* + *)
4933 let ondone s =
4934 let n =
4935 try int_of_string s with exc ->
4936 state.text <- Printf.sprintf "bad integer `%s': %s"
4937 s (Printexc.to_string exc);
4938 max_int
4940 if n != max_int
4941 then (
4942 conf.pagebias <- n;
4943 state.text <- "page bias is now " ^ string_of_int n;
4946 enttext ("page bias: ", "", None, intentry, ondone, true)
4948 | 45 | 0xffad when ctrl -> (* ctrl-- *)
4949 let decr = if conf.zoom -. 0.1 < 0.1 then 0.01 else 0.1 in
4950 setzoom (max 0.01 (conf.zoom -. decr))
4952 | 45 | 0xffad -> (* - *)
4953 let ondone msg = state.text <- msg in
4954 enttext (
4955 "option [acfhilpstvxACFPRSZTIS]: ", "", None,
4956 optentry state.mode, ondone, true
4959 | 48 when ctrl -> (* ctrl-0 *)
4960 setzoom 1.0
4962 | 49 when ctrl -> (* ctrl-1 *)
4963 let cols =
4964 match conf.columns with
4965 | Csingle _ | Cmulti _ -> 1
4966 | Csplit (n, _) -> n
4968 let zoom = zoomforh conf.winw conf.winh state.scrollw cols in
4969 if zoom < 1.0
4970 then setzoom zoom
4972 | 0xffc6 -> (* f9 *)
4973 togglebirdseye ()
4975 | 57 when ctrl -> (* ctrl-9 *)
4976 togglebirdseye ()
4978 | (48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57)
4979 when not ctrl -> (* 0..9 *)
4980 let ondone s =
4981 let n =
4982 try int_of_string s with exc ->
4983 state.text <- Printf.sprintf "bad integer `%s': %s"
4984 s (Printexc.to_string exc);
4987 if n >= 0
4988 then (
4989 addnav ();
4990 cbput state.hists.pag (string_of_int n);
4991 gotopage1 (n + conf.pagebias - 1) 0;
4994 let pageentry text key =
4995 match Char.unsafe_chr key with
4996 | 'g' -> TEdone text
4997 | _ -> intentry text key
4999 let text = "x" in text.[0] <- Char.chr key;
5000 enttext (":", text, Some (onhist state.hists.pag), pageentry, ondone, true)
5002 | 98 -> (* b *)
5003 state.scrollw <- if state.scrollw > 0 then 0 else conf.scrollbw;
5004 reshape conf.winw conf.winh;
5006 | 108 -> (* l *)
5007 conf.hlinks <- not conf.hlinks;
5008 state.text <- "highlightlinks " ^ if conf.hlinks then "on" else "off";
5009 G.postRedisplay "toggle highlightlinks";
5011 | 70 -> (* F *)
5012 state.glinks <- true;
5013 let mode = state.mode in
5014 state.mode <- Textentry (
5015 (":", "", None, linknentry, linkndone gotounder, false),
5016 (fun _ ->
5017 state.glinks <- false;
5018 state.mode <- mode)
5020 state.text <- "";
5021 G.postRedisplay "view:linkent(F)"
5023 | 121 -> (* y *)
5024 state.glinks <- true;
5025 let mode = state.mode in
5026 state.mode <- Textentry (
5027 (":", "", None, linknentry, linkndone (fun under ->
5028 match Ne.pipe () with
5029 | Ne.Exn exn ->
5030 showtext '!' (Printf.sprintf "pipe failed: %s"
5031 (Printexc.to_string exn));
5032 | Ne.Res (r, w) ->
5033 let popened =
5034 try popen conf.selcmd [r, 0; w, -1]; true
5035 with exn ->
5036 showtext '!'
5037 (Printf.sprintf "failed to execute %s: %s"
5038 conf.selcmd (Printexc.to_string exn));
5039 false
5041 let clo cap fd =
5042 Ne.clo fd (fun msg ->
5043 showtext '!' (Printf.sprintf "failed to close %s: %s" cap msg)
5046 let s = undertext under in
5047 if popened
5048 then
5049 (try
5050 let l = String.length s in
5051 let n = tempfailureretry (Unix.write w s 0) l in
5052 if n != l
5053 then
5054 showtext '!'
5055 (Printf.sprintf
5056 "failed to write %d characters to sel pipe, wrote %d"
5059 with exn ->
5060 showtext '!'
5061 (Printf.sprintf "failed to write to sel pipe: %s"
5062 (Printexc.to_string exn)
5065 else dolog "%s" s;
5066 clo "pipe/r" r;
5067 clo "pipe/w" w;
5068 ), false
5070 fun _ ->
5071 state.glinks <- false;
5072 state.mode <- mode
5074 state.text <- "";
5075 G.postRedisplay "view:linkent"
5077 | 97 -> (* a *)
5078 begin match state.autoscroll with
5079 | Some step ->
5080 conf.autoscrollstep <- step;
5081 state.autoscroll <- None
5082 | None ->
5083 if conf.autoscrollstep = 0
5084 then state.autoscroll <- Some 1
5085 else state.autoscroll <- Some conf.autoscrollstep
5088 | 112 when ctrl -> (* ctrl-p *)
5089 launchpath ()
5091 | 80 -> (* P *)
5092 setpresentationmode (not conf.presentation);
5093 showtext ' ' ("presentation mode " ^
5094 if conf.presentation then "on" else "off");
5096 | 102 -> (* f *)
5097 begin match state.fullscreen with
5098 | None ->
5099 state.fullscreen <- Some (conf.winw, conf.winh);
5100 Wsi.fullscreen ()
5101 | Some (w, h) ->
5102 state.fullscreen <- None;
5103 doreshape w h
5106 | 112 | 78 -> (* p|N *)
5107 search state.searchpattern false
5109 | 110 | 0xffc0 -> (* n|F3 *)
5110 search state.searchpattern true
5112 | 116 -> (* t *)
5113 begin match state.layout with
5114 | [] -> ()
5115 | l :: _ ->
5116 gotoy_and_clear_text (getpagey l.pageno)
5119 | 32 -> (* space *)
5120 nextpage ()
5122 | 0xff9f | 0xffff -> (* delete *)
5123 prevpage ()
5125 | 61 -> (* = *)
5126 showtext ' ' (describe_location ());
5128 | 119 -> (* w *)
5129 begin match state.layout with
5130 | [] -> ()
5131 | l :: _ ->
5132 doreshape (l.pagew + state.scrollw) l.pageh;
5133 G.postRedisplay "w"
5136 | 39 -> (* ' *)
5137 enterbookmarkmode ()
5139 | 104 | 0xffbe -> (* h|F1 *)
5140 enterhelpmode ()
5142 | 105 -> (* i *)
5143 enterinfomode ()
5145 | 101 when Buffer.length state.errmsgs > 0 -> (* e *)
5146 entermsgsmode ()
5148 | 109 -> (* m *)
5149 let ondone s =
5150 match state.layout with
5151 | l :: _ ->
5152 if String.length s > 0
5153 then
5154 state.bookmarks <- (s, 0, getanchor1 l) :: state.bookmarks
5155 | _ -> ()
5157 enttext ("bookmark: ", "", None, textentry, ondone, true)
5159 | 126 -> (* ~ *)
5160 quickbookmark ();
5161 showtext ' ' "Quick bookmark added";
5163 | 122 -> (* z *)
5164 begin match state.layout with
5165 | l :: _ ->
5166 let rect = getpdimrect l.pagedimno in
5167 let w, h =
5168 if conf.crophack
5169 then
5170 (truncate (1.8 *. (rect.(1) -. rect.(0))),
5171 truncate (1.2 *. (rect.(3) -. rect.(0))))
5172 else
5173 (truncate (rect.(1) -. rect.(0)),
5174 truncate (rect.(3) -. rect.(0)))
5176 let w = truncate ((float w)*.conf.zoom)
5177 and h = truncate ((float h)*.conf.zoom) in
5178 if w != 0 && h != 0
5179 then (
5180 state.anchor <- getanchor ();
5181 doreshape (w + state.scrollw) (h + conf.interpagespace)
5183 G.postRedisplay "z";
5185 | [] -> ()
5188 | 50 when ctrl -> (* ctrl-2 *)
5189 let maxw = getmaxw () in
5190 if maxw > 0.0
5191 then setzoom (maxw /. float conf.winw)
5193 | 60 | 62 -> (* < > *)
5194 reqlayout (conf.angle + (if key = 62 then 30 else -30)) conf.proportional
5196 | 91 | 93 -> (* [ ] *)
5197 conf.colorscale <-
5198 bound (conf.colorscale +. (if key = 93 then 0.1 else -0.1)) 0.0 1.0
5200 G.postRedisplay "brightness";
5202 | 99 when state.mode = View -> (* c *)
5203 let (c, a, b), z =
5204 match state.prevcolumns with
5205 | None -> (1, 0, 0), 1.0
5206 | Some (columns, z) ->
5207 let cab =
5208 match columns with
5209 | Csplit (c, _) -> -c, 0, 0
5210 | Cmulti ((c, a, b), _) -> c, a, b
5211 | Csingle _ -> 1, 0, 0
5213 cab, z
5215 setcolumns View c a b;
5216 setzoom z;
5218 | 0xff54 | 0xff52 when ctrl && Wsi.withshift mask ->
5219 setzoom state.prevzoom
5221 | 107 | 0xff52 | 0xff97 -> (* k (kp) up *)
5222 begin match state.autoscroll with
5223 | None ->
5224 begin match state.mode with
5225 | Birdseye beye -> upbirdseye 1 beye
5226 | _ ->
5227 if ctrl
5228 then gotoy_and_clear_text (clamp ~-(conf.winh/2))
5229 else gotoy_and_clear_text (clamp (-conf.scrollstep))
5231 | Some n ->
5232 setautoscrollspeed n false
5235 | 106 | 0xff54 | 0xff99 -> (* j (kp) down *)
5236 begin match state.autoscroll with
5237 | None ->
5238 begin match state.mode with
5239 | Birdseye beye -> downbirdseye 1 beye
5240 | _ ->
5241 if ctrl
5242 then gotoy_and_clear_text (clamp (conf.winh/2))
5243 else gotoy_and_clear_text (clamp conf.scrollstep)
5245 | Some n ->
5246 setautoscrollspeed n true
5249 | 0xff51 | 0xff53 when not (Wsi.withalt mask) -> (* left / right *)
5250 if canpan ()
5251 then
5252 let dx =
5253 if ctrl
5254 then conf.winw / 2
5255 else conf.hscrollstep
5257 let dx = if key = 0xff51 then dx else -dx in
5258 state.x <- state.x + dx;
5259 gotoy_and_clear_text state.y
5260 else (
5261 state.text <- "";
5262 G.postRedisplay "lef/right"
5265 | 0xff55 | 0xff9a -> (* (kp) prior *)
5266 let y =
5267 if ctrl
5268 then
5269 match state.layout with
5270 | [] -> state.y
5271 | l :: _ -> state.y - l.pagey
5272 else
5273 clamp (pgscale (-conf.winh))
5275 gotoghyll y
5277 | 0xff56 | 0xff9b -> (* (kp) next *)
5278 let y =
5279 if ctrl
5280 then
5281 match List.rev state.layout with
5282 | [] -> state.y
5283 | l :: _ -> getpagey l.pageno
5284 else
5285 clamp (pgscale conf.winh)
5287 gotoghyll y
5289 | 103 | 0xff50 | 0xff95 -> (* g (kp) home *)
5290 gotoghyll 0
5291 | 71 | 0xff57 | 0xff9c -> (* G end *)
5292 gotoghyll (clamp state.maxy)
5294 | 0xff53 when Wsi.withalt mask -> (* alt-right *)
5295 gotoghyll (getnav 1)
5296 | 0xff51 when Wsi.withalt mask -> (* alt-left *)
5297 gotoghyll (getnav ~-1)
5299 | 114 -> (* r *)
5300 reload ()
5302 | 118 when conf.debug -> (* v *)
5303 state.rects <- [];
5304 List.iter (fun l ->
5305 match getopaque l.pageno with
5306 | None -> ()
5307 | Some opaque ->
5308 let x0, y0, x1, y1 = pagebbox opaque in
5309 let a,b = float x0, float y0 in
5310 let c,d = float x1, float y0 in
5311 let e,f = float x1, float y1 in
5312 let h,j = float x0, float y1 in
5313 let rect = (a,b,c,d,e,f,h,j) in
5314 debugrect rect;
5315 state.rects <- (l.pageno, l.pageno mod 3, rect) :: state.rects;
5316 ) state.layout;
5317 G.postRedisplay "v";
5319 | _ ->
5320 vlog "huh? %s" (Wsi.keyname key)
5323 let linknavkeyboard key mask linknav =
5324 let getpage pageno =
5325 let rec loop = function
5326 | [] -> None
5327 | l :: _ when l.pageno = pageno -> Some l
5328 | _ :: rest -> loop rest
5329 in loop state.layout
5331 let doexact (pageno, n) =
5332 match getopaque pageno, getpage pageno with
5333 | Some opaque, Some l ->
5334 if key = 0xff0d || key = 0xff8d (* (kp)enter *)
5335 then
5336 let under = getlink opaque n in
5337 G.postRedisplay "link gotounder";
5338 gotounder under;
5339 state.mode <- View;
5340 else
5341 let opt, dir =
5342 match key with
5343 | 0xff50 -> (* home *)
5344 Some (findlink opaque LDfirst), -1
5346 | 0xff57 -> (* end *)
5347 Some (findlink opaque LDlast), 1
5349 | 0xff51 -> (* left *)
5350 Some (findlink opaque (LDleft n)), -1
5352 | 0xff53 -> (* right *)
5353 Some (findlink opaque (LDright n)), 1
5355 | 0xff52 -> (* up *)
5356 Some (findlink opaque (LDup n)), -1
5358 | 0xff54 -> (* down *)
5359 Some (findlink opaque (LDdown n)), 1
5361 | _ -> None, 0
5363 let pwl l dir =
5364 begin match findpwl l.pageno dir with
5365 | Pwlnotfound -> ()
5366 | Pwl pageno ->
5367 let notfound dir =
5368 state.mode <- LinkNav (Ltgendir dir);
5369 let y, h = getpageyh pageno in
5370 let y =
5371 if dir < 0
5372 then y + h - conf.winh
5373 else y
5375 gotoy y
5377 begin match getopaque pageno, getpage pageno with
5378 | Some opaque, Some _ ->
5379 let link =
5380 let ld = if dir > 0 then LDfirst else LDlast in
5381 findlink opaque ld
5383 begin match link with
5384 | Lfound m ->
5385 showlinktype (getlink opaque m);
5386 state.mode <- LinkNav (Ltexact (pageno, m));
5387 G.postRedisplay "linknav jpage";
5388 | _ -> notfound dir
5389 end;
5390 | _ -> notfound dir
5391 end;
5392 end;
5394 begin match opt with
5395 | Some Lnotfound -> pwl l dir;
5396 | Some (Lfound m) ->
5397 if m = n
5398 then pwl l dir
5399 else (
5400 let _, y0, _, y1 = getlinkrect opaque m in
5401 if y0 < l.pagey
5402 then gotopage1 l.pageno y0
5403 else (
5404 let d = fstate.fontsize + 1 in
5405 if y1 - l.pagey > l.pagevh - d
5406 then gotopage1 l.pageno (y1 - conf.winh - state.hscrollh + d)
5407 else G.postRedisplay "linknav";
5409 showlinktype (getlink opaque m);
5410 state.mode <- LinkNav (Ltexact (l.pageno, m));
5413 | None -> viewkeyboard key mask
5414 end;
5415 | _ -> viewkeyboard key mask
5417 if key = 0xff63
5418 then (
5419 state.mode <- View;
5420 G.postRedisplay "leave linknav"
5422 else
5423 match linknav with
5424 | Ltgendir _ -> viewkeyboard key mask
5425 | Ltexact exact -> doexact exact
5428 let keyboard key mask =
5429 if (key = 103 && Wsi.withctrl mask) && not (istextentry state.mode)
5430 then wcmd "interrupt"
5431 else state.uioh <- state.uioh#key key mask
5434 let birdseyekeyboard key mask
5435 ((oconf, leftx, pageno, hooverpageno, anchor) as beye) =
5436 let incr =
5437 match conf.columns with
5438 | Csingle _ -> 1
5439 | Cmulti ((c, _, _), _) -> c
5440 | Csplit _ -> failwith "bird's eye split mode"
5442 let pgh layout = List.fold_left (fun m l -> max l.pageh m) conf.winh layout in
5443 match key with
5444 | 108 when Wsi.withctrl mask -> (* ctrl-l *)
5445 let y, h = getpageyh pageno in
5446 let top = (conf.winh - h) / 2 in
5447 gotoy (max 0 (y - top))
5448 | 0xff0d (* enter *)
5449 | 0xff8d -> leavebirdseye beye false (* kp enter *)
5450 | 0xff1b -> leavebirdseye beye true (* escape *)
5451 | 0xff52 -> upbirdseye incr beye (* up *)
5452 | 0xff54 -> downbirdseye incr beye (* down *)
5453 | 0xff51 -> upbirdseye 1 beye (* left *)
5454 | 0xff53 -> downbirdseye 1 beye (* right *)
5456 | 0xff55 -> (* prior *)
5457 begin match state.layout with
5458 | l :: _ ->
5459 if l.pagey != 0
5460 then (
5461 state.mode <- Birdseye (
5462 oconf, leftx, l.pageno, hooverpageno, anchor
5464 gotopage1 l.pageno 0;
5466 else (
5467 let layout = layout (state.y-conf.winh) (pgh state.layout) in
5468 match layout with
5469 | [] -> gotoy (clamp (-conf.winh))
5470 | l :: _ ->
5471 state.mode <- Birdseye (
5472 oconf, leftx, l.pageno, hooverpageno, anchor
5474 gotopage1 l.pageno 0
5477 | [] -> gotoy (clamp (-conf.winh))
5478 end;
5480 | 0xff56 -> (* next *)
5481 begin match List.rev state.layout with
5482 | l :: _ ->
5483 let layout = layout (state.y + (pgh state.layout)) conf.winh in
5484 begin match layout with
5485 | [] ->
5486 let incr = l.pageh - l.pagevh in
5487 if incr = 0
5488 then (
5489 state.mode <-
5490 Birdseye (
5491 oconf, leftx, state.pagecount - 1, hooverpageno, anchor
5493 G.postRedisplay "birdseye pagedown";
5495 else gotoy (clamp (incr + conf.interpagespace*2));
5497 | l :: _ ->
5498 state.mode <-
5499 Birdseye (oconf, leftx, l.pageno, hooverpageno, anchor);
5500 gotopage1 l.pageno 0;
5503 | [] -> gotoy (clamp conf.winh)
5504 end;
5506 | 0xff50 -> (* home *)
5507 state.mode <- Birdseye (oconf, leftx, 0, hooverpageno, anchor);
5508 gotopage1 0 0
5510 | 0xff57 -> (* end *)
5511 let pageno = state.pagecount - 1 in
5512 state.mode <- Birdseye (oconf, leftx, pageno, hooverpageno, anchor);
5513 if not (pagevisible state.layout pageno)
5514 then
5515 let h =
5516 match List.rev state.pdims with
5517 | [] -> conf.winh
5518 | (_, _, h, _) :: _ -> h
5520 gotoy (max 0 (getpagey pageno - (conf.winh - h - conf.interpagespace)))
5521 else G.postRedisplay "birdseye end";
5522 | _ -> viewkeyboard key mask
5525 let drawpage l linkindexbase =
5526 let color =
5527 match state.mode with
5528 | Textentry _ -> scalecolor 0.4
5529 | LinkNav _
5530 | View -> scalecolor 1.0
5531 | Birdseye (_, _, pageno, hooverpageno, _) ->
5532 if l.pageno = hooverpageno
5533 then scalecolor 0.9
5534 else (
5535 if l.pageno = pageno
5536 then scalecolor 1.0
5537 else scalecolor 0.8
5540 drawtiles l color;
5541 begin match getopaque l.pageno with
5542 | Some opaque ->
5543 if tileready l l.pagex l.pagey
5544 then
5545 let x = l.pagedispx - l.pagex
5546 and y = l.pagedispy - l.pagey in
5547 let hlmask =
5548 match conf.columns with
5549 | Csingle _ | Cmulti _ ->
5550 (if conf.hlinks then 1 else 0)
5551 + (if state.glinks
5552 && not (isbirdseye state.mode) then 2 else 0)
5553 | _ -> 0
5555 let s =
5556 match state.mode with
5557 | Textentry ((_, s, _, _, _, _), _) when state.glinks -> s
5558 | _ -> ""
5560 postprocess opaque hlmask x y (linkindexbase, s, conf.hfsize);
5561 else 0
5563 | _ -> 0
5564 end;
5567 let scrollindicator () =
5568 let sbw, ph, sh = state.uioh#scrollph in
5569 let sbh, pw, sw = state.uioh#scrollpw in
5571 GlDraw.color (0.64, 0.64, 0.64);
5572 GlDraw.rect
5573 (float (conf.winw - sbw), 0.)
5574 (float conf.winw, float conf.winh)
5576 GlDraw.rect
5577 (0., float (conf.winh - sbh))
5578 (float (conf.winw - state.scrollw - 1), float conf.winh)
5580 GlDraw.color (0.0, 0.0, 0.0);
5582 GlDraw.rect
5583 (float (conf.winw - sbw), ph)
5584 (float conf.winw, ph +. sh)
5586 GlDraw.rect
5587 (pw, float (conf.winh - sbh))
5588 (pw +. sw, float conf.winh)
5592 let showsel () =
5593 match state.mstate with
5594 | Mnone | Mscrolly | Mscrollx | Mpan _ | Mzoom _ | Mzoomrect _ ->
5597 | Msel ((x0, y0), (x1, y1)) ->
5598 let rec loop = function
5599 | l :: ls ->
5600 if ((y0 >= l.pagedispy && y0 <= (l.pagedispy + l.pagevh))
5601 || ((y1 >= l.pagedispy && y1 <= (l.pagedispy + l.pagevh))))
5602 && ((x0 >= l.pagedispx && x0 <= (l.pagedispx + l.pagevw))
5603 || ((x1 >= l.pagedispx && x1 <= (l.pagedispx + l.pagevw))))
5604 then
5605 match getopaque l.pageno with
5606 | Some opaque ->
5607 let x0, y0 = pagetranslatepoint l x0 y0 in
5608 let x1, y1 = pagetranslatepoint l x1 y1 in
5609 seltext opaque (x0, y0, x1, y1);
5610 | _ -> ()
5611 else loop ls
5612 | [] -> ()
5614 loop state.layout
5617 let showrects rects =
5618 Gl.enable `blend;
5619 GlDraw.color (0.0, 0.0, 1.0) ~alpha:0.5;
5620 GlDraw.polygon_mode `both `fill;
5621 GlFunc.blend_func `src_alpha `one_minus_src_alpha;
5622 List.iter
5623 (fun (pageno, c, (x0, y0, x1, y1, x2, y2, x3, y3)) ->
5624 List.iter (fun l ->
5625 if l.pageno = pageno
5626 then (
5627 let dx = float (l.pagedispx - l.pagex) in
5628 let dy = float (l.pagedispy - l.pagey) in
5629 GlDraw.color (0.0, 0.0, 1.0 /. float c) ~alpha:0.5;
5630 GlDraw.begins `quads;
5632 GlDraw.vertex2 (x0+.dx, y0+.dy);
5633 GlDraw.vertex2 (x1+.dx, y1+.dy);
5634 GlDraw.vertex2 (x2+.dx, y2+.dy);
5635 GlDraw.vertex2 (x3+.dx, y3+.dy);
5637 GlDraw.ends ();
5639 ) state.layout
5640 ) rects
5642 Gl.disable `blend;
5645 let display () =
5646 GlClear.color (scalecolor2 conf.bgcolor);
5647 GlClear.clear [`color];
5648 let rec loop linkindexbase = function
5649 | l :: rest ->
5650 let linkindexbase = linkindexbase + drawpage l linkindexbase in
5651 loop linkindexbase rest
5652 | [] -> ()
5654 loop 0 state.layout;
5655 let rects =
5656 match state.mode with
5657 | LinkNav (Ltexact (pageno, linkno)) ->
5658 begin match getopaque pageno with
5659 | Some opaque ->
5660 let x0, y0, x1, y1 = getlinkrect opaque linkno in
5661 (pageno, 5, (
5662 float x0, float y0,
5663 float x1, float y0,
5664 float x1, float y1,
5665 float x0, float y1)
5666 ) :: state.rects
5667 | None -> state.rects
5669 | _ -> state.rects
5671 showrects rects;
5672 showsel ();
5673 state.uioh#display;
5674 begin match state.mstate with
5675 | Mzoomrect ((x0, y0), (x1, y1)) ->
5676 Gl.enable `blend;
5677 GlDraw.color (0.3, 0.3, 0.3) ~alpha:0.5;
5678 GlFunc.blend_func `src_alpha `one_minus_src_alpha;
5679 GlDraw.rect (float x0, float y0)
5680 (float x1, float y1);
5681 Gl.disable `blend;
5682 | _ -> ()
5683 end;
5684 enttext ();
5685 scrollindicator ();
5686 if not state.wthack then Wsi.swapb ();
5689 let zoomrect x y x1 y1 =
5690 let x0 = min x x1
5691 and x1 = max x x1
5692 and y0 = min y y1 in
5693 gotoy (state.y + y0);
5694 state.anchor <- getanchor ();
5695 let zoom = (float conf.winw *. conf.zoom) /. float (x1 - x0) in
5696 let margin =
5697 if state.w < conf.winw - state.scrollw
5698 then (conf.winw - state.scrollw - state.w) / 2
5699 else 0
5701 state.x <- (state.x + margin) - x0;
5702 setzoom zoom;
5703 Wsi.setcursor Wsi.CURSOR_INHERIT;
5704 state.mstate <- Mnone;
5707 let scrollx x =
5708 let winw = conf.winw - state.scrollw - 1 in
5709 let s = float x /. float winw in
5710 let destx = truncate (float (state.w + winw) *. s) in
5711 state.x <- winw - destx;
5712 gotoy_and_clear_text state.y;
5713 state.mstate <- Mscrollx;
5716 let scrolly y =
5717 let s = float y /. float conf.winh in
5718 let desty = truncate (float (state.maxy - conf.winh) *. s) in
5719 gotoy_and_clear_text desty;
5720 state.mstate <- Mscrolly;
5723 let viewmouse button down x y mask =
5724 match button with
5725 | n when (n == 4 || n == 5) && not down ->
5726 if Wsi.withctrl mask
5727 then (
5728 match state.mstate with
5729 | Mzoom (oldn, i) ->
5730 if oldn = n
5731 then (
5732 if i = 2
5733 then
5734 let incr =
5735 match n with
5736 | 5 ->
5737 if conf.zoom +. 0.01 > 0.1 then 0.1 else 0.01
5738 | _ ->
5739 if conf.zoom -. 0.1 < 0.1 then -0.01 else -0.1
5741 let zoom = conf.zoom -. incr in
5742 setzoom zoom;
5743 state.mstate <- Mzoom (n, 0);
5744 else
5745 state.mstate <- Mzoom (n, i+1);
5747 else state.mstate <- Mzoom (n, 0)
5749 | _ -> state.mstate <- Mzoom (n, 0)
5751 else (
5752 match state.autoscroll with
5753 | Some step -> setautoscrollspeed step (n=4)
5754 | None ->
5755 if conf.wheelbypage
5756 then (
5757 if n = 4
5758 then prevpage ()
5759 else nextpage ()
5761 else
5762 let incr =
5763 if n = 4
5764 then -conf.scrollstep
5765 else conf.scrollstep
5767 let incr = incr * 2 in
5768 let y = clamp incr in
5769 gotoy_and_clear_text y
5772 | n when (n = 6 || n = 7) && not down && canpan () ->
5773 state.x <- state.x + (if n = 7 then -2 else 2) * conf.hscrollstep;
5774 gotoy_and_clear_text state.y
5776 | 1 when Wsi.withctrl mask ->
5777 if down
5778 then (
5779 Wsi.setcursor Wsi.CURSOR_CROSSHAIR;
5780 state.mstate <- Mpan (x, y)
5782 else
5783 state.mstate <- Mnone
5785 | 3 ->
5786 if down
5787 then (
5788 Wsi.setcursor Wsi.CURSOR_CYCLE;
5789 let p = (x, y) in
5790 state.mstate <- Mzoomrect (p, p)
5792 else (
5793 match state.mstate with
5794 | Mzoomrect ((x0, y0), _) ->
5795 if abs (x-x0) > 10 && abs (y - y0) > 10
5796 then zoomrect x0 y0 x y
5797 else (
5798 state.mstate <- Mnone;
5799 Wsi.setcursor Wsi.CURSOR_INHERIT;
5800 G.postRedisplay "kill accidental zoom rect";
5802 | _ ->
5803 Wsi.setcursor Wsi.CURSOR_INHERIT;
5804 state.mstate <- Mnone
5807 | 1 when x > conf.winw - state.scrollw ->
5808 if down
5809 then
5810 let _, position, sh = state.uioh#scrollph in
5811 if y > truncate position && y < truncate (position +. sh)
5812 then state.mstate <- Mscrolly
5813 else scrolly y
5814 else
5815 state.mstate <- Mnone
5817 | 1 when y > conf.winh - state.hscrollh ->
5818 if down
5819 then
5820 let _, position, sw = state.uioh#scrollpw in
5821 if x > truncate position && x < truncate (position +. sw)
5822 then state.mstate <- Mscrollx
5823 else scrollx x
5824 else
5825 state.mstate <- Mnone
5827 | 1 ->
5828 let dest = if down then getunder x y else Unone in
5829 begin match dest with
5830 | Ulinkgoto _
5831 | Ulinkuri _
5832 | Uremote _
5833 | Uunexpected _ | Ulaunch _ | Unamed _ ->
5834 gotounder dest
5836 | Unone when down ->
5837 Wsi.setcursor Wsi.CURSOR_CROSSHAIR;
5838 state.mstate <- Mpan (x, y);
5840 | Unone | Utext _ ->
5841 if down
5842 then (
5843 if conf.angle mod 360 = 0
5844 then (
5845 state.mstate <- Msel ((x, y), (x, y));
5846 G.postRedisplay "mouse select";
5849 else (
5850 match state.mstate with
5851 | Mnone -> ()
5853 | Mzoom _ | Mscrollx | Mscrolly ->
5854 state.mstate <- Mnone
5856 | Mzoomrect ((x0, y0), _) ->
5857 zoomrect x0 y0 x y
5859 | Mpan _ ->
5860 Wsi.setcursor Wsi.CURSOR_INHERIT;
5861 state.mstate <- Mnone
5863 | Msel ((x0, y0), (x1, y1)) ->
5864 let rec loop = function
5865 | [] -> ()
5866 | l :: rest ->
5867 let inside =
5868 let a0 = l.pagedispy in
5869 let a1 = a0 + l.pagevh in
5870 let b0 = l.pagedispx in
5871 let b1 = b0 + l.pagevw in
5872 ((y0 >= a0 && y0 <= a1) || (y1 >= a0 && y1 <= a1))
5873 && ((x0 >= b0 && x0 <= b1) || (x1 >= b0 && x1 <= b1))
5875 if inside
5876 then
5877 match getopaque l.pageno with
5878 | Some opaque ->
5879 begin
5880 match Ne.pipe () with
5881 | Ne.Exn exn ->
5882 showtext '!'
5883 (Printf.sprintf
5884 "can not create sel pipe: %s"
5885 (Printexc.to_string exn));
5886 | Ne.Res (r, w) ->
5887 let doclose what fd =
5888 Ne.clo fd (fun msg ->
5889 dolog "%s close failed: %s" what msg)
5892 popen conf.selcmd [r, 0; w, -1];
5893 copysel w opaque;
5894 doclose "pipe/r" r;
5895 G.postRedisplay "copysel";
5896 with exn ->
5897 dolog "can not execute %S: %s"
5898 conf.selcmd (Printexc.to_string exn);
5899 doclose "pipe/r" r;
5900 doclose "pipe/w" w;
5902 | None -> ()
5903 else loop rest
5905 loop state.layout;
5906 Wsi.setcursor Wsi.CURSOR_INHERIT;
5907 state.mstate <- Mnone;
5911 | _ -> ()
5914 let birdseyemouse button down x y mask
5915 (conf, leftx, _, hooverpageno, anchor) =
5916 match button with
5917 | 1 when down ->
5918 let rec loop = function
5919 | [] -> ()
5920 | l :: rest ->
5921 if y > l.pagedispy && y < l.pagedispy + l.pagevh
5922 && x > l.pagedispx && x < l.pagedispx + l.pagevw
5923 then (
5924 leavebirdseye (conf, leftx, l.pageno, hooverpageno, anchor) false;
5926 else loop rest
5928 loop state.layout
5929 | 3 -> ()
5930 | _ -> viewmouse button down x y mask
5933 let mouse button down x y mask =
5934 state.uioh <- state.uioh#button button down x y mask;
5937 let motion ~x ~y =
5938 state.uioh <- state.uioh#motion x y
5941 let pmotion ~x ~y =
5942 state.uioh <- state.uioh#pmotion x y;
5945 let uioh = object
5946 method display = ()
5948 method key key mask =
5949 begin match state.mode with
5950 | Textentry textentry -> textentrykeyboard key mask textentry
5951 | Birdseye birdseye -> birdseyekeyboard key mask birdseye
5952 | View -> viewkeyboard key mask
5953 | LinkNav linknav -> linknavkeyboard key mask linknav
5954 end;
5955 state.uioh
5957 method button button bstate x y mask =
5958 begin match state.mode with
5959 | LinkNav _
5960 | View -> viewmouse button bstate x y mask
5961 | Birdseye beye -> birdseyemouse button bstate x y mask beye
5962 | Textentry _ -> ()
5963 end;
5964 state.uioh
5966 method motion x y =
5967 begin match state.mode with
5968 | Textentry _ -> ()
5969 | View | Birdseye _ | LinkNav _ ->
5970 match state.mstate with
5971 | Mzoom _ | Mnone -> ()
5973 | Mpan (x0, y0) ->
5974 let dx = x - x0
5975 and dy = y0 - y in
5976 state.mstate <- Mpan (x, y);
5977 if canpan ()
5978 then state.x <- state.x + dx;
5979 let y = clamp dy in
5980 gotoy_and_clear_text y
5982 | Msel (a, _) ->
5983 state.mstate <- Msel (a, (x, y));
5984 G.postRedisplay "motion select";
5986 | Mscrolly ->
5987 let y = min conf.winh (max 0 y) in
5988 scrolly y
5990 | Mscrollx ->
5991 let x = min conf.winw (max 0 x) in
5992 scrollx x
5994 | Mzoomrect (p0, _) ->
5995 state.mstate <- Mzoomrect (p0, (x, y));
5996 G.postRedisplay "motion zoomrect";
5997 end;
5998 state.uioh
6000 method pmotion x y =
6001 begin match state.mode with
6002 | Birdseye (conf, leftx, pageno, hooverpageno, anchor) ->
6003 let rec loop = function
6004 | [] ->
6005 if hooverpageno != -1
6006 then (
6007 state.mode <- Birdseye (conf, leftx, pageno, -1, anchor);
6008 G.postRedisplay "pmotion birdseye no hoover";
6010 | l :: rest ->
6011 if y > l.pagedispy && y < l.pagedispy + l.pagevh
6012 && x > l.pagedispx && x < l.pagedispx + l.pagevw
6013 then (
6014 state.mode <- Birdseye (conf, leftx, pageno, l.pageno, anchor);
6015 G.postRedisplay "pmotion birdseye hoover";
6017 else loop rest
6019 loop state.layout
6021 | Textentry _ -> ()
6023 | LinkNav _
6024 | View ->
6025 match state.mstate with
6026 | Mnone -> updateunder x y
6027 | Mpan _ | Msel _ | Mzoom _ | Mscrolly | Mscrollx | Mzoomrect _ ->
6029 end;
6030 state.uioh
6032 method infochanged _ = ()
6034 method scrollph =
6035 let maxy = state.maxy - (if conf.maxhfit then conf.winh else 0) in
6036 let p, h = scrollph state.y maxy in
6037 state.scrollw, p, h
6039 method scrollpw =
6040 let winw = conf.winw - state.scrollw - 1 in
6041 let fwinw = float winw in
6042 let sw =
6043 let sw = fwinw /. float state.w in
6044 let sw = fwinw *. sw in
6045 max sw (float conf.scrollh)
6047 let position, sw =
6048 let f = state.w+winw in
6049 let r = float (winw-state.x) /. float f in
6050 let p = fwinw *. r in
6051 p-.sw/.2., sw
6053 let sw =
6054 if position +. sw > fwinw
6055 then fwinw -. position
6056 else sw
6058 state.hscrollh, position, sw
6060 method modehash =
6061 let modename =
6062 match state.mode with
6063 | LinkNav _ -> "links"
6064 | Textentry _ -> "textentry"
6065 | Birdseye _ -> "birdseye"
6066 | View -> "view"
6068 findkeyhash conf modename
6069 end;;
6071 module Config =
6072 struct
6073 open Parser
6075 let fontpath = ref "";;
6077 module KeyMap =
6078 Map.Make (struct type t = (int * int) let compare = compare end);;
6080 let unent s =
6081 let l = String.length s in
6082 let b = Buffer.create l in
6083 unent b s 0 l;
6084 Buffer.contents b;
6087 let home =
6088 try Sys.getenv "HOME"
6089 with exn ->
6090 prerr_endline
6091 ("Can not determine home directory location: " ^
6092 Printexc.to_string exn);
6096 let modifier_of_string = function
6097 | "alt" -> Wsi.altmask
6098 | "shift" -> Wsi.shiftmask
6099 | "ctrl" | "control" -> Wsi.ctrlmask
6100 | "meta" -> Wsi.metamask
6101 | _ -> 0
6104 let key_of_string =
6105 let r = Str.regexp "-" in
6106 fun s ->
6107 let elems = Str.full_split r s in
6108 let f n k m =
6109 let g s =
6110 let m1 = modifier_of_string s in
6111 if m1 = 0
6112 then (Wsi.namekey s, m)
6113 else (k, m lor m1)
6114 in function
6115 | Str.Delim s when n land 1 = 0 -> g s
6116 | Str.Text s -> g s
6117 | Str.Delim _ -> (k, m)
6119 let rec loop n k m = function
6120 | [] -> (k, m)
6121 | x :: xs ->
6122 let k, m = f n k m x in
6123 loop (n+1) k m xs
6125 loop 0 0 0 elems
6128 let keys_of_string =
6129 let r = Str.regexp "[ \t]" in
6130 fun s ->
6131 let elems = Str.split r s in
6132 List.map key_of_string elems
6135 let copykeyhashes c =
6136 List.map (fun (k, v) -> k, Hashtbl.copy v) c.keyhashes;
6139 let config_of c attrs =
6140 let apply c k v =
6142 match k with
6143 | "scroll-bar-width" -> { c with scrollbw = max 0 (int_of_string v) }
6144 | "scroll-handle-height" -> { c with scrollh = max 0 (int_of_string v) }
6145 | "case-insensitive-search" -> { c with icase = bool_of_string v }
6146 | "preload" -> { c with preload = bool_of_string v }
6147 | "page-bias" -> { c with pagebias = int_of_string v }
6148 | "scroll-step" -> { c with scrollstep = max 1 (int_of_string v) }
6149 | "horizontal-scroll-step" ->
6150 { c with hscrollstep = max (int_of_string v) 1 }
6151 | "auto-scroll-step" ->
6152 { c with autoscrollstep = max 0 (int_of_string v) }
6153 | "max-height-fit" -> { c with maxhfit = bool_of_string v }
6154 | "crop-hack" -> { c with crophack = bool_of_string v }
6155 | "throttle" ->
6156 let mw =
6157 match String.lowercase v with
6158 | "true" -> Some infinity
6159 | "false" -> None
6160 | f -> Some (float_of_string f)
6162 { c with maxwait = mw}
6163 | "highlight-links" -> { c with hlinks = bool_of_string v }
6164 | "under-cursor-info" -> { c with underinfo = bool_of_string v }
6165 | "vertical-margin" ->
6166 { c with interpagespace = max 0 (int_of_string v) }
6167 | "zoom" ->
6168 let zoom = float_of_string v /. 100. in
6169 let zoom = max zoom 0.0 in
6170 { c with zoom = zoom }
6171 | "presentation" -> { c with presentation = bool_of_string v }
6172 | "rotation-angle" -> { c with angle = int_of_string v }
6173 | "width" -> { c with winw = max 20 (int_of_string v) }
6174 | "height" -> { c with winh = max 20 (int_of_string v) }
6175 | "persistent-bookmarks" -> { c with savebmarks = bool_of_string v }
6176 | "proportional-display" -> { c with proportional = bool_of_string v }
6177 | "pixmap-cache-size" ->
6178 { c with memlimit = max 2 (int_of_string_with_suffix v) }
6179 | "tex-count" -> { c with texcount = max 1 (int_of_string v) }
6180 | "slice-height" -> { c with sliceheight = max 2 (int_of_string v) }
6181 | "thumbnail-width" -> { c with thumbw = max 2 (int_of_string v) }
6182 | "persistent-location" -> { c with jumpback = bool_of_string v }
6183 | "background-color" -> { c with bgcolor = color_of_string v }
6184 | "scrollbar-in-presentation" ->
6185 { c with scrollbarinpm = bool_of_string v }
6186 | "tile-width" -> { c with tilew = max 2 (int_of_string v) }
6187 | "tile-height" -> { c with tileh = max 2 (int_of_string v) }
6188 | "mupdf-store-size" ->
6189 { c with mustoresize = max 1024 (int_of_string_with_suffix v) }
6190 | "checkers" -> { c with checkers = bool_of_string v }
6191 | "aalevel" -> { c with aalevel = max 0 (int_of_string v) }
6192 | "trim-margins" -> { c with trimmargins = bool_of_string v }
6193 | "trim-fuzz" -> { c with trimfuzz = irect_of_string v }
6194 | "uri-launcher" -> { c with urilauncher = unent v }
6195 | "path-launcher" -> { c with pathlauncher = unent v }
6196 | "color-space" -> { c with colorspace = colorspace_of_string v }
6197 | "invert-colors" -> { c with invert = bool_of_string v }
6198 | "brightness" -> { c with colorscale = float_of_string v }
6199 | "redirectstderr" -> { c with redirectstderr = bool_of_string v }
6200 | "ghyllscroll" ->
6201 { c with ghyllscroll = Some (ghyllscroll_of_string v) }
6202 | "columns" ->
6203 let (n, _, _) as nab = multicolumns_of_string v in
6204 if n < 0
6205 then { c with columns = Csplit (-n, [||]) }
6206 else { c with columns = Cmulti (nab, [||]) }
6207 | "birds-eye-columns" ->
6208 { c with beyecolumns = Some (max (int_of_string v) 2) }
6209 | "selection-command" -> { c with selcmd = unent v }
6210 | "update-cursor" -> { c with updatecurs = bool_of_string v }
6211 | "hint-font-size" -> { c with hfsize = bound (int_of_string v) 5 100 }
6212 | "page-scroll-scale" -> { c with pgscale = float_of_string v }
6213 | "use-pbo" -> { c with usepbo = bool_of_string v }
6214 | "wheel-scrolls-pages" -> { c with wheelbypage = bool_of_string v }
6215 | _ -> c
6216 with exn ->
6217 prerr_endline ("Error processing attribute (`" ^
6218 k ^ "'=`" ^ v ^ "'): " ^ Printexc.to_string exn);
6221 let rec fold c = function
6222 | [] -> c
6223 | (k, v) :: rest ->
6224 let c = apply c k v in
6225 fold c rest
6227 fold { c with keyhashes = copykeyhashes c } attrs;
6230 let fromstring f pos n v d =
6231 try f v
6232 with exn ->
6233 dolog "Error processing attribute (%S=%S) at %d\n%s"
6234 n v pos (Printexc.to_string exn)
6239 let bookmark_of attrs =
6240 let rec fold title page rely visy = function
6241 | ("title", v) :: rest -> fold v page rely visy rest
6242 | ("page", v) :: rest -> fold title v rely visy rest
6243 | ("rely", v) :: rest -> fold title page v visy rest
6244 | ("visy", v) :: rest -> fold title page rely v rest
6245 | _ :: rest -> fold title page rely visy rest
6246 | [] -> title, page, rely, visy
6248 fold "invalid" "0" "0" "0" attrs
6251 let doc_of attrs =
6252 let rec fold path page rely pan visy = function
6253 | ("path", v) :: rest -> fold v page rely pan visy rest
6254 | ("page", v) :: rest -> fold path v rely pan visy rest
6255 | ("rely", v) :: rest -> fold path page v pan visy rest
6256 | ("pan", v) :: rest -> fold path page rely v visy rest
6257 | ("visy", v) :: rest -> fold path page rely pan v rest
6258 | _ :: rest -> fold path page rely pan visy rest
6259 | [] -> path, page, rely, pan, visy
6261 fold "" "0" "0" "0" "0" attrs
6264 let map_of attrs =
6265 let rec fold rs ls = function
6266 | ("out", v) :: rest -> fold v ls rest
6267 | ("in", v) :: rest -> fold rs v rest
6268 | _ :: rest -> fold ls rs rest
6269 | [] -> ls, rs
6271 fold "" "" attrs
6274 let setconf dst src =
6275 dst.scrollbw <- src.scrollbw;
6276 dst.scrollh <- src.scrollh;
6277 dst.icase <- src.icase;
6278 dst.preload <- src.preload;
6279 dst.pagebias <- src.pagebias;
6280 dst.verbose <- src.verbose;
6281 dst.scrollstep <- src.scrollstep;
6282 dst.maxhfit <- src.maxhfit;
6283 dst.crophack <- src.crophack;
6284 dst.autoscrollstep <- src.autoscrollstep;
6285 dst.maxwait <- src.maxwait;
6286 dst.hlinks <- src.hlinks;
6287 dst.underinfo <- src.underinfo;
6288 dst.interpagespace <- src.interpagespace;
6289 dst.zoom <- src.zoom;
6290 dst.presentation <- src.presentation;
6291 dst.angle <- src.angle;
6292 dst.winw <- src.winw;
6293 dst.winh <- src.winh;
6294 dst.savebmarks <- src.savebmarks;
6295 dst.memlimit <- src.memlimit;
6296 dst.proportional <- src.proportional;
6297 dst.texcount <- src.texcount;
6298 dst.sliceheight <- src.sliceheight;
6299 dst.thumbw <- src.thumbw;
6300 dst.jumpback <- src.jumpback;
6301 dst.bgcolor <- src.bgcolor;
6302 dst.scrollbarinpm <- src.scrollbarinpm;
6303 dst.tilew <- src.tilew;
6304 dst.tileh <- src.tileh;
6305 dst.mustoresize <- src.mustoresize;
6306 dst.checkers <- src.checkers;
6307 dst.aalevel <- src.aalevel;
6308 dst.trimmargins <- src.trimmargins;
6309 dst.trimfuzz <- src.trimfuzz;
6310 dst.urilauncher <- src.urilauncher;
6311 dst.colorspace <- src.colorspace;
6312 dst.invert <- src.invert;
6313 dst.colorscale <- src.colorscale;
6314 dst.redirectstderr <- src.redirectstderr;
6315 dst.ghyllscroll <- src.ghyllscroll;
6316 dst.columns <- src.columns;
6317 dst.beyecolumns <- src.beyecolumns;
6318 dst.selcmd <- src.selcmd;
6319 dst.updatecurs <- src.updatecurs;
6320 dst.pathlauncher <- src.pathlauncher;
6321 dst.keyhashes <- copykeyhashes src;
6322 dst.hfsize <- src.hfsize;
6323 dst.hscrollstep <- src.hscrollstep;
6324 dst.pgscale <- src.pgscale;
6325 dst.usepbo <- src.usepbo;
6326 dst.wheelbypage <- src.wheelbypage;
6329 let get s =
6330 let h = Hashtbl.create 10 in
6331 let dc = { defconf with angle = defconf.angle } in
6332 let rec toplevel v t spos _ =
6333 match t with
6334 | Vdata | Vcdata | Vend -> v
6335 | Vopen ("llppconfig", _, closed) ->
6336 if closed
6337 then v
6338 else { v with f = llppconfig }
6339 | Vopen _ ->
6340 error "unexpected subelement at top level" s spos
6341 | Vclose _ -> error "unexpected close at top level" s spos
6343 and llppconfig v t spos _ =
6344 match t with
6345 | Vdata | Vcdata -> v
6346 | Vend -> error "unexpected end of input in llppconfig" s spos
6347 | Vopen ("defaults", attrs, closed) ->
6348 let c = config_of dc attrs in
6349 setconf dc c;
6350 if closed
6351 then v
6352 else { v with f = defaults }
6354 | Vopen ("ui-font", attrs, closed) ->
6355 let rec getsize size = function
6356 | [] -> size
6357 | ("size", v) :: rest ->
6358 let size =
6359 fromstring int_of_string spos "size" v fstate.fontsize in
6360 getsize size rest
6361 | l -> getsize size l
6363 fstate.fontsize <- getsize fstate.fontsize attrs;
6364 if closed
6365 then v
6366 else { v with f = uifont (Buffer.create 10) }
6368 | Vopen ("doc", attrs, closed) ->
6369 let pathent, spage, srely, span, svisy = doc_of attrs in
6370 let path = unent pathent
6371 and pageno = fromstring int_of_string spos "page" spage 0
6372 and rely = fromstring float_of_string spos "rely" srely 0.0
6373 and pan = fromstring int_of_string spos "pan" span 0
6374 and visy = fromstring float_of_string spos "visy" svisy 0.0 in
6375 let c = config_of dc attrs in
6376 let anchor = (pageno, rely, visy) in
6377 if closed
6378 then (Hashtbl.add h path (c, [], pan, anchor); v)
6379 else { v with f = doc path pan anchor c [] }
6381 | Vopen _ ->
6382 error "unexpected subelement in llppconfig" s spos
6384 | Vclose "llppconfig" -> { v with f = toplevel }
6385 | Vclose _ -> error "unexpected close in llppconfig" s spos
6387 and defaults v t spos _ =
6388 match t with
6389 | Vdata | Vcdata -> v
6390 | Vend -> error "unexpected end of input in defaults" s spos
6391 | Vopen ("keymap", attrs, closed) ->
6392 let modename =
6393 try List.assoc "mode" attrs
6394 with Not_found -> "global" in
6395 if closed
6396 then v
6397 else
6398 let ret keymap =
6399 let h = findkeyhash dc modename in
6400 KeyMap.iter (Hashtbl.replace h) keymap;
6401 defaults
6403 { v with f = pkeymap ret KeyMap.empty }
6405 | Vopen (_, _, _) ->
6406 error "unexpected subelement in defaults" s spos
6408 | Vclose "defaults" ->
6409 { v with f = llppconfig }
6411 | Vclose _ -> error "unexpected close in defaults" s spos
6413 and uifont b v t spos epos =
6414 match t with
6415 | Vdata | Vcdata ->
6416 Buffer.add_substring b s spos (epos - spos);
6418 | Vopen (_, _, _) ->
6419 error "unexpected subelement in ui-font" s spos
6420 | Vclose "ui-font" ->
6421 if String.length !fontpath = 0
6422 then fontpath := Buffer.contents b;
6423 { v with f = llppconfig }
6424 | Vclose _ -> error "unexpected close in ui-font" s spos
6425 | Vend -> error "unexpected end of input in ui-font" s spos
6427 and doc path pan anchor c bookmarks v t spos _ =
6428 match t with
6429 | Vdata | Vcdata -> v
6430 | Vend -> error "unexpected end of input in doc" s spos
6431 | Vopen ("bookmarks", _, closed) ->
6432 if closed
6433 then v
6434 else { v with f = pbookmarks path pan anchor c bookmarks }
6436 | Vopen ("keymap", attrs, closed) ->
6437 let modename =
6438 try List.assoc "mode" attrs
6439 with Not_found -> "global"
6441 if closed
6442 then v
6443 else
6444 let ret keymap =
6445 let h = findkeyhash c modename in
6446 KeyMap.iter (Hashtbl.replace h) keymap;
6447 doc path pan anchor c bookmarks
6449 { v with f = pkeymap ret KeyMap.empty }
6451 | Vopen (_, _, _) ->
6452 error "unexpected subelement in doc" s spos
6454 | Vclose "doc" ->
6455 Hashtbl.add h path (c, List.rev bookmarks, pan, anchor);
6456 { v with f = llppconfig }
6458 | Vclose _ -> error "unexpected close in doc" s spos
6460 and pkeymap ret keymap v t spos _ =
6461 match t with
6462 | Vdata | Vcdata -> v
6463 | Vend -> error "unexpected end of input in keymap" s spos
6464 | Vopen ("map", attrs, closed) ->
6465 let r, l = map_of attrs in
6466 let kss = fromstring keys_of_string spos "in" r [] in
6467 let lss = fromstring keys_of_string spos "out" l [] in
6468 let keymap =
6469 match kss with
6470 | [] -> keymap
6471 | ks :: [] -> KeyMap.add ks (KMinsrl lss) keymap
6472 | ks :: rest -> KeyMap.add ks (KMmulti (rest, lss)) keymap
6474 if closed
6475 then { v with f = pkeymap ret keymap }
6476 else
6477 let f () = v in
6478 { v with f = skip "map" f }
6480 | Vopen _ ->
6481 error "unexpected subelement in keymap" s spos
6483 | Vclose "keymap" ->
6484 { v with f = ret keymap }
6486 | Vclose _ -> error "unexpected close in keymap" s spos
6488 and pbookmarks path pan anchor c bookmarks v t spos _ =
6489 match t with
6490 | Vdata | Vcdata -> v
6491 | Vend -> error "unexpected end of input in bookmarks" s spos
6492 | Vopen ("item", attrs, closed) ->
6493 let titleent, spage, srely, svisy = bookmark_of attrs in
6494 let page = fromstring int_of_string spos "page" spage 0
6495 and rely = fromstring float_of_string spos "rely" srely 0.0
6496 and visy = fromstring float_of_string spos "visy" svisy 0.0 in
6497 let bookmarks =
6498 (unent titleent, 0, (page, rely, visy)) :: bookmarks
6500 if closed
6501 then { v with f = pbookmarks path pan anchor c bookmarks }
6502 else
6503 let f () = v in
6504 { v with f = skip "item" f }
6506 | Vopen _ ->
6507 error "unexpected subelement in bookmarks" s spos
6509 | Vclose "bookmarks" ->
6510 { v with f = doc path pan anchor c bookmarks }
6512 | Vclose _ -> error "unexpected close in bookmarks" s spos
6514 and skip tag f v t spos _ =
6515 match t with
6516 | Vdata | Vcdata -> v
6517 | Vend ->
6518 error ("unexpected end of input in skipped " ^ tag) s spos
6519 | Vopen (tag', _, closed) ->
6520 if closed
6521 then v
6522 else
6523 let f' () = { v with f = skip tag f } in
6524 { v with f = skip tag' f' }
6525 | Vclose ctag ->
6526 if tag = ctag
6527 then f ()
6528 else error ("unexpected close in skipped " ^ tag) s spos
6531 parse { f = toplevel; accu = () } s;
6532 h, dc;
6535 let do_load f ic =
6537 let len = in_channel_length ic in
6538 let s = String.create len in
6539 really_input ic s 0 len;
6540 f s;
6541 with
6542 | Parse_error (msg, s, pos) ->
6543 let subs = subs s pos in
6544 let s = Printf.sprintf "%s: at %d [..%s..]" msg pos subs in
6545 failwith ("parse error: " ^ s)
6547 | exn ->
6548 failwith ("config load error: " ^ Printexc.to_string exn)
6551 let defconfpath =
6552 let dir =
6554 let dir = Filename.concat home ".config" in
6555 if Sys.is_directory dir then dir else home
6556 with _ -> home
6558 Filename.concat dir "llpp.conf"
6561 let confpath = ref defconfpath;;
6563 let load1 f =
6564 if Sys.file_exists !confpath
6565 then
6566 match
6567 (try Some (open_in_bin !confpath)
6568 with exn ->
6569 prerr_endline
6570 ("Error opening configuation file `" ^ !confpath ^ "': " ^
6571 Printexc.to_string exn);
6572 None
6574 with
6575 | Some ic ->
6576 let success =
6578 f (do_load get ic)
6579 with exn ->
6580 prerr_endline
6581 ("Error loading configuation from `" ^ !confpath ^ "': " ^
6582 Printexc.to_string exn);
6583 false
6585 close_in ic;
6586 success
6588 | None -> false
6589 else
6590 f (Hashtbl.create 0, defconf)
6593 let load () =
6594 let f (h, dc) =
6595 let pc, pb, px, pa =
6597 Hashtbl.find h (Filename.basename state.path)
6598 with Not_found -> dc, [], 0, emptyanchor
6600 setconf defconf dc;
6601 setconf conf pc;
6602 state.bookmarks <- pb;
6603 state.x <- px;
6604 state.scrollw <- conf.scrollbw;
6605 if conf.jumpback
6606 then state.anchor <- pa;
6607 cbput state.hists.nav pa;
6608 true
6610 load1 f
6613 let add_attrs bb always dc c =
6614 let ob s a b =
6615 if always || a != b
6616 then Printf.bprintf bb "\n %s='%b'" s a
6617 and oi s a b =
6618 if always || a != b
6619 then Printf.bprintf bb "\n %s='%d'" s a
6620 and oI s a b =
6621 if always || a != b
6622 then Printf.bprintf bb "\n %s='%s'" s (string_with_suffix_of_int a)
6623 and oz s a b =
6624 if always || a <> b
6625 then Printf.bprintf bb "\n %s='%g'" s (a*.100.)
6626 and oF s a b =
6627 if always || a <> b
6628 then Printf.bprintf bb "\n %s='%f'" s a
6629 and oc s a b =
6630 if always || a <> b
6631 then
6632 Printf.bprintf bb "\n %s='%s'" s (color_to_string a)
6633 and oC s a b =
6634 if always || a <> b
6635 then
6636 Printf.bprintf bb "\n %s='%s'" s (colorspace_to_string a)
6637 and oR s a b =
6638 if always || a <> b
6639 then
6640 Printf.bprintf bb "\n %s='%s'" s (irect_to_string a)
6641 and os s a b =
6642 if always || a <> b
6643 then
6644 Printf.bprintf bb "\n %s='%s'" s (enent a 0 (String.length a))
6645 and og s a b =
6646 if always || a <> b
6647 then
6648 match a with
6649 | None -> ()
6650 | Some (_N, _A, _B) ->
6651 Printf.bprintf bb "\n %s='%u,%u,%u'" s _N _A _B
6652 and oW s a b =
6653 if always || a <> b
6654 then
6655 let v =
6656 match a with
6657 | None -> "false"
6658 | Some f ->
6659 if f = infinity
6660 then "true"
6661 else string_of_float f
6663 Printf.bprintf bb "\n %s='%s'" s v
6664 and oco s a b =
6665 if always || a <> b
6666 then
6667 match a with
6668 | Cmulti ((n, a, b), _) when n > 1 ->
6669 Printf.bprintf bb "\n %s='%d,%d,%d'" s n a b
6670 | Csplit (n, _) when n > 1 ->
6671 Printf.bprintf bb "\n %s='%d'" s ~-n
6672 | _ -> ()
6673 and obeco s a b =
6674 if always || a <> b
6675 then
6676 match a with
6677 | Some c when c > 1 -> Printf.bprintf bb "\n %s='%d'" s c
6678 | _ -> ()
6680 let w, h =
6681 if always
6682 then dc.winw, dc.winh
6683 else
6684 match state.fullscreen with
6685 | Some wh -> wh
6686 | None -> c.winw, c.winh
6688 oi "width" w dc.winw;
6689 oi "height" h dc.winh;
6690 oi "scroll-bar-width" c.scrollbw dc.scrollbw;
6691 oi "scroll-handle-height" c.scrollh dc.scrollh;
6692 ob "case-insensitive-search" c.icase dc.icase;
6693 ob "preload" c.preload dc.preload;
6694 oi "page-bias" c.pagebias dc.pagebias;
6695 oi "scroll-step" c.scrollstep dc.scrollstep;
6696 oi "auto-scroll-step" c.autoscrollstep dc.autoscrollstep;
6697 ob "max-height-fit" c.maxhfit dc.maxhfit;
6698 ob "crop-hack" c.crophack dc.crophack;
6699 oW "throttle" c.maxwait dc.maxwait;
6700 ob "highlight-links" c.hlinks dc.hlinks;
6701 ob "under-cursor-info" c.underinfo dc.underinfo;
6702 oi "vertical-margin" c.interpagespace dc.interpagespace;
6703 oz "zoom" c.zoom dc.zoom;
6704 ob "presentation" c.presentation dc.presentation;
6705 oi "rotation-angle" c.angle dc.angle;
6706 ob "persistent-bookmarks" c.savebmarks dc.savebmarks;
6707 ob "proportional-display" c.proportional dc.proportional;
6708 oI "pixmap-cache-size" c.memlimit dc.memlimit;
6709 oi "tex-count" c.texcount dc.texcount;
6710 oi "slice-height" c.sliceheight dc.sliceheight;
6711 oi "thumbnail-width" c.thumbw dc.thumbw;
6712 ob "persistent-location" c.jumpback dc.jumpback;
6713 oc "background-color" c.bgcolor dc.bgcolor;
6714 ob "scrollbar-in-presentation" c.scrollbarinpm dc.scrollbarinpm;
6715 oi "tile-width" c.tilew dc.tilew;
6716 oi "tile-height" c.tileh dc.tileh;
6717 oI "mupdf-store-size" c.mustoresize dc.mustoresize;
6718 ob "checkers" c.checkers dc.checkers;
6719 oi "aalevel" c.aalevel dc.aalevel;
6720 ob "trim-margins" c.trimmargins dc.trimmargins;
6721 oR "trim-fuzz" c.trimfuzz dc.trimfuzz;
6722 os "uri-launcher" c.urilauncher dc.urilauncher;
6723 os "path-launcher" c.pathlauncher dc.pathlauncher;
6724 oC "color-space" c.colorspace dc.colorspace;
6725 ob "invert-colors" c.invert dc.invert;
6726 oF "brightness" c.colorscale dc.colorscale;
6727 ob "redirectstderr" c.redirectstderr dc.redirectstderr;
6728 og "ghyllscroll" c.ghyllscroll dc.ghyllscroll;
6729 oco "columns" c.columns dc.columns;
6730 obeco "birds-eye-columns" c.beyecolumns dc.beyecolumns;
6731 os "selection-command" c.selcmd dc.selcmd;
6732 ob "update-cursor" c.updatecurs dc.updatecurs;
6733 oi "hint-font-size" c.hfsize dc.hfsize;
6734 oi "horizontal-scroll-step" c.hscrollstep dc.hscrollstep;
6735 oF "page-scroll-scale" c.pgscale dc.pgscale;
6736 ob "use-pbo" c.usepbo dc.usepbo;
6737 ob "wheel-scrolls-pages" c.wheelbypage dc.wheelbypage;
6740 let keymapsbuf always dc c =
6741 let bb = Buffer.create 16 in
6742 let rec loop = function
6743 | [] -> ()
6744 | (modename, h) :: rest ->
6745 let dh = findkeyhash dc modename in
6746 if always || h <> dh
6747 then (
6748 if Hashtbl.length h > 0
6749 then (
6750 if Buffer.length bb > 0
6751 then Buffer.add_char bb '\n';
6752 Printf.bprintf bb "<keymap mode='%s'>\n" modename;
6753 Hashtbl.iter (fun i o ->
6754 let isdifferent = always ||
6756 let dO = Hashtbl.find dh i in
6757 dO <> o
6758 with Not_found -> true
6760 if isdifferent
6761 then
6762 let addkm (k, m) =
6763 if Wsi.withctrl m then Buffer.add_string bb "ctrl-";
6764 if Wsi.withalt m then Buffer.add_string bb "alt-";
6765 if Wsi.withshift m then Buffer.add_string bb "shift-";
6766 if Wsi.withmeta m then Buffer.add_string bb "meta-";
6767 Buffer.add_string bb (Wsi.keyname k);
6769 let addkms l =
6770 let rec loop = function
6771 | [] -> ()
6772 | km :: [] -> addkm km
6773 | km :: rest -> addkm km; Buffer.add_char bb ' '; loop rest
6775 loop l
6777 Buffer.add_string bb "<map in='";
6778 addkm i;
6779 match o with
6780 | KMinsrt km ->
6781 Buffer.add_string bb "' out='";
6782 addkm km;
6783 Buffer.add_string bb "'/>\n"
6785 | KMinsrl kms ->
6786 Buffer.add_string bb "' out='";
6787 addkms kms;
6788 Buffer.add_string bb "'/>\n"
6790 | KMmulti (ins, kms) ->
6791 Buffer.add_char bb ' ';
6792 addkms ins;
6793 Buffer.add_string bb "' out='";
6794 addkms kms;
6795 Buffer.add_string bb "'/>\n"
6796 ) h;
6797 Buffer.add_string bb "</keymap>";
6800 loop rest
6802 loop c.keyhashes;
6806 let save () =
6807 let uifontsize = fstate.fontsize in
6808 let bb = Buffer.create 32768 in
6809 let f (h, dc) =
6810 let dc = if conf.bedefault then conf else dc in
6811 Buffer.add_string bb "<llppconfig>\n";
6813 if String.length !fontpath > 0
6814 then
6815 Printf.bprintf bb "<ui-font size='%d'><![CDATA[%s]]></ui-font>\n"
6816 uifontsize
6817 !fontpath
6818 else (
6819 if uifontsize <> 14
6820 then
6821 Printf.bprintf bb "<ui-font size='%d'/>\n" uifontsize
6824 Buffer.add_string bb "<defaults ";
6825 add_attrs bb true dc dc;
6826 let kb = keymapsbuf true dc dc in
6827 if Buffer.length kb > 0
6828 then (
6829 Buffer.add_string bb ">\n";
6830 Buffer.add_buffer bb kb;
6831 Buffer.add_string bb "\n</defaults>\n";
6833 else Buffer.add_string bb "/>\n";
6835 let adddoc path pan anchor c bookmarks =
6836 if bookmarks == [] && c = dc && anchor = emptyanchor
6837 then ()
6838 else (
6839 Printf.bprintf bb "<doc path='%s'"
6840 (enent path 0 (String.length path));
6842 if anchor <> emptyanchor
6843 then (
6844 let n, rely, visy = anchor in
6845 Printf.bprintf bb " page='%d'" n;
6846 if rely > 1e-6
6847 then
6848 Printf.bprintf bb " rely='%f'" rely
6850 if abs_float visy > 1e-6
6851 then
6852 Printf.bprintf bb " visy='%f'" visy
6856 if pan != 0
6857 then Printf.bprintf bb " pan='%d'" pan;
6859 add_attrs bb false dc c;
6860 let kb = keymapsbuf false dc c in
6862 begin match bookmarks with
6863 | [] ->
6864 if Buffer.length kb > 0
6865 then (
6866 Buffer.add_string bb ">\n";
6867 Buffer.add_buffer bb kb;
6868 Buffer.add_string bb "\n</doc>\n";
6870 else Buffer.add_string bb "/>\n"
6871 | _ ->
6872 Buffer.add_string bb ">\n<bookmarks>\n";
6873 List.iter (fun (title, _level, (page, rely, visy)) ->
6874 Printf.bprintf bb
6875 "<item title='%s' page='%d'"
6876 (enent title 0 (String.length title))
6877 page
6879 if rely > 1e-6
6880 then
6881 Printf.bprintf bb " rely='%f'" rely
6883 if abs_float visy > 1e-6
6884 then
6885 Printf.bprintf bb " visy='%f'" visy
6887 Buffer.add_string bb "/>\n";
6888 ) bookmarks;
6889 Buffer.add_string bb "</bookmarks>";
6890 if Buffer.length kb > 0
6891 then (
6892 Buffer.add_string bb "\n";
6893 Buffer.add_buffer bb kb;
6895 Buffer.add_string bb "\n</doc>\n";
6896 end;
6900 let pan, conf =
6901 match state.mode with
6902 | Birdseye (c, pan, _, _, _) ->
6903 let beyecolumns =
6904 match conf.columns with
6905 | Cmulti ((c, _, _), _) -> Some c
6906 | Csingle _ -> None
6907 | Csplit _ -> None
6908 and columns =
6909 match c.columns with
6910 | Cmulti (c, _) -> Cmulti (c, [||])
6911 | Csingle _ -> Csingle [||]
6912 | Csplit _ -> failwith "quit from bird's eye while split"
6914 pan, { c with beyecolumns = beyecolumns; columns = columns }
6915 | _ -> state.x, conf
6917 let basename = Filename.basename state.path in
6918 adddoc basename pan (getanchor ())
6919 (let conf =
6920 let autoscrollstep =
6921 match state.autoscroll with
6922 | Some step -> step
6923 | None -> conf.autoscrollstep
6925 match state.mode with
6926 | Birdseye (bc, _, _, _, _) ->
6927 { conf with
6928 zoom = bc.zoom;
6929 presentation = bc.presentation;
6930 interpagespace = bc.interpagespace;
6931 maxwait = bc.maxwait;
6932 autoscrollstep = autoscrollstep }
6933 | _ -> { conf with autoscrollstep = autoscrollstep }
6934 in conf)
6935 (if conf.savebmarks then state.bookmarks else []);
6937 Hashtbl.iter (fun path (c, bookmarks, x, anchor) ->
6938 if basename <> path
6939 then adddoc path x anchor c bookmarks
6940 ) h;
6941 Buffer.add_string bb "</llppconfig>\n";
6942 true;
6944 if load1 f && Buffer.length bb > 0
6945 then
6947 let tmp = !confpath ^ ".tmp" in
6948 let oc = open_out_bin tmp in
6949 Buffer.output_buffer oc bb;
6950 close_out oc;
6951 Unix.rename tmp !confpath;
6952 with exn ->
6953 prerr_endline
6954 ("error while saving configuration: " ^ Printexc.to_string exn)
6956 end;;
6958 let () =
6959 let trimcachepath = ref "" in
6960 Arg.parse
6961 (Arg.align
6962 [("-p", Arg.String (fun s -> state.password <- s) ,
6963 "<password> Set password");
6965 ("-f", Arg.String (fun s -> Config.fontpath := s),
6966 "<path> Set path to the user interface font");
6968 ("-c", Arg.String (fun s -> Config.confpath := s),
6969 "<path> Set path to the configuration file");
6971 ("-tcf", Arg.String (fun s -> trimcachepath := s),
6972 "<path> Set path to the trim cache file");
6974 ("-dest", Arg.String (fun s -> state.nameddest <- s),
6975 "<named destination> Set named destination");
6977 ("-wtmode", Arg.Set wtmode, "wt mode");
6979 ("-v", Arg.Unit (fun () ->
6980 Printf.printf
6981 "%s\nconfiguration path: %s\n"
6982 (version ())
6983 Config.defconfpath
6985 exit 0), " Print version and exit");
6988 (fun s -> state.path <- s)
6989 ("Usage: " ^ Sys.argv.(0) ^ " [options] some.pdf\nOptions:")
6991 if String.length state.path = 0
6992 then (prerr_endline "file name missing"; exit 1);
6994 if not (Config.load ())
6995 then prerr_endline "failed to load configuration";
6997 let globalkeyhash = findkeyhash conf "global" in
6998 let wsfd, winw, winh = Wsi.init (object
6999 method expose =
7000 state.wthack <- false;
7001 if nogeomcmds state.geomcmds || platform == Posx
7002 then display ()
7003 else (
7004 GlClear.color (scalecolor2 conf.bgcolor);
7005 GlClear.clear [`color];
7007 method display = display ()
7008 method reshape w h = reshape w h
7009 method mouse b d x y m = mouse b d x y m
7010 method motion x y = state.mpos <- (x, y); motion x y
7011 method pmotion x y = state.mpos <- (x, y); pmotion x y
7012 method key k m =
7013 let mascm = m land (
7014 Wsi.altmask + Wsi.shiftmask + Wsi.ctrlmask + Wsi.metamask
7015 ) in
7016 match state.keystate with
7017 | KSnone ->
7018 let km = k, mascm in
7019 begin
7020 match
7021 let modehash = state.uioh#modehash in
7022 try Hashtbl.find modehash km
7023 with Not_found ->
7024 try Hashtbl.find globalkeyhash km
7025 with Not_found -> KMinsrt (k, m)
7026 with
7027 | KMinsrt (k, m) -> keyboard k m
7028 | KMinsrl l -> List.iter (fun (k, m) -> keyboard k m) l
7029 | KMmulti (l, r) -> state.keystate <- KSinto (l, r)
7031 | KSinto ((k', m') :: [], insrt) when k'=k && m' land mascm = m' ->
7032 List.iter (fun (k, m) -> keyboard k m) insrt;
7033 state.keystate <- KSnone
7034 | KSinto ((k', m') :: keys, insrt) when k'=k && m' land mascm = m' ->
7035 state.keystate <- KSinto (keys, insrt)
7036 | _ ->
7037 state.keystate <- KSnone
7039 method enter x y = state.mpos <- (x, y); pmotion x y
7040 method leave = state.mpos <- (-1, -1)
7041 method quit = raise Quit
7042 end) conf.winw conf.winh (platform = Posx) in
7044 state.wsfd <- wsfd;
7046 if not (
7047 List.exists GlMisc.check_extension
7048 [ "GL_ARB_texture_rectangle"
7049 ; "GL_EXT_texture_recangle"
7050 ; "GL_NV_texture_rectangle" ]
7052 then (prerr_endline "OpenGL does not suppport rectangular textures"; exit 1);
7054 let cr, sw =
7055 match Ne.pipe () with
7056 | Ne.Exn exn ->
7057 Printf.eprintf "pipe/crsw failed: %s" (Printexc.to_string exn);
7058 exit 1
7059 | Ne.Res rw -> rw
7060 and sr, cw =
7061 match Ne.pipe () with
7062 | Ne.Exn exn ->
7063 Printf.eprintf "pipe/srcw failed: %s" (Printexc.to_string exn);
7064 exit 1
7065 | Ne.Res rw -> rw
7068 cloexec cr;
7069 cloexec sw;
7070 cloexec sr;
7071 cloexec cw;
7073 setcheckers conf.checkers;
7074 redirectstderr ();
7076 init (cr, cw) (
7077 conf.angle, conf.proportional, (conf.trimmargins, conf.trimfuzz),
7078 conf.texcount, conf.sliceheight, conf.mustoresize, conf.colorspace,
7079 !Config.fontpath, !trimcachepath,
7080 GlMisc.check_extension "GL_ARB_pixel_buffer_object"
7082 state.sr <- sr;
7083 state.sw <- sw;
7084 state.text <- "Opening " ^ (mbtoutf8 state.path);
7085 reshape winw winh;
7086 opendoc state.path state.password;
7087 state.uioh <- uioh;
7089 Sys.set_signal Sys.sighup (Sys.Signal_handle (fun _ -> reload ()));
7091 let rec loop deadline =
7092 let r =
7093 match state.errfd with
7094 | None -> [state.sr; state.wsfd]
7095 | Some fd -> [state.sr; state.wsfd; fd]
7097 if state.redisplay
7098 then (
7099 state.redisplay <- false;
7100 display ();
7102 let timeout =
7103 let now = now () in
7104 if deadline > now
7105 then (
7106 if deadline = infinity
7107 then ~-.1.0
7108 else max 0.0 (deadline -. now)
7110 else 0.0
7112 let r, _, _ =
7113 try tempfailureretry (Unix.select r [] []) timeout
7114 with Unix.Unix_error (Unix.EINTR, _, _) -> [], [], []
7116 begin match r with
7117 | [] ->
7118 state.ghyll None;
7119 let newdeadline =
7120 if state.ghyll == noghyll
7121 then
7122 match state.autoscroll with
7123 | Some step when step != 0 ->
7124 let y = state.y + step in
7125 let y =
7126 if y < 0
7127 then state.maxy
7128 else if y >= state.maxy then 0 else y
7130 gotoy y;
7131 if state.mode = View
7132 then state.text <- "";
7133 deadline +. 0.01
7134 | _ -> infinity
7135 else deadline +. 0.01
7137 loop newdeadline
7139 | l ->
7140 let rec checkfds = function
7141 | [] -> ()
7142 | fd :: rest when fd = state.sr ->
7143 let cmd = readcmd state.sr in
7144 act cmd;
7145 checkfds rest
7147 | fd :: rest when fd = state.wsfd ->
7148 Wsi.readresp fd;
7149 checkfds rest
7151 | fd :: rest ->
7152 let s = String.create 80 in
7153 let n = tempfailureretry (Unix.read fd s 0) 80 in
7154 if conf.redirectstderr
7155 then (
7156 Buffer.add_substring state.errmsgs s 0 n;
7157 state.newerrmsgs <- true;
7158 state.redisplay <- true;
7160 else (
7161 prerr_string (String.sub s 0 n);
7162 flush stderr;
7164 checkfds rest
7166 checkfds l;
7167 let newdeadline =
7168 let deadline1 =
7169 if deadline = infinity
7170 then now () +. 0.01
7171 else deadline
7173 match state.autoscroll with
7174 | Some step when step != 0 -> deadline1
7175 | _ -> if state.ghyll == noghyll then infinity else deadline1
7177 loop newdeadline
7178 end;
7181 loop infinity;
7182 with Quit ->
7183 Config.save ();