Fix corner case
[llpp.git] / main.ml
blob0a32e9c3da764ddb50ca3ce6b7140532b3ea8cd7
1 open Utils;;
2 open Config;;
4 exception Quit;;
6 external init : Unix.file_descr -> initparams -> unit = "ml_init";;
7 external seltext : opaque -> (int * int * int * int) -> unit = "ml_seltext";;
8 external hassel : opaque -> bool = "ml_hassel";;
9 external getpdimrect : int -> float array = "ml_getpdimrect";;
10 external whatsunder : opaque -> int -> int -> under = "ml_whatsunder";;
11 external markunder : opaque -> int -> int -> mark -> bool = "ml_markunder";;
12 external clearmark : opaque -> unit = "ml_clearmark";;
13 external zoomforh : int -> int -> int -> int -> float = "ml_zoom_for_height";;
14 external getmaxw : unit -> float = "ml_getmaxw";;
15 external drawstr : int -> int -> int -> string -> float = "ml_draw_string";;
16 external measurestr : int -> string -> float = "ml_measure_string";;
17 external postprocess : opaque -> int -> int -> int -> (int * string * int)
18 -> int = "ml_postprocess";;
19 external pagebbox : opaque -> (int * int * int * int) = "ml_getpagebox";;
20 external setaalevel : int -> unit = "ml_setaalevel";;
21 external realloctexts : int -> bool = "ml_realloctexts";;
22 external findlink : opaque -> linkdir -> link = "ml_findlink";;
23 external getlink : opaque -> int -> under = "ml_getlink";;
24 external getlinkrect : opaque -> int -> irect = "ml_getlinkrect";;
25 external getlinkcount : opaque -> int = "ml_getlinkcount";;
26 external findpwl : int -> int -> pagewithlinks = "ml_find_page_with_links";;
27 external getpbo : width -> height -> colorspace -> opaque = "ml_getpbo";;
28 external freepbo : opaque -> unit = "ml_freepbo";;
29 external unmappbo : opaque -> unit = "ml_unmappbo";;
30 external bousable : unit -> bool = "ml_bo_usable";;
31 external unproject : opaque -> int -> int
32 -> (int * int) option = "ml_unproject";;
33 external project : opaque -> int -> int -> float -> float
34 -> (float * float) = "ml_project";;
35 external drawtile : tileparams -> opaque
36 -> unit = "ml_drawtile";;
37 external rectofblock : opaque -> int -> int
38 -> float array option = "ml_rectofblock";;
39 external begintiles : unit -> unit = "ml_begintiles";;
40 external endtiles : unit -> unit = "ml_endtiles";;
41 external addannot : opaque -> int -> int -> string -> unit = "ml_addannot";;
42 external modannot : opaque -> slinkindex -> string -> unit = "ml_modannot";;
43 external delannot : opaque -> slinkindex -> unit = "ml_delannot";;
44 external hasunsavedchanges : unit -> bool = "ml_hasunsavedchanges";;
45 external savedoc : string -> unit = "ml_savedoc";;
46 external getannotcontents : opaque -> slinkindex
47 -> string = "ml_getannotcontents";;
48 external drawprect : opaque -> int -> int -> float array
49 -> unit = "ml_drawprect";;
50 external wcmd : Unix.file_descr -> bytes -> int -> unit = "ml_wcmd";;
51 external rcmd : Unix.file_descr -> string = "ml_rcmd";;
52 external uritolocation : string
53 -> (pageno * float * float) = "ml_uritolocation";;
54 external isexternallink : string -> bool = "ml_isexternallink";;
56 (* copysel _will_ close the supplied descriptor *)
57 external copysel : Unix.file_descr -> opaque -> unit = "ml_copysel";;
59 let selfexec = ref E.s;;
60 let opengl_has_pbo = ref false;;
62 let drawstring size x y s =
63 Gl.enable `blend;
64 Gl.enable `texture_2d;
65 GlFunc.blend_func ~src:`src_alpha ~dst:`one_minus_src_alpha;
66 ignore (drawstr size x y s);
67 Gl.disable `blend;
68 Gl.disable `texture_2d;
71 let drawstring1 size x y s =
72 drawstr size x y s;
75 let drawstring2 size x y fmt =
76 Printf.kprintf (drawstring size (x+1) (y+size+1)) fmt
79 module UniSyms = struct
80 let ellipsis = "\xe2\x80\xa6";;
81 let radical = "\xe2\x88\x9a";;
82 let lguillemet = "\xc2\xab";;
83 let rguillemet = "\xc2\xbb";;
84 end;;
86 let _debugl l =
87 dolog {|l %d dim=%d {
88 WxH %dx%d
89 vWxH %dx%d
90 pagex,y %d,%d
91 dispx,y %d,%d
92 column %d\n
93 }|}
94 l.pageno l.pagedimno
95 l.pagew l.pageh
96 l.pagevw l.pagevh
97 l.pagex l.pagey
98 l.pagedispx l.pagedispy
99 l.pagecol
102 let debugrect (x0, y0, x1, y1, x2, y2, x3, y3) =
103 dolog {|rect {
104 x0,y0=(% f, % f)
105 x1,y1=(% f, % f)
106 x2,y2=(% f, % f)
107 x3,y3=(% f, % f)
108 }|} x0 y0 x1 y1 x2 y2 x3 y3;
111 let isbirdseye = function
112 | Birdseye _ -> true
113 | Textentry _ | View | LinkNav _ -> false
116 let istextentry = function
117 | Textentry _ -> true
118 | Birdseye _ | View | LinkNav _ -> false
121 let wtmode = ref false;;
122 let cxack = ref false;;
124 let pgscale h = truncate (float h *. conf.pgscale);;
126 let hscrollh () =
127 if state.uioh#alwaysscrolly || ((conf.scrollb land scrollbhv != 0)
128 && (state.w > state.winw))
129 then conf.scrollbw
130 else 0
133 let vscrollw () =
134 if state.uioh#alwaysscrolly || ((conf.scrollb land scrollbvv != 0)
135 && (state.maxy > state.winh))
136 then conf.scrollbw
137 else 0
140 let vscrollhit x =
141 if conf.leftscroll
142 then x < vscrollw ()
143 else x > state.winw - vscrollw ()
146 let setfontsize n =
147 fstate.fontsize <- n;
148 fstate.wwidth <- measurestr fstate.fontsize "w";
149 fstate.maxrows <- (state.winh - fstate.fontsize - 1) / (fstate.fontsize + 1);
152 let vlog fmt =
153 if conf.verbose
154 then dolog fmt
155 else Printf.kprintf ignore fmt
158 let launchpath () =
159 if emptystr conf.pathlauncher
160 then dolog "%s" state.path
161 else (
162 let command = Str.global_replace percentsre state.path conf.pathlauncher in
163 match spawn command [] with
164 | _pid -> ()
165 | exception exn ->
166 dolog "failed to execute `%s': %s" command @@ exntos exn
170 module G =
171 struct
172 let postRedisplay who =
173 vlog "redisplay for [%S]" who;
174 state.redisplay <- true;
176 end;;
178 let getopaque pageno =
179 try Some (Hashtbl.find state.pagemap (pageno, state.gen))
180 with Not_found -> None
183 let pagetranslatepoint l x y =
184 let dy = y - l.pagedispy in
185 let y = dy + l.pagey in
186 let dx = x - l.pagedispx in
187 let x = dx + l.pagex in
188 (x, y);
191 let onppundermouse g x y d =
192 let rec f = function
193 | l :: rest ->
194 begin match getopaque l.pageno with
195 | Some opaque ->
196 let x0 = l.pagedispx in
197 let x1 = x0 + l.pagevw in
198 let y0 = l.pagedispy in
199 let y1 = y0 + l.pagevh in
200 if y >= y0 && y <= y1 && x >= x0 && x <= x1
201 then
202 let px, py = pagetranslatepoint l x y in
203 match g opaque l px py with
204 | Some res -> res
205 | None -> f rest
206 else f rest
207 | _ ->
208 f rest
210 | [] -> d
212 f state.layout
215 let getunder x y =
216 let g opaque l px py =
217 if state.bzoom
218 then (
219 match rectofblock opaque px py with
220 | Some [|x0;x1;y0;y1|] ->
221 let rect = (x0, y0, x1, y0, x1, y1, x0, y1) in
222 let color = (0.0, 0.0, 1.0 /. (l.pageno mod 3 |> float), 0.5) in
223 state.rects <- [l.pageno, color, rect];
224 G.postRedisplay "getunder";
225 | _ -> ()
227 let under = whatsunder opaque px py in
228 if under = Unone then None else Some under
230 onppundermouse g x y Unone
233 let unproject x y =
234 let g opaque l x y =
235 match unproject opaque x y with
236 | Some (x, y) -> Some (Some (opaque, l.pageno, x, y))
237 | None -> None
239 onppundermouse g x y None;
242 let showtext c s =
243 state.text <- Printf.sprintf "%c%s" c s;
244 G.postRedisplay "showtext";
247 let impmsg fmt =
248 Format.ksprintf (fun s -> showtext '!' s) fmt;
251 let pipef ?(closew=true) cap f cmd =
252 match Unix.pipe () with
253 | exception exn -> dolog "%s cannot create pipe: %S" cap @@ exntos exn
254 | (r, w) ->
255 begin match spawn cmd [r, 0; w, -1] with
256 | exception exn -> dolog "%s: cannot execute %S: %s" cap cmd @@ exntos exn
257 | _pid -> f w
258 end;
259 Ne.clo r (dolog "%s failed to close r: %s" cap);
260 if closew then Ne.clo w (dolog "%s failed to close w: %s" cap);
263 let pipesel opaque cmd =
264 if hassel opaque
265 then pipef ~closew:false "pipesel"
266 (fun w ->
267 copysel w opaque;
268 G.postRedisplay "pipesel"
269 ) cmd
272 let paxunder x y =
273 let g opaque l px py =
274 if markunder opaque px py conf.paxmark
275 then (
276 Some (fun () ->
277 match getopaque l.pageno with
278 | None -> ()
279 | Some opaque -> pipesel opaque conf.paxcmd
282 else None
284 G.postRedisplay "paxunder";
285 if conf.paxmark = Mark_page
286 then
287 List.iter (fun l ->
288 match getopaque l.pageno with
289 | None -> ()
290 | Some opaque -> clearmark opaque) state.layout;
291 state.roam <- onppundermouse g x y (fun () -> impmsg "whoopsie daisy");
294 let selstring s =
295 pipef
296 "selstring" (fun w ->
298 let l = String.length s in
299 let bytes = Bytes.unsafe_of_string s in
300 let n = tempfailureretry (Unix.write w bytes 0) l in
301 if n != l
302 then impmsg "failed to write %d characters to sel pipe, wrote %d" l n;
303 with exn -> impmsg "failed to write to sel pipe: %s" @@ exntos exn
304 ) conf.selcmd
307 let undertext = function
308 | Unone -> "none"
309 | Ulinkuri s -> s
310 | Utext s -> "font: " ^ s
311 | Uannotation (opaque, slinkindex) ->
312 "annotation: " ^ getannotcontents opaque slinkindex
315 let updateunder x y =
316 match getunder x y with
317 | Unone -> Wsi.setcursor Wsi.CURSOR_INHERIT
318 | Ulinkuri uri ->
319 if conf.underinfo then showtext 'u' ("ri: " ^ uri);
320 Wsi.setcursor Wsi.CURSOR_INFO
321 | Utext s ->
322 if conf.underinfo then showtext 'f' ("ont: " ^ s);
323 Wsi.setcursor Wsi.CURSOR_TEXT
324 | Uannotation _ ->
325 if conf.underinfo then showtext 'a' "nnotation";
326 Wsi.setcursor Wsi.CURSOR_INFO
329 let showlinktype under =
330 if conf.underinfo && under != Unone
331 then showtext ' ' @@ undertext under
334 let [@warning "-4"] intentry_with_suffix text key =
335 let text =
336 match key with
337 | Keys.Ascii ('0'..'9' as c) -> addchar text c
338 | Keys.Ascii ('k' | 'm' | 'g' | 'K' | 'M' | 'G' as c) ->
339 addchar text @@ asciilower c
340 | _ ->
341 state.text <- Printf.sprintf "invalid key";
342 text
344 TEcont text
347 let wcmd fmt =
348 let b = Buffer.create 16 in
349 Printf.kbprintf
350 (fun b ->
351 let b = Buffer.to_bytes b in
352 wcmd state.ss b @@ Bytes.length b
353 ) b fmt
356 let nogeomcmds cmds =
357 match cmds with
358 | s, [] -> emptystr s
359 | _ -> false
362 let layoutN ((columns, coverA, coverB), b) x y sw sh =
363 let rec fold accu n =
364 if n = Array.length b
365 then accu
366 else
367 let pdimno, dx, vy, (_, w, h, xoff) = b.(n) in
368 if (vy - y) > sh &&
369 (n = coverA - 1
370 || n = state.pagecount - coverB
371 || (n - coverA) mod columns = columns - 1)
372 then accu
373 else
374 let accu =
375 if vy + h > y
376 then
377 let pagey = max 0 (y - vy) in
378 let pagedispy = if pagey > 0 then 0 else vy - y in
379 let pagedispx, pagex =
380 let pdx =
381 if n = coverA - 1 || n = state.pagecount - coverB
382 then x + (sw - w) / 2
383 else dx + xoff + x
385 if pdx < 0
386 then 0, -pdx
387 else pdx, 0
389 let pagevw =
390 let vw = sw - pagedispx in
391 let pw = w - pagex in
392 min vw pw
394 let pagevh = min (h - pagey) (sh - pagedispy) in
395 if pagevw > 0 && pagevh > 0
396 then
397 let e =
398 { pageno = n
399 ; pagedimno = pdimno
400 ; pagew = w
401 ; pageh = h
402 ; pagex = pagex
403 ; pagey = pagey
404 ; pagevw = pagevw
405 ; pagevh = pagevh
406 ; pagedispx = pagedispx
407 ; pagedispy = pagedispy
408 ; pagecol = 0
411 e :: accu
412 else
413 accu
414 else
415 accu
417 fold accu (n+1)
419 if Array.length b = 0
420 then []
421 else List.rev (fold [] (page_of_y y))
424 let layoutS (columns, b) x y sw sh =
425 let rec fold accu n =
426 if n = Array.length b
427 then accu
428 else
429 let pdimno, px, vy, (_, pagew, pageh, xoff) = b.(n) in
430 if (vy - y) > sh
431 then accu
432 else
433 let accu =
434 if vy + pageh > y
435 then
436 let x = xoff + x in
437 let pagey = max 0 (y - vy) in
438 let pagedispy = if pagey > 0 then 0 else vy - y in
439 let pagedispx, pagex =
440 if px = 0
441 then (
442 if x < 0
443 then 0, -x
444 else x, 0
446 else (
447 let px = px - x in
448 if px < 0
449 then -px, 0
450 else 0, px
453 let pagecolw = pagew/columns in
454 let pagedispx =
455 if pagecolw < sw
456 then pagedispx + ((sw - pagecolw) / 2)
457 else pagedispx
459 let pagevw =
460 let vw = sw - pagedispx in
461 let pw = pagew - pagex in
462 min vw pw
464 let pagevw = min pagevw pagecolw in
465 let pagevh = min (pageh - pagey) (sh - pagedispy) in
466 if pagevw > 0 && pagevh > 0
467 then
468 let e =
469 { pageno = n/columns
470 ; pagedimno = pdimno
471 ; pagew = pagew
472 ; pageh = pageh
473 ; pagex = pagex
474 ; pagey = pagey
475 ; pagevw = pagevw
476 ; pagevh = pagevh
477 ; pagedispx = pagedispx
478 ; pagedispy = pagedispy
479 ; pagecol = n mod columns
482 e :: accu
483 else
484 accu
485 else
486 accu
488 fold accu (n+1)
490 List.rev (fold [] 0)
493 let layout x y sw sh =
494 if nogeomcmds state.geomcmds
495 then
496 match conf.columns with
497 | Csingle b -> layoutN ((1, 0, 0), b) x y sw sh
498 | Cmulti c -> layoutN c x y sw sh
499 | Csplit s -> layoutS s x y sw sh
500 else []
503 let maxy () = state.maxy - if conf.maxhfit then state.winh else 0;;
505 let clamp incr = bound (state.y + incr) 0 @@ maxy ();;
507 let itertiles l f =
508 let tilex = l.pagex mod conf.tilew in
509 let tiley = l.pagey mod conf.tileh in
511 let col = l.pagex / conf.tilew in
512 let row = l.pagey / conf.tileh in
514 let rec rowloop row y0 dispy h =
515 if h = 0
516 then ()
517 else (
518 let dh = conf.tileh - y0 in
519 let dh = min h dh in
520 let rec colloop col x0 dispx w =
521 if w = 0
522 then ()
523 else (
524 let dw = conf.tilew - x0 in
525 let dw = min w dw in
526 f col row dispx dispy x0 y0 dw dh;
527 colloop (col+1) 0 (dispx+dw) (w-dw)
530 colloop col tilex l.pagedispx l.pagevw;
531 rowloop (row+1) 0 (dispy+dh) (h-dh)
534 if l.pagevw > 0 && l.pagevh > 0
535 then rowloop row tiley l.pagedispy l.pagevh;
538 let gettileopaque l col row =
539 let key =
540 l.pageno, state.gen, conf.colorspace, conf.angle, l.pagew, l.pageh, col, row
542 try Some (Hashtbl.find state.tilemap key)
543 with Not_found -> None
546 let puttileopaque l col row gen colorspace angle opaque size elapsed =
547 let key = l.pageno, gen, colorspace, angle, l.pagew, l.pageh, col, row in
548 Hashtbl.add state.tilemap key (opaque, size, elapsed)
551 let filledrect2 x0 y0 x1 y1 x2 y2 x3 y3 =
552 Raw.sets_float state.vraw ~pos:0 [| x0; y0; x1; y1; x2; y2; x3; y3 |];
553 GlArray.vertex `two state.vraw;
554 GlArray.draw_arrays `triangle_strip ~first:0 ~count:4;
557 let filledrect1 x0 y0 x1 y1 = filledrect2 x0 y0 x0 y1 x1 y0 x1 y1;;
559 let filledrect x0 y0 x1 y1 =
560 GlArray.disable `texture_coord;
561 filledrect1 x0 y0 x1 y1;
562 GlArray.enable `texture_coord;
565 let linerect x0 y0 x1 y1 =
566 GlArray.disable `texture_coord;
567 Raw.sets_float state.vraw ~pos:0 [| x0; y0; x0; y1; x1; y1; x1; y0 |];
568 GlArray.vertex `two state.vraw;
569 GlArray.draw_arrays `line_loop ~first:0 ~count:4;
570 GlArray.enable `texture_coord;
573 let drawtiles l color =
574 GlDraw.color color;
575 begintiles ();
576 let f col row x y tilex tiley w h =
577 match gettileopaque l col row with
578 | Some (opaque, _, t) ->
579 let params = x, y, w, h, tilex, tiley in
580 if conf.invert
581 then GlTex.env (`mode `blend);
582 drawtile params opaque;
583 if conf.invert
584 then GlTex.env (`mode `modulate);
585 if conf.debug
586 then (
587 endtiles ();
588 let s = Printf.sprintf
589 "%d[%d,%d] %f sec"
590 l.pageno col row t
592 let w = measurestr fstate.fontsize s in
593 GlDraw.color (0.0, 0.0, 0.0);
594 filledrect (float (x-2))
595 (float (y-2))
596 (float (x+2) +. w)
597 (float (y + fstate.fontsize + 2));
598 GlDraw.color color;
599 drawstring fstate.fontsize x (y + fstate.fontsize - 1) s;
600 begintiles ();
603 | None ->
604 endtiles ();
605 let w =
606 let lw = state.winw - x in
607 min lw w
608 and h =
609 let lh = state.winh - y in
610 min lh h
612 if conf.invert
613 then GlTex.env (`mode `blend);
614 begin match state.checkerstexid with
615 | Some id ->
616 Gl.enable `texture_2d;
617 GlTex.bind_texture ~target:`texture_2d id;
618 let x0 = float x
619 and y0 = float y
620 and x1 = float (x+w)
621 and y1 = float (y+h) in
623 let tw = float w /. 16.0
624 and th = float h /. 16.0 in
625 let tx0 = float tilex /. 16.0
626 and ty0 = float tiley /. 16.0 in
627 let tx1 = tx0 +. tw
628 and ty1 = ty0 +. th in
629 Raw.sets_float state.vraw ~pos:0
630 [| x0; y0; x0; y1; x1; y0; x1; y1 |];
631 Raw.sets_float state.traw ~pos:0
632 [| tx0; ty0; tx0; ty1; tx1; ty0; tx1; ty1 |];
633 GlArray.vertex `two state.vraw;
634 GlArray.tex_coord `two state.traw;
635 GlArray.draw_arrays `triangle_strip ~first:0 ~count:4;
636 Gl.disable `texture_2d;
638 | None ->
639 GlDraw.color (1.0, 1.0, 1.0);
640 filledrect (float x) (float y) (float (x+w)) (float (y+h));
641 end;
642 if conf.invert
643 then GlTex.env (`mode `modulate);
644 if w > 128 && h > fstate.fontsize + 10
645 then (
646 let c = if conf.invert then 1.0 else 0.0 in
647 GlDraw.color (c, c, c);
648 let c, r =
649 if conf.verbose
650 then (col*conf.tilew, row*conf.tileh)
651 else col, row
653 drawstring2 fstate.fontsize x y "Loading %d [%d,%d]" l.pageno c r;
655 GlDraw.color color;
656 begintiles ();
658 itertiles l f;
659 endtiles ();
662 let pagevisible layout n = List.exists (fun l -> l.pageno = n) layout;;
664 let tilevisible1 l x y =
665 let ax0 = l.pagex
666 and ax1 = l.pagex + l.pagevw
667 and ay0 = l.pagey
668 and ay1 = l.pagey + l.pagevh in
670 let bx0 = x
671 and by0 = y in
672 let bx1 = min (bx0 + conf.tilew) l.pagew
673 and by1 = min (by0 + conf.tileh) l.pageh in
675 let rx0 = max ax0 bx0
676 and ry0 = max ay0 by0
677 and rx1 = min ax1 bx1
678 and ry1 = min ay1 by1 in
680 let nonemptyintersection = rx1 > rx0 && ry1 > ry0 in
681 nonemptyintersection
684 let tilevisible layout n x y =
685 let rec findpageinlayout m = function
686 | l :: rest when l.pageno = n ->
687 tilevisible1 l x y || (
688 match conf.columns with
689 | Csplit (c, _) when c > m -> findpageinlayout (m+1) rest
690 | Csplit _ | Csingle _ | Cmulti _ -> false
692 | _ :: rest -> findpageinlayout 0 rest
693 | [] -> false
695 findpageinlayout 0 layout;
698 let tileready l x y =
699 tilevisible1 l x y &&
700 gettileopaque l (x/conf.tilew) (y/conf.tileh) != None
703 let tilepage n p layout =
704 let rec loop = function
705 | l :: rest ->
706 if l.pageno = n
707 then
708 let f col row _ _ _ _ _ _ =
709 if state.currently = Idle
710 then
711 match gettileopaque l col row with
712 | Some _ -> ()
713 | None ->
714 let x = col*conf.tilew
715 and y = row*conf.tileh in
716 let w =
717 let w = l.pagew - x in
718 min w conf.tilew
720 let h =
721 let h = l.pageh - y in
722 min h conf.tileh
724 let pbo =
725 if conf.usepbo
726 then getpbo w h conf.colorspace
727 else ~< "0"
729 wcmd "tile %s %d %d %d %d %s"
730 (~> p) x y w h (~> pbo);
731 state.currently <-
732 Tiling (
733 l, p, conf.colorspace, conf.angle,
734 state.gen, col, row, conf.tilew, conf.tileh
737 itertiles l f;
738 else
739 loop rest
741 | [] -> ()
743 if nogeomcmds state.geomcmds
744 then loop layout;
747 let preloadlayout x y sw sh =
748 let y = if y < sh then 0 else y - sh in
749 let x = min 0 (x + sw) in
750 let h = sh*3 in
751 let w = sw*3 in
752 layout x y w h;
755 let load pages =
756 let rec loop pages =
757 if state.currently != Idle
758 then ()
759 else
760 match pages with
761 | l :: rest ->
762 begin match getopaque l.pageno with
763 | None ->
764 wcmd "page %d %d" l.pageno l.pagedimno;
765 state.currently <- Loading (l, state.gen);
766 | Some opaque ->
767 tilepage l.pageno opaque pages;
768 loop rest
769 end;
770 | _ -> ()
772 if nogeomcmds state.geomcmds
773 then loop pages
776 let preload pages =
777 load pages;
778 if conf.preload && state.currently = Idle
779 then load (preloadlayout state.x state.y state.winw state.winh);
782 let layoutready layout =
783 let rec fold all ls =
784 all && match ls with
785 | l :: rest ->
786 let seen = ref false in
787 let allvisible = ref true in
788 let foo col row _ _ _ _ _ _ =
789 seen := true;
790 allvisible := !allvisible &&
791 begin match gettileopaque l col row with
792 | Some _ -> true
793 | None -> false
796 itertiles l foo;
797 fold (!seen && !allvisible) rest
798 | [] -> true
800 let alltilesvisible = fold true layout in
801 alltilesvisible;
804 let gotoxy x y =
805 let y = bound y 0 state.maxy in
806 let y, layout, proceed =
807 match conf.maxwait with
808 | Some time when state.ghyll == noghyll ->
809 begin match state.throttle with
810 | None ->
811 let layout = layout x y state.winw state.winh in
812 let ready = layoutready layout in
813 if not ready
814 then (
815 load layout;
816 state.throttle <- Some (layout, y, now ());
818 else G.postRedisplay "gotoxy showall (None)";
819 y, layout, ready
820 | Some (_, _, started) ->
821 let dt = now () -. started in
822 if dt > time
823 then (
824 state.throttle <- None;
825 let layout = layout x y state.winw state.winh in
826 load layout;
827 G.postRedisplay "maxwait";
828 y, layout, true
830 else -1, [], false
833 | _ ->
834 let layout = layout x y state.winw state.winh in
835 if not !wtmode || layoutready layout
836 then G.postRedisplay "gotoxy ready";
837 y, layout, true
839 if proceed
840 then (
841 state.x <- x;
842 state.y <- y;
843 state.layout <- layout;
844 begin match state.mode with
845 | LinkNav ln ->
846 begin match ln with
847 | Ltexact (pageno, linkno) ->
848 let rec loop = function
849 | [] ->
850 state.lnava <- Some (pageno, linkno);
851 state.mode <- LinkNav (Ltgendir 0)
852 | l :: _ when l.pageno = pageno ->
853 begin match getopaque pageno with
854 | None -> state.mode <- LinkNav (Ltnotready (pageno, 0))
855 | Some opaque ->
856 let x0, y0, x1, y1 = getlinkrect opaque linkno in
857 if not (x0 >= l.pagex && x1 <= l.pagex + l.pagevw
858 && y0 >= l.pagey && y1 <= l.pagey + l.pagevh)
859 then state.mode <- LinkNav (Ltgendir 0)
861 | _ :: rest -> loop rest
863 loop layout
864 | Ltnotready _ | Ltgendir _ -> ()
866 | Birdseye _ | Textentry _ | View -> ()
867 end;
868 begin match state.mode with
869 | Birdseye (conf, leftx, pageno, hooverpageno, anchor) ->
870 if not (pagevisible layout pageno)
871 then (
872 match state.layout with
873 | [] -> ()
874 | l :: _ ->
875 state.mode <- Birdseye (
876 conf, leftx, l.pageno, hooverpageno, anchor
879 | LinkNav lt ->
880 begin match lt with
881 | Ltnotready (_, dir)
882 | Ltgendir dir ->
883 let linknav =
884 let rec loop = function
885 | [] -> lt
886 | l :: rest ->
887 match getopaque l.pageno with
888 | None -> Ltnotready (l.pageno, dir)
889 | Some opaque ->
890 let link =
891 let ld =
892 if dir = 0
893 then LDfirstvisible (l.pagex, l.pagey, dir)
894 else (
895 if dir > 0 then LDfirst else LDlast
898 findlink opaque ld
900 match link with
901 | Lnotfound -> loop rest
902 | Lfound n ->
903 showlinktype (getlink opaque n);
904 Ltexact (l.pageno, n)
906 loop state.layout
908 state.mode <- LinkNav linknav
909 | Ltexact _ -> ()
911 | Textentry _ | View -> ()
912 end;
913 preload layout;
915 state.ghyll <- noghyll;
916 if conf.updatecurs
917 then (
918 let mx, my = state.mpos in
919 updateunder mx my;
923 let conttiling pageno opaque =
924 tilepage pageno opaque
925 (if conf.preload
926 then preloadlayout state.x state.y state.winw state.winh
927 else state.layout)
930 let gotoxy_and_clear_text x y =
931 if not conf.verbose then state.text <- E.s;
932 gotoxy x y;
935 let getanchory (n, top, dtop) =
936 let y, h = getpageyh n in
937 if conf.presentation
938 then
939 let ips = calcips h in
940 y + truncate (top*.float h -. dtop*.float ips) + ips;
941 else
942 y + truncate (top*.float h -. dtop*.float conf.interpagespace)
945 let gotoanchor anchor =
946 gotoxy state.x (getanchory anchor);
949 let addnav () =
950 cbput state.hists.nav (getanchor ());
953 let getnav dir =
954 let anchor = cbgetc state.hists.nav dir in
955 getanchory anchor;
958 let gotoghyll1 single y =
959 let scroll f n a b =
960 (* http://devmaster.net/forums/topic/9796-ease-in-ease-out-algorithm/ *)
961 let snake f a b =
962 let s x = 3.0*.x**2.0 -. 2.0*.x**3.0 in
963 if f < a
964 then s (float f /. float a)
965 else (
966 if f > b
967 then 1.0 -. s ((float (f-b) /. float (n-b)))
968 else 1.0
971 snake f a b
972 and summa n a b =
973 let ins = float a *. 0.5
974 and outs = float (n-b) *. 0.5 in
975 let ones = b - a in
976 ins +. outs +. float ones
978 let rec set nab y sy =
979 let (_N, _A, _B), y =
980 if single
981 then
982 let scl = if y > sy then 2 else -2 in
983 let _N, _, _ = nab in
984 (_N,0,_N), y+conf.scrollstep*scl
985 else nab,y in
986 let sum = summa _N _A _B in
987 let dy = float (y - sy) in
988 state.ghyll <- (
989 let rec gf n y1 o =
990 if n >= _N
991 then state.ghyll <- noghyll
992 else
993 let go n =
994 let s = scroll n _N _A _B in
995 let y1 = y1 +. ((s *. dy) /. sum) in
996 gotoxy_and_clear_text state.x (truncate y1);
997 state.ghyll <- gf (n+1) y1;
999 match o with
1000 | None -> go n
1001 | Some y' when single -> set nab y' state.y
1002 | Some y' -> set (_N/2, 1, 1) y' state.y
1004 gf 0 (float state.y)
1007 match conf.ghyllscroll with
1008 | Some nab when not conf.presentation ->
1009 if state.ghyll == noghyll
1010 then set nab y state.y
1011 else state.ghyll (Some y)
1012 | _ ->
1013 gotoxy_and_clear_text state.x y
1016 let gotoghyll = gotoghyll1 false;;
1018 let gotopage n top =
1019 let y, h = getpageyh n in
1020 let y = y + (truncate (top *. float h)) in
1021 gotoghyll y
1024 let gotopage1 n top =
1025 let y = getpagey n in
1026 let y = y + top in
1027 gotoghyll y
1030 let invalidate ?(redisplay=false) s f =
1031 state.redisplay <- redisplay;
1032 state.layout <- [];
1033 state.pdims <- [];
1034 state.rects <- [];
1035 state.rects1 <- [];
1036 match state.geomcmds with
1037 | ps, [] when emptystr ps ->
1038 f ();
1039 state.geomcmds <- s, [];
1041 | ps, [] ->
1042 state.geomcmds <- ps, [s, f];
1044 | ps, (s', _) :: rest when s' = s ->
1045 state.geomcmds <- ps, ((s, f) :: rest);
1047 | ps, cmds ->
1048 state.geomcmds <- ps, ((s, f) :: cmds);
1051 let flushpages () =
1052 Hashtbl.iter (fun _ opaque ->
1053 wcmd "freepage %s" (~> opaque);
1054 ) state.pagemap;
1055 Hashtbl.clear state.pagemap;
1058 let flushtiles () =
1059 if not (Queue.is_empty state.tilelru)
1060 then (
1061 Queue.iter (fun (k, p, s) ->
1062 wcmd "freetile %s" (~> p);
1063 state.memused <- state.memused - s;
1064 Hashtbl.remove state.tilemap k;
1065 ) state.tilelru;
1066 state.uioh#infochanged Memused;
1067 Queue.clear state.tilelru;
1069 load state.layout;
1072 let stateh h =
1073 let h = truncate (float h*.conf.zoom) in
1074 let d = conf.interpagespace lsl (if conf.presentation then 1 else 0) in
1075 h - d
1078 let opendoc path password =
1079 state.path <- path;
1080 state.password <- password;
1081 state.gen <- state.gen + 1;
1082 state.docinfo <- [];
1083 state.outlines <- [||];
1085 flushpages ();
1086 setaalevel conf.aalevel;
1087 let titlepath =
1088 if emptystr state.origin
1089 then path
1090 else state.origin
1092 Wsi.settitle ("llpp " ^ (mbtoutf8 (Filename.basename titlepath)));
1093 wcmd "open %d %d %d %s\000%s\000%s\000"
1094 (btod !wtmode) (btod !cxack) (btod conf.usedoccss)
1095 path password conf.css;
1096 invalidate "reqlayout"
1097 (fun () ->
1098 wcmd "reqlayout %d %d %d %s\000"
1099 conf.angle (FMTE.to_int conf.fitmodel)
1100 (stateh state.winh) state.nameddest
1102 state.help <-
1103 let sl = keystostrlist conf in
1104 let rec loop accu =
1105 function | [] -> accu
1106 | s :: rest -> loop ((s, 0, Noaction) :: accu) rest
1107 in makehelp () @ (("", 0, Noaction) :: loop [] sl) |> Array.of_list
1110 let reload () =
1111 state.anchor <- getanchor ();
1112 opendoc state.path state.password;
1115 let scalecolor c =
1116 let c = c *. conf.colorscale in
1117 (c, c, c);
1120 let scalecolor2 (r, g, b) =
1121 (r *. conf.colorscale, g *. conf.colorscale, b *. conf.colorscale);
1124 let docolumns columns =
1125 match columns with
1126 | Csingle _ ->
1127 let a = Array.make state.pagecount (-1, -1, -1, (-1, -1, -1, -1)) in
1128 let rec loop pageno pdimno pdim y ph pdims =
1129 if pageno = state.pagecount
1130 then ()
1131 else
1132 let pdimno, ((_, w, h, xoff) as pdim), pdims =
1133 match pdims with
1134 | ((pageno', _, _, _) as pdim) :: rest when pageno' = pageno ->
1135 pdimno+1, pdim, rest
1136 | _ ->
1137 pdimno, pdim, pdims
1139 let x = max 0 (((state.winw - w) / 2) - xoff) in
1140 let y =
1141 y + (if conf.presentation
1142 then (if pageno = 0 then calcips h else calcips ph + calcips h)
1143 else (if pageno = 0 then 0 else conf.interpagespace)
1146 a.(pageno) <- (pdimno, x, y, pdim);
1147 loop (pageno+1) pdimno pdim (y + h) h pdims
1149 loop 0 ~-1 (-1,-1,-1,-1) 0 0 state.pdims;
1150 conf.columns <- Csingle a;
1152 | Cmulti ((columns, coverA, coverB), _) ->
1153 let a = Array.make state.pagecount (-1, -1, -1, (-1, -1, -1, -1)) in
1154 let rec loop pageno pdimno pdim x y rowh pdims =
1155 let rec fixrow m =
1156 if m = pageno then () else
1157 let (pdimno, x, y, ((_, _, h, _) as pdim)) = a.(m) in
1158 if h < rowh
1159 then (
1160 let y = y + (rowh - h) / 2 in
1161 a.(m) <- (pdimno, x, y, pdim);
1163 fixrow (m+1)
1165 if pageno = state.pagecount
1166 then fixrow (((pageno - 1) / columns) * columns)
1167 else
1168 let pdimno, ((_, w, h, xoff) as pdim), pdims =
1169 match pdims with
1170 | ((pageno', _, _, _) as pdim) :: rest when pageno' = pageno ->
1171 pdimno+1, pdim, rest
1172 | _ ->
1173 pdimno, pdim, pdims
1175 let x, y, rowh' =
1176 if pageno = coverA - 1 || pageno = state.pagecount - coverB
1177 then (
1178 let x = (state.winw - w) / 2 in
1179 let ips =
1180 if conf.presentation then calcips h else conf.interpagespace in
1181 x, y + ips + rowh, h
1183 else (
1184 if (pageno - coverA) mod columns = 0
1185 then (
1186 let x = max 0 (state.winw - state.w) / 2 in
1187 let y =
1188 if conf.presentation
1189 then
1190 let ips = calcips h in
1191 y + (if pageno = 0 then 0 else calcips rowh + ips)
1192 else
1193 y + (if pageno = 0 then 0 else conf.interpagespace)
1195 x, y + rowh, h
1197 else x, y, max rowh h
1200 let y =
1201 if pageno > 1 && (pageno - coverA) mod columns = 0
1202 then (
1203 let y =
1204 if pageno = columns && conf.presentation
1205 then (
1206 let ips = calcips rowh in
1207 for i = 0 to pred columns
1209 let (pdimno, x, y, pdim) = a.(i) in
1210 a.(i) <- (pdimno, x, y+ips, pdim)
1211 done;
1212 y+ips;
1214 else y
1216 fixrow (pageno - columns);
1219 else y
1221 a.(pageno) <- (pdimno, x, y, pdim);
1222 let x = x + w + xoff*2 + conf.interpagespace in
1223 loop (pageno+1) pdimno pdim x y rowh' pdims
1225 loop 0 ~-1 (-1,-1,-1,-1) 0 0 0 state.pdims;
1226 conf.columns <- Cmulti ((columns, coverA, coverB), a);
1228 | Csplit (c, _) ->
1229 let a = Array.make (state.pagecount*c) (-1, -1, -1, (-1, -1, -1, -1)) in
1230 let rec loop pageno pdimno pdim y pdims =
1231 if pageno = state.pagecount
1232 then ()
1233 else
1234 let pdimno, ((_, w, h, _) as pdim), pdims =
1235 match pdims with
1236 | ((pageno', _, _, _) as pdim) :: rest when pageno' = pageno ->
1237 pdimno+1, pdim, rest
1238 | _ ->
1239 pdimno, pdim, pdims
1241 let cw = w / c in
1242 let rec loop1 n x y =
1243 if n = c then y else (
1244 a.(pageno*c + n) <- (pdimno, x, y, pdim);
1245 loop1 (n+1) (x+cw) (y + h + conf.interpagespace)
1248 let y = loop1 0 0 y in
1249 loop (pageno+1) pdimno pdim y pdims
1251 loop 0 ~-1 (-1,-1,-1,-1) 0 state.pdims;
1252 conf.columns <- Csplit (c, a);
1255 let represent () =
1256 docolumns conf.columns;
1257 state.maxy <- calcheight ();
1258 if state.reprf == noreprf
1259 then (
1260 match state.mode with
1261 | Birdseye (_, _, pageno, _, _) ->
1262 let y, h = getpageyh pageno in
1263 let top = (state.winh - h) / 2 in
1264 gotoxy state.x (max 0 (y - top))
1265 | Textentry _ | View | LinkNav _ ->
1266 let y = getanchory state.anchor in
1267 let y = min y (state.maxy - state.winh) in
1268 gotoxy state.x y;
1270 else (
1271 state.reprf ();
1272 state.reprf <- noreprf;
1276 let reshape ?(firsttime=false) w h =
1277 GlDraw.viewport ~x:0 ~y:0 ~w ~h;
1278 if not firsttime && nogeomcmds state.geomcmds
1279 then state.anchor <- getanchor ();
1281 state.winw <- w;
1282 let w = truncate (float w *. conf.zoom) in
1283 let w = max w 2 in
1284 state.winh <- h;
1285 setfontsize fstate.fontsize;
1286 GlMat.mode `modelview;
1287 GlMat.load_identity ();
1289 GlMat.mode `projection;
1290 GlMat.load_identity ();
1291 GlMat.rotate ~x:1.0 ~angle:180.0 ();
1292 GlMat.translate ~x:~-.1.0 ~y:~-.1.0 ();
1293 GlMat.scale3 (2.0 /. float state.winw, 2.0 /. float state.winh, 1.0);
1295 let relx =
1296 if conf.zoom <= 1.0
1297 then 0.0
1298 else float state.x /. float state.w
1300 invalidate ~redisplay:true "geometry"
1301 (fun () ->
1302 state.w <- w;
1303 if not firsttime
1304 then state.x <- truncate (relx *. float w);
1305 let w =
1306 match conf.columns with
1307 | Csingle _ -> w
1308 | Cmulti ((c, _, _), _) -> (w - (c-1)*conf.interpagespace) / c
1309 | Csplit (c, _) -> w * c
1311 wcmd "geometry %d %d %d"
1312 w (stateh h) (FMTE.to_int conf.fitmodel)
1316 let enttext () =
1317 let len = String.length state.text in
1318 let x0 = if conf.leftscroll then vscrollw () else 0 in
1319 let drawstring s =
1320 let hscrollh =
1321 match state.mode with
1322 | Textentry _ | View | LinkNav _ ->
1323 let h, _, _ = state.uioh#scrollpw in
1325 | Birdseye _ -> 0
1327 let rect x w =
1328 filledrect
1329 x (float (state.winh - (fstate.fontsize + 4) - hscrollh))
1330 (x+.w) (float (state.winh - hscrollh))
1333 let w = float (state.winw - 1 - vscrollw ()) in
1334 if state.progress >= 0.0 && state.progress < 1.0
1335 then (
1336 GlDraw.color (0.3, 0.3, 0.3);
1337 let w1 = w *. state.progress in
1338 rect (float x0) w1;
1339 GlDraw.color (0.0, 0.0, 0.0);
1340 rect (float x0+.w1) (float x0+.w-.w1)
1342 else (
1343 GlDraw.color (0.0, 0.0, 0.0);
1344 rect (float x0) w;
1347 GlDraw.color (1.0, 1.0, 1.0);
1348 drawstring
1349 fstate.fontsize
1350 (if conf.leftscroll then x0 + 2 else x0 + if len > 0 then 8 else 2)
1351 (state.winh - hscrollh - 5) s;
1353 let s =
1354 match state.mode with
1355 | Textentry ((prefix, text, _, _, _, _), _) ->
1356 let s =
1357 if len > 0
1358 then Printf.sprintf "%s%s_ [%s]" prefix text state.text
1359 else Printf.sprintf "%s%s_" prefix text
1363 | Birdseye _ | View | LinkNav _ -> state.text
1365 let s =
1366 if state.newerrmsgs
1367 then (
1368 if not (istextentry state.mode) && state.uioh#eformsgs
1369 then
1370 let s1 = "(press 'e' to review error messasges)" in
1371 if nonemptystr s then s ^ " " ^ s1 else s1
1372 else s
1374 else s
1376 if nonemptystr s
1377 then drawstring s
1380 let gctiles () =
1381 let len = Queue.length state.tilelru in
1382 let layout = lazy (
1383 match state.throttle with
1384 | None ->
1385 if conf.preload
1386 then preloadlayout state.x state.y state.winw state.winh
1387 else state.layout
1388 | Some (layout, _, _) ->
1389 layout
1390 ) in
1391 let rec loop qpos =
1392 if state.memused > conf.memlimit
1393 then (
1394 if qpos < len
1395 then
1396 let (k, p, s) as lruitem = Queue.pop state.tilelru in
1397 let n, gen, colorspace, angle, pagew, pageh, col, row = k in
1398 let (_, pw, ph, _) = getpagedim n in
1399 if gen = state.gen
1400 && colorspace = conf.colorspace
1401 && angle = conf.angle
1402 && pagew = pw
1403 && pageh = ph
1404 && (
1405 let x = col*conf.tilew
1406 and y = row*conf.tileh in
1407 tilevisible (Lazy.force_val layout) n x y
1409 then Queue.push lruitem state.tilelru
1410 else (
1411 freepbo p;
1412 wcmd "freetile %s" (~> p);
1413 state.memused <- state.memused - s;
1414 state.uioh#infochanged Memused;
1415 Hashtbl.remove state.tilemap k;
1417 loop (qpos+1)
1420 loop 0
1423 let onpagerect pageno f =
1424 let b =
1425 match conf.columns with
1426 | Cmulti (_, b) -> b
1427 | Csingle b -> b
1428 | Csplit (_, b) -> b
1430 if pageno >= 0 && pageno < Array.length b
1431 then
1432 let (_, _, _, (_, w, h, _)) = b.(pageno) in
1433 f w h
1436 let gotopagexy1 wtmode pageno x y =
1437 let _,w1,h1,leftx = getpagedim pageno in
1438 let top = y /. (float h1) in
1439 let left = x /. (float w1) in
1440 let py, w, h = getpageywh pageno in
1441 let wh = state.winh in
1442 let x = left *. (float w) in
1443 let x = leftx + state.x + truncate x in
1444 let sx =
1445 if x < 0 || x >= state.winw
1446 then state.x - x
1447 else state.x
1449 let pdy = truncate (top *. float h) in
1450 let y' = py + pdy in
1451 let dy = y' - state.y in
1452 let sy =
1453 if x != state.x || not (dy > 0 && dy < wh)
1454 then (
1455 if conf.presentation
1456 then
1457 if abs (py - y') > wh
1458 then y'
1459 else py
1460 else y';
1462 else state.y
1464 if state.x != sx || state.y != sy
1465 then (
1466 let x, y =
1467 if wtmode
1468 then (
1469 let ww = state.winw in
1470 let qx = sx / ww
1471 and qy = pdy / wh in
1472 let x = qx * ww
1473 and y = py + qy * wh in
1474 let x = if -x + ww > w1 then -(w1-ww) else x
1475 and y' = if y + wh > state.maxy then state.maxy - wh else y in
1476 let y =
1477 if conf.presentation
1478 then
1479 if abs (py - y') > wh
1480 then y'
1481 else py
1482 else y';
1484 (x, y)
1486 else (sx, sy)
1488 gotoxy_and_clear_text x y;
1490 else gotoxy_and_clear_text state.x state.y;
1493 let gotopagexy wtmode pageno x y =
1494 match state.mode with
1495 | Birdseye _ -> gotopage pageno 0.0
1496 | Textentry _ | View | LinkNav _ -> gotopagexy1 wtmode pageno x y
1499 let getpassword () =
1500 let passcmd = getenvwithdef "LLPP_ASKPASS" conf.passcmd in
1501 if emptystr passcmd
1502 then E.s
1503 else getcmdoutput
1504 (fun s ->
1505 impmsg "error getting password: %s" s;
1506 dolog "%s" s) passcmd;
1509 let pgoto opaque pageno x y =
1510 let pdimno = getpdimno pageno in
1511 let x, y = project opaque pageno pdimno x y in
1512 gotopagexy false pageno x y;
1515 let act cmds =
1516 (* dolog "%S" cmds; *)
1517 let spl = splitatchar cmds ' ' in
1518 let scan s fmt f =
1519 try Scanf.sscanf s fmt f
1520 with exn ->
1521 dolog "error processing '%S': %s" cmds @@ exntos exn;
1522 exit 1
1524 let addoutline outline =
1525 match state.currently with
1526 | Outlining outlines -> state.currently <- Outlining (outline :: outlines)
1527 | Idle -> state.currently <- Outlining [outline]
1528 | Loading _ | Tiling _ ->
1529 dolog "invalid outlining state";
1530 logcurrently state.currently
1532 match spl with
1533 | "clear", "" ->
1534 state.pdims <- [];
1535 state.uioh#infochanged Pdim;
1537 | "clearrects", "" ->
1538 state.rects <- state.rects1;
1539 G.postRedisplay "clearrects";
1541 | "continue", args ->
1542 let n = scan args "%u" (fun n -> n) in
1543 state.pagecount <- n;
1544 begin match state.currently with
1545 | Outlining l ->
1546 state.currently <- Idle;
1547 state.outlines <- Array.of_list (List.rev l)
1548 | Idle | Loading _ | Tiling _ -> ()
1549 end;
1551 let cur, cmds = state.geomcmds in
1552 if emptystr cur
1553 then failwith "umpossible";
1555 begin match List.rev cmds with
1556 | [] ->
1557 state.geomcmds <- E.s, [];
1558 state.throttle <- None;
1559 represent ();
1560 | (s, f) :: rest ->
1561 f ();
1562 state.geomcmds <- s, List.rev rest;
1563 end;
1564 if conf.maxwait = None && not !wtmode
1565 then G.postRedisplay "continue";
1567 | "msg", args ->
1568 showtext ' ' args
1570 | "vmsg", args ->
1571 if conf.verbose
1572 then showtext ' ' args
1574 | "emsg", args ->
1575 Buffer.add_string state.errmsgs args;
1576 state.newerrmsgs <- true;
1577 G.postRedisplay "error message"
1579 | "progress", args ->
1580 let progress, text =
1581 scan args "%f %n"
1582 (fun f pos ->
1583 f, String.sub args pos (String.length args - pos))
1585 state.text <- text;
1586 state.progress <- progress;
1587 G.postRedisplay "progress"
1589 | "firstmatch", args ->
1590 let pageno, c, x0, y0, x1, y1, x2, y2, x3, y3 =
1591 scan args "%u %d %f %f %f %f %f %f %f %f"
1592 (fun p c x0 y0 x1 y1 x2 y2 x3 y3 ->
1593 (p, c, x0, y0, x1, y1, x2, y2, x3, y3))
1595 let y = (getpagey pageno) + truncate y0 in
1596 let x =
1597 if conf.zoom > 1.0
1598 then state.winw/2
1599 else state.x
1601 addnav ();
1602 gotoxy x y;
1603 let color = (0.0, 0.0, 1.0 /. float c, 0.5) in
1604 state.rects1 <- [pageno, color, (x0, y0, x1, y1, x2, y2, x3, y3)]
1606 | "match", args ->
1607 let pageno, c, x0, y0, x1, y1, x2, y2, x3, y3 =
1608 scan args "%u %d %f %f %f %f %f %f %f %f"
1609 (fun p c x0 y0 x1 y1 x2 y2 x3 y3 ->
1610 (p, c, x0, y0, x1, y1, x2, y2, x3, y3))
1612 let color = (0.0, 0.0, 1.0 /. float c, 0.5) in
1613 state.rects1 <-
1614 (pageno, color, (x0, y0, x1, y1, x2, y2, x3, y3)) :: state.rects1
1616 | "page", args ->
1617 let pageopaques, t = scan args "%s %f" (fun p t -> p, t) in
1618 let pageopaque = ~< pageopaques in
1619 begin match state.currently with
1620 | Loading (l, gen) ->
1621 vlog "page %d took %f sec" l.pageno t;
1622 Hashtbl.replace state.pagemap (l.pageno, gen) pageopaque;
1623 begin match state.throttle with
1624 | None ->
1625 let preloadedpages =
1626 if conf.preload
1627 then preloadlayout state.x state.y state.winw state.winh
1628 else state.layout
1630 let evict () =
1631 let set =
1632 List.fold_left (fun s l -> IntSet.add l.pageno s)
1633 IntSet.empty preloadedpages
1635 let evictedpages =
1636 Hashtbl.fold (fun ((pageno, _) as key) opaque accu ->
1637 if not (IntSet.mem pageno set)
1638 then (
1639 wcmd "freepage %s" (~> opaque);
1640 key :: accu
1642 else accu
1643 ) state.pagemap []
1645 List.iter (Hashtbl.remove state.pagemap) evictedpages;
1647 evict ();
1648 state.currently <- Idle;
1649 if gen = state.gen
1650 then (
1651 tilepage l.pageno pageopaque state.layout;
1652 load state.layout;
1653 load preloadedpages;
1654 let visible = pagevisible state.layout l.pageno in
1655 if visible
1656 then (
1657 match state.mode with
1658 | LinkNav (Ltnotready (pageno, dir)) ->
1659 if pageno = l.pageno
1660 then (
1661 let link =
1662 let ld =
1663 if dir = 0
1664 then LDfirstvisible (l.pagex, l.pagey, dir)
1665 else (
1666 if dir > 0 then LDfirst else LDlast
1669 findlink pageopaque ld
1671 match link with
1672 | Lnotfound -> ()
1673 | Lfound n ->
1674 showlinktype (getlink pageopaque n);
1675 state.mode <- LinkNav (Ltexact (l.pageno, n))
1677 | LinkNav (Ltgendir _)
1678 | LinkNav (Ltexact _)
1679 | View
1680 | Birdseye _
1681 | Textentry _ -> ()
1684 if visible && layoutready state.layout
1685 then (
1686 G.postRedisplay "page";
1690 | Some (layout, _, _) ->
1691 state.currently <- Idle;
1692 tilepage l.pageno pageopaque layout;
1693 load state.layout
1694 end;
1696 | Idle | Tiling _ | Outlining _ ->
1697 dolog "Inconsistent loading state";
1698 logcurrently state.currently;
1699 exit 1
1702 | "tile" , args ->
1703 let (x, y, opaques, size, t) =
1704 scan args "%u %u %s %u %f"
1705 (fun x y p size t -> (x, y, p, size, t))
1707 let opaque = ~< opaques in
1708 begin match state.currently with
1709 | Tiling (l, pageopaque, cs, angle, gen, col, row, tilew, tileh) ->
1710 vlog "tile %d [%d,%d] took %f sec" l.pageno col row t;
1712 unmappbo opaque;
1713 if tilew != conf.tilew || tileh != conf.tileh
1714 then (
1715 wcmd "freetile %s" (~> opaque);
1716 state.currently <- Idle;
1717 load state.layout;
1719 else (
1720 puttileopaque l col row gen cs angle opaque size t;
1721 state.memused <- state.memused + size;
1722 state.uioh#infochanged Memused;
1723 gctiles ();
1724 Queue.push ((l.pageno, gen, cs, angle, l.pagew, l.pageh, col, row),
1725 opaque, size) state.tilelru;
1727 let layout =
1728 match state.throttle with
1729 | None -> state.layout
1730 | Some (layout, _, _) -> layout
1733 state.currently <- Idle;
1734 if gen = state.gen
1735 && conf.colorspace = cs
1736 && conf.angle = angle
1737 && tilevisible layout l.pageno x y
1738 then conttiling l.pageno pageopaque;
1740 begin match state.throttle with
1741 | None ->
1742 preload state.layout;
1743 if gen = state.gen
1744 && conf.colorspace = cs
1745 && conf.angle = angle
1746 && tilevisible state.layout l.pageno x y
1747 && (not !wtmode || layoutready state.layout)
1748 then G.postRedisplay "tile nothrottle";
1750 | Some (layout, y, _) ->
1751 let ready = layoutready layout in
1752 if ready
1753 then (
1754 state.y <- y;
1755 state.layout <- layout;
1756 state.throttle <- None;
1757 G.postRedisplay "throttle";
1759 else load layout;
1760 end;
1763 | Idle | Loading _ | Outlining _ ->
1764 dolog "Inconsistent tiling state";
1765 logcurrently state.currently;
1766 exit 1
1769 | "pdim", args ->
1770 let (n, w, h, _) as pdim =
1771 scan args "%u %u %u %u" (fun n w h x -> n, w, h, x)
1773 let pdim =
1774 match conf.fitmodel with
1775 | FitWidth -> pdim
1776 | FitPage | FitProportional ->
1777 match conf.columns with
1778 | Csplit _ -> (n, w, h, 0)
1779 | Csingle _ | Cmulti _ -> pdim
1781 state.pdims <- pdim :: state.pdims;
1782 state.uioh#infochanged Pdim
1784 | "o", args ->
1785 let (l, n, t, h, pos) =
1786 scan args "%u %u %d %u %n"
1787 (fun l n t h pos -> l, n, t, h, pos)
1789 let s = String.sub args pos (String.length args - pos) in
1790 addoutline (s, l, Oanchor (n, float t /. float h, 0.0))
1792 | "ou", args ->
1793 let (l, len, pos) = scan args "%u %u %n" (fun l len pos -> l, len, pos) in
1794 let s = String.sub args pos len in
1795 let pos2 = pos + len + 1 in
1796 let uri = String.sub args pos2 (String.length args - pos2) in
1797 addoutline (s, l, Ouri uri)
1799 | "on", args ->
1800 let (l, pos) = scan args "%u %n" (fun l pos -> l, pos) in
1801 let s = String.sub args pos (String.length args - pos) in
1802 addoutline (s, l, Onone)
1804 | "a", args ->
1805 let (n, l, t) =
1806 scan args "%u %d %d" (fun n l t -> n, l, t)
1808 state.reprf <- (fun () -> gotopagexy !wtmode n (float l) (float t))
1810 | "info", args ->
1811 let c, v = splitatchar args '\t' in
1812 let s =
1813 if nonemptystr v
1814 then
1815 if c = "Title"
1816 then (
1817 conf.title <- v;
1818 Wsi.settitle v;
1819 args
1821 else
1822 if let len = String.length c in
1823 len > 6 && ((String.sub c (len-4) 4) = "date")
1824 then (
1825 if String.length v >= 7 && v.[0] = 'D' && v.[1] = ':'
1826 then
1827 let b = Buffer.create 10 in
1828 Printf.bprintf b "%s\t" c;
1829 let sub p l c =
1831 Buffer.add_substring b v p l;
1832 Buffer.add_char b c;
1833 with exn -> Buffer.add_string b @@ exntos exn
1835 sub 2 4 '/';
1836 sub 6 2 '/';
1837 sub 8 2 ' ';
1838 sub 10 2 ':';
1839 sub 12 2 ':';
1840 sub 14 2 ' ';
1841 Buffer.add_char b '[';
1842 Buffer.add_string b v;
1843 Buffer.add_char b ']';
1844 Buffer.contents b
1845 else args
1847 else args
1848 else args
1850 state.docinfo <- (1, s) :: state.docinfo
1852 | "infoend", "" ->
1853 state.docinfo <- List.rev state.docinfo;
1854 state.uioh#infochanged Docinfo
1856 | "pass", args ->
1857 if args = "fail"
1858 then Wsi.settitle "Wrong password";
1859 let password = getpassword () in
1860 if emptystr password
1861 then error "document is password protected"
1862 else opendoc state.path password
1864 | _ ->
1865 error "unknown cmd `%S'" cmds
1868 let onhist cb =
1869 let rc = cb.rc in
1870 let action = function
1871 | HCprev -> cbget cb ~-1
1872 | HCnext -> cbget cb 1
1873 | HCfirst -> cbget cb ~-(cb.rc)
1874 | HClast -> cbget cb (cb.len - 1 - cb.rc)
1875 and cancel () = cb.rc <- rc
1876 in (action, cancel)
1879 let search pattern forward =
1880 match conf.columns with
1881 | Csplit _ -> impmsg "searching does not work properly in split columns mode"
1882 | Csingle _ | Cmulti _ ->
1883 if nonemptystr pattern
1884 then
1885 let pn, py =
1886 match state.layout with
1887 | [] -> 0, 0
1888 | l :: _ ->
1889 l.pageno, (l.pagey + if forward then 0 else 0*l.pagevh)
1891 wcmd "search %d %d %d %d,%s\000"
1892 (btod conf.icase) pn py (btod forward) pattern;
1895 let [@warning "-4"] intentry text key =
1896 let text =
1897 if emptystr text && key = Keys.Ascii '-'
1898 then addchar text '-'
1899 else
1900 match key with
1901 | Keys.Ascii ('0'..'9' as c) -> addchar text c
1902 | _ ->
1903 state.text <- "invalid key";
1904 text
1906 TEcont text
1909 let linknact f s =
1910 if nonemptystr s
1911 then (
1912 let n =
1913 let l = String.length s in
1914 let rec loop pos n =
1915 if pos = l
1916 then n
1917 else
1918 let m = Char.code s.[pos] - (if pos = 0 && l > 1 then 96 else 97) in
1919 loop (pos+1) (n*26 + m)
1920 in loop 0 0
1922 let rec loop n = function
1923 | [] -> ()
1924 | l :: rest ->
1925 match getopaque l.pageno with
1926 | None -> loop n rest
1927 | Some opaque ->
1928 let m = getlinkcount opaque in
1929 if n < m
1930 then (
1931 let under = getlink opaque n in
1932 f under
1934 else loop (n-m) rest
1936 loop n state.layout;
1940 let [@warning "-4"] linknentry text = function
1941 | Keys.Ascii c ->
1942 let text = addchar text c in
1943 linknact (fun under -> state.text <- undertext under) text;
1944 TEcont text
1945 | _ ->
1946 state.text <- Printf.sprintf "invalid key";
1947 TEcont text
1950 let [@warning "-4"] textentry text = function
1951 | Keys.Ascii c -> TEcont (addchar text c)
1952 | Keys.Code c -> TEcont (text ^ toutf8 c)
1953 | _ -> TEcont text
1956 let reqlayout angle fitmodel =
1957 match state.throttle with
1958 | None ->
1959 if nogeomcmds state.geomcmds
1960 then state.anchor <- getanchor ();
1961 conf.angle <- angle mod 360;
1962 if conf.angle != 0
1963 then (
1964 match state.mode with
1965 | LinkNav _ -> state.mode <- View
1966 | Birdseye _ | Textentry _ | View -> ()
1968 conf.fitmodel <- fitmodel;
1969 invalidate
1970 "reqlayout"
1971 (fun () ->
1972 wcmd "reqlayout %d %d %d"
1973 conf.angle (FMTE.to_int conf.fitmodel) (stateh state.winh)
1975 | _ -> ()
1978 let settrim trimmargins trimfuzz =
1979 if nogeomcmds state.geomcmds
1980 then state.anchor <- getanchor ();
1981 conf.trimmargins <- trimmargins;
1982 conf.trimfuzz <- trimfuzz;
1983 let x0, y0, x1, y1 = trimfuzz in
1984 invalidate
1985 "settrim" (fun () ->
1986 wcmd "settrim %d %d %d %d %d" (btod conf.trimmargins) x0 y0 x1 y1);
1987 flushpages ();
1990 let setzoom zoom =
1991 match state.throttle with
1992 | None ->
1993 let zoom = max 0.0001 zoom in
1994 if zoom <> conf.zoom
1995 then (
1996 state.prevzoom <- (conf.zoom, state.x);
1997 conf.zoom <- zoom;
1998 reshape state.winw state.winh;
1999 state.text <- Printf.sprintf "zoom is now %-5.2f" (zoom *. 100.0);
2002 | Some (layout, y, started) ->
2003 let time =
2004 match conf.maxwait with
2005 | None -> 0.0
2006 | Some t -> t
2008 let dt = now () -. started in
2009 if dt > time
2010 then (
2011 state.y <- y;
2012 load layout;
2016 let pivotzoom ?(vw=min state.w state.winw)
2017 ?(vh=min (state.maxy-state.y) state.winh)
2018 ?(x=vw/2) ?(y=vh/2) zoom =
2019 let w = float state.w /. zoom in
2020 let hw = w /. 2.0 in
2021 let ratio = float vh /. float vw in
2022 let hh = hw *. ratio in
2023 let x0 = float x -. hw
2024 and y0 = float y -. hh in
2025 gotoxy (state.x - truncate x0) (state.y + truncate y0);
2026 setzoom zoom;
2029 let pivotzoom ?vw ?vh ?x ?y zoom =
2030 if nogeomcmds state.geomcmds
2031 then
2032 if zoom > 1.0
2033 then pivotzoom ?vw ?vh ?x ?y zoom
2034 else setzoom zoom
2037 let setcolumns mode columns coverA coverB =
2038 state.prevcolumns <- Some (conf.columns, conf.zoom);
2039 if columns < 0
2040 then (
2041 if isbirdseye mode
2042 then impmsg "split mode doesn't work in bird's eye"
2043 else (
2044 conf.columns <- Csplit (-columns, E.a);
2045 state.x <- 0;
2046 conf.zoom <- 1.0;
2049 else (
2050 if columns < 2
2051 then (
2052 conf.columns <- Csingle E.a;
2053 state.x <- 0;
2054 setzoom 1.0;
2056 else (
2057 conf.columns <- Cmulti ((columns, coverA, coverB), E.a);
2058 conf.zoom <- 1.0;
2061 reshape state.winw state.winh;
2064 let resetmstate () =
2065 state.mstate <- Mnone;
2066 Wsi.setcursor Wsi.CURSOR_INHERIT;
2069 let enterbirdseye () =
2070 let zoom = float conf.thumbw /. float state.winw in
2071 let birdseyepageno =
2072 let cy = state.winh / 2 in
2073 let fold = function
2074 | [] -> 0
2075 | l :: rest ->
2076 let rec fold best = function
2077 | [] -> best.pageno
2078 | l :: rest ->
2079 let d = cy - (l.pagedispy + l.pagevh/2)
2080 and dbest = cy - (best.pagedispy + best.pagevh/2) in
2081 if abs d < abs dbest
2082 then fold l rest
2083 else best.pageno
2084 in fold l rest
2086 fold state.layout
2088 state.mode <-
2089 Birdseye (
2090 { conf with zoom = conf.zoom },
2091 state.x, birdseyepageno, -1, getanchor ()
2093 resetmstate ();
2094 conf.zoom <- zoom;
2095 conf.presentation <- false;
2096 conf.interpagespace <- 10;
2097 conf.hlinks <- false;
2098 conf.fitmodel <- FitPage;
2099 state.x <- 0;
2100 conf.maxwait <- None;
2101 conf.columns <- (
2102 match conf.beyecolumns with
2103 | Some c ->
2104 conf.zoom <- 1.0;
2105 Cmulti ((c, 0, 0), E.a)
2106 | None -> Csingle E.a
2108 if conf.verbose
2109 then
2110 state.text <- Printf.sprintf "birds eye mode on (zoom %3.1f%%)"
2111 (100.0*.zoom)
2112 else
2113 state.text <- E.s
2115 reshape state.winw state.winh;
2118 let leavebirdseye (c, leftx, pageno, _, anchor) goback =
2119 state.mode <- View;
2120 conf.zoom <- c.zoom;
2121 conf.presentation <- c.presentation;
2122 conf.interpagespace <- c.interpagespace;
2123 conf.maxwait <- c.maxwait;
2124 conf.hlinks <- c.hlinks;
2125 conf.fitmodel <- c.fitmodel;
2126 conf.beyecolumns <- (
2127 match conf.columns with
2128 | Cmulti ((c, _, _), _) -> Some c
2129 | Csingle _ -> None
2130 | Csplit _ -> failwith "leaving bird's eye split mode"
2132 conf.columns <- (
2133 match c.columns with
2134 | Cmulti (c, _) -> Cmulti (c, E.a)
2135 | Csingle _ -> Csingle E.a
2136 | Csplit (c, _) -> Csplit (c, E.a)
2138 if conf.verbose
2139 then
2140 state.text <- Printf.sprintf "birds eye mode off (zoom %3.1f%%)"
2141 (100.0*.conf.zoom)
2143 reshape state.winw state.winh;
2144 state.anchor <- if goback then anchor else (pageno, 0.0, 1.0);
2145 state.x <- leftx;
2148 let togglebirdseye () =
2149 match state.mode with
2150 | Birdseye vals -> leavebirdseye vals true
2151 | View -> enterbirdseye ()
2152 | Textentry _ | LinkNav _ -> ()
2155 let upbirdseye incr (conf, leftx, pageno, hooverpageno, anchor) =
2156 let pageno = max 0 (pageno - incr) in
2157 let rec loop = function
2158 | [] -> gotopage1 pageno 0
2159 | l :: _ when l.pageno = pageno ->
2160 if l.pagedispy >= 0 && l.pagey = 0
2161 then G.postRedisplay "upbirdseye"
2162 else gotopage1 pageno 0
2163 | _ :: rest -> loop rest
2165 loop state.layout;
2166 state.text <- E.s;
2167 state.mode <- Birdseye (conf, leftx, pageno, hooverpageno, anchor)
2170 let downbirdseye incr (conf, leftx, pageno, hooverpageno, anchor) =
2171 let pageno = min (state.pagecount - 1) (pageno + incr) in
2172 state.mode <- Birdseye (conf, leftx, pageno, hooverpageno, anchor);
2173 let rec loop = function
2174 | [] ->
2175 let y, h = getpageyh pageno in
2176 let dy = (y - state.y) - (state.winh - h - conf.interpagespace) in
2177 gotoxy state.x (clamp dy)
2178 | l :: _ when l.pageno = pageno ->
2179 if l.pagevh != l.pageh
2180 then gotoxy state.x (clamp (l.pageh - l.pagevh + conf.interpagespace))
2181 else G.postRedisplay "downbirdseye"
2182 | _ :: rest -> loop rest
2184 loop state.layout;
2185 state.text <- E.s;
2188 let [@warning "-4"] optentry mode _ key =
2189 let btos b = if b then "on" else "off" in
2190 match key with
2191 | Keys.Ascii 's' ->
2192 let ondone s =
2193 try conf.scrollstep <- int_of_string s with exn ->
2194 state.text <- Printf.sprintf "bad integer `%s': %s" s @@ exntos exn
2196 TEswitch ("scroll step: ", E.s, None, intentry, ondone, true)
2198 | Keys.Ascii 'A' ->
2199 let ondone s =
2201 conf.autoscrollstep <- boundastep state.winh (int_of_string s);
2202 if state.autoscroll <> None
2203 then state.autoscroll <- Some conf.autoscrollstep
2204 with exn ->
2205 state.text <- Printf.sprintf "bad integer `%s': %s" s @@ exntos exn
2207 TEswitch ("auto scroll step: ", E.s, None, intentry, ondone, true)
2209 | Keys.Ascii 'C' ->
2210 let ondone s =
2212 let n, a, b = multicolumns_of_string s in
2213 setcolumns mode n a b;
2214 with exn ->
2215 state.text <- Printf.sprintf "bad columns `%s': %s" s @@ exntos exn
2217 TEswitch ("columns: ", E.s, None, textentry, ondone, true)
2219 | Keys.Ascii 'Z' ->
2220 let ondone s =
2222 let zoom = float (int_of_string s) /. 100.0 in
2223 pivotzoom zoom
2224 with exn ->
2225 state.text <- Printf.sprintf "bad integer `%s': %s" s @@ exntos exn
2227 TEswitch ("zoom: ", E.s, None, intentry, ondone, true)
2229 | Keys.Ascii 't' ->
2230 let ondone s =
2232 conf.thumbw <- bound (int_of_string s) 2 4096;
2233 state.text <-
2234 Printf.sprintf "thumbnail width is set to %d" conf.thumbw;
2235 begin match mode with
2236 | Birdseye beye ->
2237 leavebirdseye beye false;
2238 enterbirdseye ();
2239 | Textentry _ | View | LinkNav _ -> ();
2241 with exn ->
2242 state.text <- Printf.sprintf "bad integer `%s': %s" s @@ exntos exn
2244 TEswitch ("thumbnail width: ", E.s, None, intentry, ondone, true)
2246 | Keys.Ascii 'R' ->
2247 let ondone s =
2248 match int_of_string s with
2249 | angle -> reqlayout angle conf.fitmodel
2250 | exception exn ->
2251 state.text <- Printf.sprintf "bad integer `%s': %s" s @@ exntos exn
2253 TEswitch ("rotation: ", E.s, None, intentry, ondone, true)
2255 | Keys.Ascii 'i' ->
2256 conf.icase <- not conf.icase;
2257 TEdone ("case insensitive search " ^ (btos conf.icase))
2259 | Keys.Ascii 'p' ->
2260 conf.preload <- not conf.preload;
2261 gotoxy state.x state.y;
2262 TEdone ("preload " ^ (btos conf.preload))
2264 | Keys.Ascii 'v' ->
2265 conf.verbose <- not conf.verbose;
2266 TEdone ("verbose " ^ (btos conf.verbose))
2268 | Keys.Ascii 'd' ->
2269 conf.debug <- not conf.debug;
2270 TEdone ("debug " ^ (btos conf.debug))
2272 | Keys.Ascii 'h' ->
2273 conf.maxhfit <- not conf.maxhfit;
2274 state.maxy <- calcheight ();
2275 TEdone ("maxhfit " ^ (btos conf.maxhfit))
2277 | Keys.Ascii 'c' ->
2278 conf.crophack <- not conf.crophack;
2279 TEdone ("crophack " ^ btos conf.crophack)
2281 | Keys.Ascii 'a' ->
2282 let s =
2283 match conf.maxwait with
2284 | None ->
2285 conf.maxwait <- Some infinity;
2286 "always wait for page to complete"
2287 | Some _ ->
2288 conf.maxwait <- None;
2289 "show placeholder if page is not ready"
2291 TEdone s
2293 | Keys.Ascii 'f' ->
2294 conf.underinfo <- not conf.underinfo;
2295 TEdone ("underinfo " ^ btos conf.underinfo)
2297 | Keys.Ascii 'P' ->
2298 conf.savebmarks <- not conf.savebmarks;
2299 TEdone ("persistent bookmarks " ^ btos conf.savebmarks)
2301 | Keys.Ascii 'S' ->
2302 let ondone s =
2304 let pageno, py =
2305 match state.layout with
2306 | [] -> 0, 0
2307 | l :: _ ->
2308 l.pageno, l.pagey
2310 conf.interpagespace <- int_of_string s;
2311 docolumns conf.columns;
2312 state.maxy <- calcheight ();
2313 let y = getpagey pageno in
2314 gotoxy state.x (y + py)
2315 with exn ->
2316 state.text <- Printf.sprintf "bad integer `%s': %s" s @@ exntos exn
2318 TEswitch ("vertical margin: ", E.s, None, intentry, ondone, true)
2320 | Keys.Ascii 'l' ->
2321 let fm =
2322 match conf.fitmodel with
2323 | FitProportional -> FitWidth
2324 | FitWidth | FitPage -> FitProportional
2326 reqlayout conf.angle fm;
2327 TEdone ("proportional display " ^ btos (fm == FitProportional))
2329 | Keys.Ascii 'T' ->
2330 settrim (not conf.trimmargins) conf.trimfuzz;
2331 TEdone ("trim margins " ^ btos conf.trimmargins)
2333 | Keys.Ascii 'I' ->
2334 conf.invert <- not conf.invert;
2335 TEdone ("invert colors " ^ btos conf.invert)
2337 | Keys.Ascii 'x' ->
2338 let ondone s =
2339 cbput state.hists.sel s;
2340 conf.selcmd <- s;
2342 TEswitch ("selection command: ", E.s, Some (onhist state.hists.sel),
2343 textentry, ondone, true)
2345 | Keys.Ascii 'M' ->
2346 if conf.pax == None
2347 then conf.pax <- Some (ref (0.0, 0, 0))
2348 else conf.pax <- None;
2349 TEdone ("PAX " ^ btos (conf.pax != None))
2351 | (Keys.Ascii c) ->
2352 state.text <- Printf.sprintf "bad option %d `%c'"
2353 (Char.code c) c;
2354 TEstop
2356 | _ ->
2357 TEcont state.text
2360 class type lvsource =
2361 object
2362 method getitemcount : int
2363 method getitem : int -> (string * int)
2364 method hasaction : int -> bool
2365 method exit : uioh:uioh ->
2366 cancel:bool ->
2367 active:int ->
2368 first:int ->
2369 pan:int ->
2370 uioh option
2371 method getactive : int
2372 method getfirst : int
2373 method getpan : int
2374 method getminfo : (int * int) array
2375 end;;
2377 class virtual lvsourcebase = object
2378 val mutable m_active = 0
2379 val mutable m_first = 0
2380 val mutable m_pan = 0
2381 method getactive = m_active
2382 method getfirst = m_first
2383 method getpan = m_pan
2384 method getminfo : (int * int) array = E.a
2385 end;;
2387 let [@warning "-4"]
2388 textentrykeyboard
2389 key _mask ((c, text, opthist, onkey, ondone, cancelonempty), onleave) =
2390 state.text <- E.s;
2391 let enttext te =
2392 state.mode <- Textentry (te, onleave);
2393 enttext ();
2394 G.postRedisplay "textentrykeyboard enttext";
2396 let histaction cmd =
2397 match opthist with
2398 | None -> ()
2399 | Some (action, _) ->
2400 state.mode <-
2401 Textentry (
2402 (c, action cmd, opthist, onkey, ondone, cancelonempty), onleave
2404 G.postRedisplay "textentry histaction"
2406 let open Keys in
2407 let kt = Wsi.kc2kt key in
2408 match kt with
2409 | Backspace ->
2410 if emptystr text && cancelonempty
2411 then (
2412 onleave Cancel;
2413 G.postRedisplay "textentrykeyboard after cancel";
2415 else
2416 let s = withoutlastutf8 text in
2417 enttext (c, s, opthist, onkey, ondone, cancelonempty)
2419 | Enter ->
2420 ondone text;
2421 onleave Confirm;
2422 G.postRedisplay "textentrykeyboard after confirm"
2424 | Up -> histaction HCprev
2425 | Down -> histaction HCnext
2426 | Home -> histaction HCfirst
2427 | End -> histaction HClast
2429 | Escape ->
2430 if emptystr text
2431 then (
2432 begin match opthist with
2433 | None -> ()
2434 | Some (_, onhistcancel) -> onhistcancel ()
2435 end;
2436 onleave Cancel;
2437 state.text <- E.s;
2438 G.postRedisplay "textentrykeyboard after cancel2"
2440 else (
2441 enttext (c, E.s, opthist, onkey, ondone, cancelonempty)
2444 | Delete -> ()
2446 | Code _ | Ascii _ ->
2447 begin match onkey text kt with
2448 | TEdone text ->
2449 ondone text;
2450 onleave Confirm;
2451 G.postRedisplay "textentrykeyboard after confirm2";
2453 | TEcont text ->
2454 enttext (c, text, opthist, onkey, ondone, cancelonempty);
2456 | TEstop ->
2457 onleave Cancel;
2458 G.postRedisplay "textentrykeyboard after cancel3"
2460 | TEswitch te ->
2461 state.mode <- Textentry (te, onleave);
2462 G.postRedisplay "textentrykeyboard switch";
2464 | _ -> vlog "unhandled key"
2467 let firstof first active =
2468 if first > active || abs (first - active) > fstate.maxrows - 1
2469 then max 0 (active - (fstate.maxrows/2))
2470 else first
2473 let calcfirst first active =
2474 if active > first
2475 then
2476 let rows = active - first in
2477 if rows > fstate.maxrows then active - fstate.maxrows else first
2478 else active
2481 let scrollph y maxy =
2482 let sh = float (maxy + state.winh) /. float state.winh in
2483 let sh = float state.winh /. sh in
2484 let sh = max sh (float conf.scrollh) in
2486 let percent = float y /. float maxy in
2487 let position = (float state.winh -. sh) *. percent in
2489 let position =
2490 if position +. sh > float state.winh
2491 then float state.winh -. sh
2492 else position
2494 position, sh;
2497 let adderrmsg src msg =
2498 Buffer.add_string state.errmsgs msg;
2499 state.newerrmsgs <- true;
2500 G.postRedisplay src
2503 let adderrfmt src fmt =
2504 Format.ksprintf (fun s -> adderrmsg src s) fmt;
2507 let coe s = (s :> uioh);;
2509 class listview ~zebra ~helpmode ~(source:lvsource) ~trusted ~modehash =
2510 object (self)
2511 val m_pan = source#getpan
2512 val m_first = source#getfirst
2513 val m_active = source#getactive
2514 val m_qsearch = E.s
2515 val m_prev_uioh = state.uioh
2517 method private elemunder y =
2518 if y < 0
2519 then None
2520 else
2521 let n = y / (fstate.fontsize+1) in
2522 if m_first + n < source#getitemcount
2523 then (
2524 if source#hasaction (m_first + n)
2525 then Some (m_first + n)
2526 else None
2528 else None
2530 method display =
2531 Gl.enable `blend;
2532 GlFunc.blend_func ~src:`src_alpha ~dst:`one_minus_src_alpha;
2533 GlDraw.color (0., 0., 0.) ~alpha:0.85;
2534 filledrect 0. 0. (float state.winw) (float state.winh);
2535 GlDraw.color (1., 1., 1.);
2536 Gl.enable `texture_2d;
2537 let fs = fstate.fontsize in
2538 let nfs = fs + 1 in
2539 let hw = state.winw/3 in
2540 let ww = fstate.wwidth in
2541 let tabw = 17.0*.ww in
2542 let itemcount = source#getitemcount in
2543 let minfo = source#getminfo in
2544 if conf.leftscroll
2545 then (
2546 GlMat.push ();
2547 GlMat.translate ~x:(float conf.scrollbw) ();
2549 let x0 = 0.0 and x1 = float (state.winw - conf.scrollbw - 1) in
2550 let rec loop row =
2551 if (row - m_first) > fstate.maxrows
2552 then ()
2553 else (
2554 if row >= 0 && row < itemcount
2555 then (
2556 let (s, level) = source#getitem row in
2557 let y = (row - m_first) * nfs in
2558 let x = 5.0 +. (float (level + m_pan)) *. ww in
2559 if helpmode
2560 then GlDraw.color
2561 (let c = if row land 1 = 0 then 1.0 else 0.92 in (c,c,c));
2563 if row = m_active
2564 then (
2565 Gl.disable `texture_2d;
2566 let alpha = if source#hasaction row then 0.9 else 0.3 in
2567 GlDraw.color (1., 1., 1.) ~alpha;
2568 linerect (x0 +. 1.) (float (y + 1)) (x1) (float (y + fs + 3));
2569 Gl.enable `texture_2d;
2571 let c =
2572 if zebra && row land 1 = 1
2573 then 0.8
2574 else 1.0
2576 GlDraw.color (c,c,c);
2577 let drawtabularstring s =
2578 let drawstr x s =
2579 let x' = truncate (x0 +. x) in
2580 let s1, s2 = splitatchar s '\000' in
2581 if emptystr s2
2582 then drawstring1 fs x' (y+nfs) s
2583 else
2584 let rec e s =
2585 if emptystr s
2586 then s
2587 else
2588 let s' = withoutlastutf8 s in
2589 let s = s' ^ UniSyms.ellipsis in
2590 let w = measurestr fs s in
2591 if float x' +. w +. ww < float (hw + x')
2592 then s
2593 else e s'
2595 let s1 =
2596 if float x' +. ww +. measurestr fs s1 > float (hw + x')
2597 then e s1
2598 else s1
2600 ignore (drawstring1 fs x' (y+nfs) s1);
2601 drawstring1 fs (hw + x') (y+nfs) s2
2603 if trusted
2604 then
2605 let x = if helpmode && row > 0 then x +. ww else x in
2606 let s1, s2 = splitatchar s '\t' in
2607 if nonemptystr s2
2608 then
2609 let nx = drawstr x s1 in
2610 let sw = nx -. x in
2611 let x = x +. (max tabw sw) in
2612 drawstr x s2
2613 else
2614 let len = String.length s - 2 in
2615 if len > 0 && s.[0] = '\xc2' && s.[1] = '\xb7'
2616 then
2617 let s = String.sub s 2 len in
2618 let x = if not helpmode then x +. ww else x in
2619 GlDraw.color (1.2, 1.2, 1.2);
2620 let vinc = drawstring1 (fs+fs/4)
2621 (truncate (x -. ww)) (y+nfs) s in
2622 GlDraw.color (1., 1., 1.);
2623 vinc +. (float fs *. 0.8)
2624 else
2625 drawstr x s
2626 else
2627 drawstr x s
2629 ignore (drawtabularstring s);
2630 loop (row+1)
2634 loop m_first;
2635 GlDraw.color (1.0, 1.0, 1.0) ~alpha:0.5;
2636 let xadj = 5.0 in
2637 let rec loop row =
2638 if (row - m_first) <= fstate.maxrows
2639 then
2640 if row >= 0 && row < itemcount
2641 then (
2642 let (s, level) = source#getitem row in
2643 let pos0 = nindex s '\000' in
2644 let y = (row - m_first) * nfs in
2645 let x = float (level + m_pan) *. ww in
2646 let (first, last) = minfo.(row) in
2647 let prefix =
2648 if pos0 > 0 && first > pos0
2649 then String.sub s (pos0+1) (first-pos0-1)
2650 else String.sub s 0 first
2652 let suffix = String.sub s first (last - first) in
2653 let w1 = measurestr fstate.fontsize prefix in
2654 let w2 = measurestr fstate.fontsize suffix in
2655 let x = x +. if conf.leftscroll then xadj else 5.0 in
2656 let x = if pos0 > 0 && first > pos0 then x +. float hw else x in
2657 let x0 = x +. w1
2658 and y0 = float (y+2) in
2659 let x1 = x0 +. w2
2660 and y1 = float (y+fs+3) in
2661 filledrect x0 y0 x1 y1;
2662 loop (row+1)
2665 Gl.disable `texture_2d;
2666 if Array.length minfo > 0 then loop m_first;
2667 Gl.disable `blend;
2668 if conf.leftscroll
2669 then GlMat.pop ()
2671 method updownlevel incr =
2672 let len = source#getitemcount in
2673 let curlevel =
2674 if m_active >= 0 && m_active < len
2675 then snd (source#getitem m_active)
2676 else -1
2678 let rec flow i =
2679 if i = len then i-1 else if i = -1 then 0 else
2680 let _, l = source#getitem i in
2681 if l != curlevel then i else flow (i+incr)
2683 let active = flow m_active in
2684 let first = calcfirst m_first active in
2685 G.postRedisplay "outline updownlevel";
2686 {< m_active = active; m_first = first >}
2688 method private key1 key mask =
2689 let set1 active first qsearch =
2690 coe {< m_active = active; m_first = first; m_qsearch = qsearch >}
2692 let search active pattern incr =
2693 let active = if active = -1 then m_first else active in
2694 let dosearch re =
2695 let rec loop n =
2696 if n >= 0 && n < source#getitemcount
2697 then (
2698 let s, _ = source#getitem n in
2699 match Str.search_forward re s 0 with
2700 | exception Not_found -> loop (n + incr)
2701 | _ -> Some n
2703 else None
2705 loop active
2707 let qpat = Str.quote pattern in
2708 match Str.regexp_case_fold qpat with
2709 | s -> dosearch s
2710 | exception exn ->
2711 adderrfmt "listview key1" "regexp_case_fold for `%S' failed: %S\n"
2712 qpat @@ Printexc.to_string exn;
2713 None
2715 let itemcount = source#getitemcount in
2716 let find start incr =
2717 let rec find i =
2718 if i = -1 || i = itemcount
2719 then -1
2720 else (
2721 if source#hasaction i
2722 then i
2723 else find (i + incr)
2726 find start
2728 let set active first =
2729 let first = bound first 0 (itemcount - fstate.maxrows) in
2730 state.text <- E.s;
2731 coe {< m_active = active; m_first = first; m_qsearch = E.s >}
2733 let navigate incr =
2734 let isvisible first n = n >= first && n - first <= fstate.maxrows in
2735 let active, first =
2736 let incr1 = if incr > 0 then 1 else -1 in
2737 if isvisible m_first m_active
2738 then
2739 let next =
2740 let next = m_active + incr in
2741 let next =
2742 if next < 0 || next >= itemcount
2743 then -1
2744 else find next incr1
2746 if abs (m_active - next) > fstate.maxrows
2747 then -1
2748 else next
2750 if next = -1
2751 then
2752 let first = m_first + incr in
2753 let first = bound first 0 (itemcount - fstate.maxrows) in
2754 let next =
2755 let next = m_active + incr in
2756 let next = bound next 0 (itemcount - 1) in
2757 find next ~-incr1
2759 let active =
2760 if next = -1
2761 then m_active
2762 else (
2763 if isvisible first next
2764 then next
2765 else m_active
2768 active, first
2769 else
2770 let first = min next m_first in
2771 let first =
2772 if abs (next - first) > fstate.maxrows
2773 then first + incr
2774 else first
2776 next, first
2777 else
2778 let first = m_first + incr in
2779 let first = bound first 0 (itemcount - 1) in
2780 let active =
2781 let next = m_active + incr in
2782 let next = bound next 0 (itemcount - 1) in
2783 let next = find next incr1 in
2784 let active =
2785 if next = -1 || abs (m_active - first) > fstate.maxrows
2786 then (
2787 let active = if m_active = -1 then next else m_active in
2788 active
2790 else next
2792 if isvisible first active
2793 then active
2794 else -1
2796 active, first
2798 G.postRedisplay "listview navigate";
2799 set active first;
2801 let open Keys in
2802 let kt = Wsi.kc2kt key in
2803 match [@warning "-4"] kt with
2804 | Ascii (('r'|'s') as c) when Wsi.withctrl mask ->
2805 let incr = if c = 'r' then -1 else 1 in
2806 let active, first =
2807 match search (m_active + incr) m_qsearch incr with
2808 | None ->
2809 state.text <- m_qsearch ^ " [not found]";
2810 m_active, m_first
2811 | Some active ->
2812 state.text <- m_qsearch;
2813 active, firstof m_first active
2815 G.postRedisplay "listview ctrl-r/s";
2816 set1 active first m_qsearch;
2818 | Insert when Wsi.withctrl mask ->
2819 if m_active >= 0 && m_active < source#getitemcount
2820 then (
2821 let s, _ = source#getitem m_active in
2822 selstring s;
2824 coe self
2826 | Backspace ->
2827 if emptystr m_qsearch
2828 then coe self
2829 else (
2830 let qsearch = withoutlastutf8 m_qsearch in
2831 if emptystr qsearch
2832 then (
2833 state.text <- E.s;
2834 G.postRedisplay "listview empty qsearch";
2835 set1 m_active m_first E.s;
2837 else
2838 let active, first =
2839 match search m_active qsearch ~-1 with
2840 | None ->
2841 state.text <- qsearch ^ " [not found]";
2842 m_active, m_first
2843 | Some active ->
2844 state.text <- qsearch;
2845 active, firstof m_first active
2847 G.postRedisplay "listview backspace qsearch";
2848 set1 active first qsearch
2851 | Ascii _ | Code _ ->
2852 let utf8 =
2853 match [@warning "-8"] kt with
2854 | Ascii c -> String.make 1 c
2855 | Code code -> toutf8 code
2857 let pattern = m_qsearch ^ utf8 in
2858 let active, first =
2859 match search m_active pattern 1 with
2860 | None ->
2861 state.text <- pattern ^ " [not found]";
2862 m_active, m_first
2863 | Some active ->
2864 state.text <- pattern;
2865 active, firstof m_first active
2867 G.postRedisplay "listview qsearch add";
2868 set1 active first pattern;
2870 | Escape ->
2871 state.text <- E.s;
2872 if emptystr m_qsearch
2873 then (
2874 G.postRedisplay "list view escape";
2875 let mx, my = state.mpos in
2876 updateunder mx my;
2877 match source#exit ~uioh:(coe self) ~cancel:true ~active:m_active
2878 ~first:m_first ~pan:m_pan with
2879 | None -> m_prev_uioh
2880 | Some uioh -> uioh
2882 else (
2883 G.postRedisplay "list view kill qsearch";
2884 coe {< m_qsearch = E.s >}
2887 | Enter ->
2888 state.text <- E.s;
2889 let self = {< m_qsearch = E.s >} in
2890 let opt =
2891 G.postRedisplay "listview enter";
2892 let cancel = not (m_active >= 0 && m_active < source#getitemcount) in
2893 source#exit ~uioh:(coe self) ~cancel
2894 ~active:m_active ~first:m_first ~pan:m_pan;
2896 begin match opt with
2897 | None -> m_prev_uioh
2898 | Some uioh -> uioh
2901 | Delete ->
2902 coe self
2904 | Up -> navigate ~-1
2905 | Down -> navigate 1
2906 | Prior -> navigate ~-(fstate.maxrows)
2907 | Next -> navigate fstate.maxrows
2909 | Right ->
2910 state.text <- E.s;
2911 G.postRedisplay "listview right";
2912 coe {< m_pan = m_pan - 1 >}
2914 | Left ->
2915 state.text <- E.s;
2916 G.postRedisplay "listview left";
2917 coe {< m_pan = m_pan + 1 >}
2919 | Home ->
2920 let active = find 0 1 in
2921 G.postRedisplay "listview home";
2922 set active 0;
2924 | End ->
2925 let first = max 0 (itemcount - fstate.maxrows) in
2926 let active = find (itemcount - 1) ~-1 in
2927 G.postRedisplay "listview end";
2928 set active first;
2930 | _ -> coe self
2932 method key key mask =
2933 match state.mode with
2934 | Textentry te ->
2935 textentrykeyboard key mask te;
2936 coe self
2937 | Birdseye _ | View | LinkNav _ -> self#key1 key mask
2939 method button button down x y _ =
2940 let opt =
2941 match button with
2942 | 1 when vscrollhit x ->
2943 G.postRedisplay "listview scroll";
2944 if down
2945 then
2946 let _, position, sh = self#scrollph in
2947 if y > truncate position && y < truncate (position +. sh)
2948 then (
2949 state.mstate <- Mscrolly;
2950 Some (coe self)
2952 else
2953 let s = float (max 0 (y - conf.scrollh)) /. float state.winh in
2954 let first = truncate (s *. float source#getitemcount) in
2955 let first = min source#getitemcount first in
2956 Some (coe {< m_first = first; m_active = first >})
2957 else (
2958 state.mstate <- Mnone;
2959 Some (coe self);
2961 | 1 when down ->
2962 begin match self#elemunder y with
2963 | Some n ->
2964 G.postRedisplay "listview click";
2965 source#exit ~uioh:(coe {< m_active = n >})
2966 ~cancel:false ~active:n ~first:m_first ~pan:m_pan
2967 | _ ->
2968 Some (coe self)
2970 | n when (n == 4 || n == 5) && not down ->
2971 let len = source#getitemcount in
2972 let first =
2973 if n = 5 && m_first + fstate.maxrows >= len
2974 then
2975 m_first
2976 else
2977 let first = m_first + (if n == 4 then -1 else 1) in
2978 bound first 0 (len - 1)
2980 G.postRedisplay "listview wheel";
2981 Some (coe {< m_first = first >})
2982 | n when (n = 6 || n = 7) && not down ->
2983 let inc = if n = 7 then -1 else 1 in
2984 G.postRedisplay "listview hwheel";
2985 Some (coe {< m_pan = m_pan + inc >})
2986 | _ ->
2987 Some (coe self)
2989 match opt with
2990 | None -> m_prev_uioh
2991 | Some uioh -> uioh
2993 method multiclick _ x y = self#button 1 true x y
2995 method motion _ y =
2996 match state.mstate with
2997 | Mscrolly ->
2998 let s = float (max 0 (y - conf.scrollh)) /. float state.winh in
2999 let first = truncate (s *. float source#getitemcount) in
3000 let first = min source#getitemcount first in
3001 G.postRedisplay "listview motion";
3002 coe {< m_first = first; m_active = first >}
3003 | Msel _
3004 | Mpan _
3005 | Mscrollx
3006 | Mzoom _
3007 | Mzoomrect _
3008 | Mnone -> coe self
3010 method pmotion x y =
3011 if x < state.winw - conf.scrollbw
3012 then
3013 let n =
3014 match self#elemunder y with
3015 | None -> Wsi.setcursor Wsi.CURSOR_INHERIT; m_active
3016 | Some n -> Wsi.setcursor Wsi.CURSOR_INFO; n
3018 let o =
3019 if n != m_active
3020 then (G.postRedisplay "listview pmotion"; {< m_active = n >})
3021 else self
3023 coe o
3024 else (
3025 Wsi.setcursor Wsi.CURSOR_INHERIT;
3026 coe self
3029 method infochanged _ = ()
3031 method scrollpw = (0, 0.0, 0.0)
3032 method scrollph =
3033 let nfs = fstate.fontsize + 1 in
3034 let y = m_first * nfs in
3035 let itemcount = source#getitemcount in
3036 let maxi = max 0 (itemcount - fstate.maxrows) in
3037 let maxy = maxi * nfs in
3038 let p, h = scrollph y maxy in
3039 conf.scrollbw, p, h
3041 method modehash = modehash
3042 method eformsgs = false
3043 method alwaysscrolly = true
3044 method scroll _ dy =
3045 let self =
3046 if dy != 0 then begin
3047 let len = source#getitemcount in
3048 let first =
3049 if dy > 0 && m_first + fstate.maxrows >= len
3050 then
3051 m_first
3052 else
3053 let first = m_first + dy / 10 in
3054 bound first 0 (len - 1)
3056 G.postRedisplay "listview wheel";
3057 {< m_first = first >}
3058 end else
3059 self
3061 coe self
3063 method zoom _ _ _ = ()
3064 end;;
3066 class outlinelistview ~zebra ~source =
3067 let settext autonarrow s =
3068 if autonarrow
3069 then
3070 let ss = source#statestr in
3071 state.text <-
3072 if emptystr ss
3073 then "[" ^ s ^ "]"
3074 else "{" ^ ss ^ "} [" ^ s ^ "]"
3075 else state.text <- s
3077 object (self)
3078 inherit listview
3079 ~zebra
3080 ~helpmode:false
3081 ~source:(source :> lvsource)
3082 ~trusted:false
3083 ~modehash:(findkeyhash conf "outline")
3084 as super
3086 val m_autonarrow = false
3088 method! key key mask =
3089 let maxrows =
3090 if emptystr state.text
3091 then fstate.maxrows
3092 else fstate.maxrows - 2
3094 let calcfirst first active =
3095 if active > first
3096 then
3097 let rows = active - first in
3098 if rows > maxrows then active - maxrows else first
3099 else active
3101 let navigate incr =
3102 let active = m_active + incr in
3103 let active = bound active 0 (source#getitemcount - 1) in
3104 let first = calcfirst m_first active in
3105 G.postRedisplay "outline navigate";
3106 coe {< m_active = active; m_first = first >}
3108 let navscroll first =
3109 let active =
3110 let dist = m_active - first in
3111 if dist < 0
3112 then first
3113 else (
3114 if dist < maxrows
3115 then m_active
3116 else first + maxrows
3119 G.postRedisplay "outline navscroll";
3120 coe {< m_first = first; m_active = active >}
3122 let ctrl = Wsi.withctrl mask in
3123 let open Keys in
3124 match Wsi.kc2kt key with
3125 | Ascii 'a' when ctrl ->
3126 let text =
3127 if m_autonarrow
3128 then (source#denarrow; E.s)
3129 else (
3130 let pattern = source#renarrow in
3131 if nonemptystr m_qsearch
3132 then (source#narrow m_qsearch; m_qsearch)
3133 else pattern
3136 settext (not m_autonarrow) text;
3137 G.postRedisplay "toggle auto narrowing";
3138 coe {< m_first = 0; m_active = 0; m_autonarrow = not m_autonarrow >}
3140 | Ascii '/' when emptystr m_qsearch && not m_autonarrow ->
3141 settext true E.s;
3142 G.postRedisplay "toggle auto narrowing";
3143 coe {< m_first = 0; m_active = 0; m_autonarrow = true >}
3145 | Ascii 'n' when ctrl ->
3146 source#narrow m_qsearch;
3147 if not m_autonarrow
3148 then source#add_narrow_pattern m_qsearch;
3149 G.postRedisplay "outline ctrl-n";
3150 coe {< m_first = 0; m_active = 0 >}
3152 | Ascii 'S' when ctrl ->
3153 let active = source#calcactive (getanchor ()) in
3154 let first = firstof m_first active in
3155 G.postRedisplay "outline ctrl-s";
3156 coe {< m_first = first; m_active = active >}
3158 | Ascii 'u' when ctrl ->
3159 G.postRedisplay "outline ctrl-u";
3160 if m_autonarrow && nonemptystr m_qsearch
3161 then (
3162 ignore (source#renarrow);
3163 settext m_autonarrow E.s;
3164 coe {< m_first = 0; m_active = 0; m_qsearch = E.s >}
3166 else (
3167 source#del_narrow_pattern;
3168 let pattern = source#renarrow in
3169 let text =
3170 if emptystr pattern then E.s else "Narrowed to " ^ pattern
3172 settext m_autonarrow text;
3173 coe {< m_first = 0; m_active = 0; m_qsearch = E.s >}
3176 | Ascii 'l' when ctrl ->
3177 let first = max 0 (m_active - (fstate.maxrows / 2)) in
3178 G.postRedisplay "outline ctrl-l";
3179 coe {< m_first = first >}
3181 | Ascii '\t' when m_autonarrow ->
3182 if nonemptystr m_qsearch
3183 then (
3184 G.postRedisplay "outline list view tab";
3185 source#add_narrow_pattern m_qsearch;
3186 settext true E.s;
3187 coe {< m_qsearch = E.s >}
3189 else coe self
3191 | Escape when m_autonarrow ->
3192 if nonemptystr m_qsearch
3193 then source#add_narrow_pattern m_qsearch;
3194 super#key key mask
3196 | Enter when m_autonarrow ->
3197 if nonemptystr m_qsearch
3198 then source#add_narrow_pattern m_qsearch;
3199 super#key key mask
3201 | (Ascii _ | Code _) when m_autonarrow ->
3202 let pattern = m_qsearch ^ toutf8 key in
3203 G.postRedisplay "outlinelistview autonarrow add";
3204 source#narrow pattern;
3205 settext true pattern;
3206 coe {< m_first = 0; m_active = 0; m_qsearch = pattern >}
3208 | Backspace when m_autonarrow ->
3209 if emptystr m_qsearch
3210 then coe self
3211 else
3212 let pattern = withoutlastutf8 m_qsearch in
3213 G.postRedisplay "outlinelistview autonarrow backspace";
3214 ignore (source#renarrow);
3215 source#narrow pattern;
3216 settext true pattern;
3217 coe {< m_first = 0; m_active = 0; m_qsearch = pattern >}
3219 | Up when ctrl ->
3220 navscroll (max 0 (m_first - 1))
3222 | Down when ctrl ->
3223 navscroll (min (source#getitemcount - 1) (m_first + 1))
3225 | Up -> navigate ~-1
3226 | Down -> navigate 1
3227 | Prior -> navigate ~-(fstate.maxrows)
3228 | Next -> navigate fstate.maxrows
3230 | Right ->
3231 let o =
3232 if ctrl
3233 then (
3234 G.postRedisplay "outline ctrl right";
3235 {< m_pan = m_pan + 1 >}
3237 else self#updownlevel 1
3239 coe o
3241 | Left ->
3242 let o =
3243 if ctrl
3244 then (
3245 G.postRedisplay "outline ctrl left";
3246 {< m_pan = m_pan - 1 >}
3248 else self#updownlevel ~-1
3250 coe o
3252 | Home ->
3253 G.postRedisplay "outline home";
3254 coe {< m_first = 0; m_active = 0 >}
3256 | End ->
3257 let active = source#getitemcount - 1 in
3258 let first = max 0 (active - fstate.maxrows) in
3259 G.postRedisplay "outline end";
3260 coe {< m_active = active; m_first = first >}
3262 | Delete|Escape|Insert|Enter|Ascii _|Code _|Ctrl _|Backspace|Fn _ ->
3263 super#key key mask
3264 end;;
3266 let genhistoutlines () =
3267 Config.gethist ()
3268 |> List.sort (fun (_, c1, _, _, _, _) (_, c2, _, _, _, _) ->
3269 compare c2.lastvisit c1.lastvisit)
3270 |> List.map (fun ((path, c, _, _, _, origin) as hist) ->
3271 let path = if nonemptystr origin then origin else path in
3272 let base = mbtoutf8 @@ Filename.basename path in
3273 (base ^ "\000" ^ c.title, 1, Ohistory hist)
3277 let gotohist (path, c, bookmarks, x, anchor, origin) =
3278 Config.save leavebirdseye;
3279 state.anchor <- anchor;
3280 state.bookmarks <- bookmarks;
3281 state.origin <- origin;
3282 state.x <- x;
3283 setconf conf c;
3284 let x0, y0, x1, y1 = conf.trimfuzz in
3285 wcmd "trimset %d %d %d %d %d" (btod conf.trimmargins) x0 y0 x1 y1;
3286 reshape ~firsttime:true state.winw state.winh;
3287 opendoc path origin;
3288 setzoom c.zoom;
3291 let makecheckers () =
3292 (* Based on lablGL-1.04/LablGlut/examples/lablGL/checker.ml which had
3293 following to say:
3294 converted by Issac Trotts. July 25, 2002 *)
3295 let image = GlPix.create `ubyte ~format:`luminance ~width:2 ~height:2 in
3296 Raw.sets_string (GlPix.to_raw image) ~pos:0 "\255\200\200\255";
3297 let id = GlTex.gen_texture () in
3298 GlTex.bind_texture ~target:`texture_2d id;
3299 GlPix.store (`unpack_alignment 1);
3300 GlTex.image2d image;
3301 List.iter (GlTex.parameter ~target:`texture_2d)
3302 [ `mag_filter `nearest; `min_filter `nearest ];
3306 let setcheckers enabled =
3307 match state.checkerstexid with
3308 | None ->
3309 if enabled then state.checkerstexid <- Some (makecheckers ())
3311 | Some checkerstexid ->
3312 if not enabled
3313 then (
3314 GlTex.delete_texture checkerstexid;
3315 state.checkerstexid <- None;
3319 let describe_location () =
3320 let d =
3321 match state.layout with
3322 | [] -> "Page 0"
3323 | l :: [] -> Printf.sprintf "Page %d" (l.pageno+1)
3324 | l :: rest ->
3325 let rangestr a b =
3326 if a.pageno = b.pageno then Printf.sprintf "%d" (a.pageno+1)
3327 else
3328 let sep = if a.pageno+1 = b.pageno then " " else ".." in
3329 Printf.sprintf "%d%s%d" (a.pageno+1) sep (b.pageno+1)
3331 let rec fold s la lb = function
3332 | [] -> Printf.sprintf "%s %s" s (rangestr la lb)
3333 | l :: rest when l.pageno = succ lb.pageno -> fold s la l rest
3334 | l :: rest -> fold (s ^ " " ^ rangestr la lb) l l rest
3336 fold "Pages" l l rest
3338 let percent =
3339 let maxy = maxy () in
3340 if maxy <= 0
3341 then 100.
3342 else 100. *. (float state.y /. float maxy)
3344 Printf.sprintf "%s of %d [%.2f%%]" d state.pagecount percent
3347 let setpresentationmode v =
3348 let n = page_of_y state.y in
3349 state.anchor <- (n, 0.0, 1.0);
3350 conf.presentation <- v;
3351 if conf.fitmodel = FitPage
3352 then reqlayout conf.angle conf.fitmodel;
3353 represent ();
3356 let setbgcol (r, g, b) =
3357 let col =
3358 let r = r *. 255.0 |> truncate
3359 and g = g *. 255.0 |> truncate
3360 and b = b *. 255.0 |> truncate in
3361 r lsl 16 |> (lor) (g lsl 8) |> (lor) b
3363 Wsi.setwinbgcol col;
3366 let enterinfomode =
3367 let btos b = if b then UniSyms.radical else E.s in
3368 let showextended = ref false in
3369 let leave mode _ = state.mode <- mode in
3370 let src =
3371 (object
3372 val mutable m_l = []
3373 val mutable m_a = E.a
3374 val mutable m_prev_uioh = nouioh
3375 val mutable m_prev_mode = View
3377 inherit lvsourcebase
3379 method reset prev_mode prev_uioh =
3380 m_a <- Array.of_list (List.rev m_l);
3381 m_l <- [];
3382 m_prev_mode <- prev_mode;
3383 m_prev_uioh <- prev_uioh;
3385 method int name get set =
3386 m_l <-
3387 (name, `int get, 1,
3388 Action (
3389 fun u ->
3390 let ondone s =
3391 try set (int_of_string s)
3392 with exn ->
3393 state.text <- Printf.sprintf "bad integer `%s': %s"
3394 s @@ exntos exn
3396 state.text <- E.s;
3397 let te = name ^ ": ", E.s, None, intentry, ondone, true in
3398 state.mode <- Textentry (te, leave m_prev_mode);
3400 )) :: m_l
3402 method int_with_suffix name get set =
3403 m_l <-
3404 (name, `intws get, 1,
3405 Action (
3406 fun u ->
3407 let ondone s =
3408 try set (int_of_string_with_suffix s)
3409 with exn ->
3410 state.text <- Printf.sprintf "bad integer `%s': %s"
3411 s @@ exntos exn
3413 state.text <- E.s;
3414 let te =
3415 name ^ ": ", E.s, None, intentry_with_suffix, ondone, true
3417 state.mode <- Textentry (te, leave m_prev_mode);
3419 )) :: m_l
3421 method bool ?(offset=1) ?(btos=btos) name get set =
3422 m_l <-
3423 (name, `bool (btos, get), offset, Action (
3424 fun u ->
3425 let v = get () in
3426 set (not v);
3428 )) :: m_l
3430 method color name get set =
3431 m_l <-
3432 (name, `color get, 1,
3433 Action (
3434 fun u ->
3435 let invalid = (nan, nan, nan) in
3436 let ondone s =
3437 let c =
3438 try color_of_string s
3439 with exn ->
3440 state.text <- Printf.sprintf "bad color `%s': %s"
3441 s @@ exntos exn;
3442 invalid
3444 if c <> invalid
3445 then set c;
3447 let te = name ^ ": ", E.s, None, textentry, ondone, true in
3448 state.text <- color_to_string (get ());
3449 state.mode <- Textentry (te, leave m_prev_mode);
3451 )) :: m_l
3453 method string name get set =
3454 m_l <-
3455 (name, `string get, 1,
3456 Action (
3457 fun u ->
3458 let ondone s = set s in
3459 let te = name ^ ": ", E.s, None, textentry, ondone, true in
3460 state.mode <- Textentry (te, leave m_prev_mode);
3462 )) :: m_l
3464 method colorspace name get set =
3465 m_l <-
3466 (name, `string get, 1,
3467 Action (
3468 fun _ ->
3469 let source =
3470 (object
3471 inherit lvsourcebase
3473 initializer
3474 m_active <- CSTE.to_int conf.colorspace;
3475 m_first <- 0;
3477 method getitemcount =
3478 Array.length CSTE.names
3479 method getitem n =
3480 (CSTE.names.(n), 0)
3481 method exit ~uioh ~cancel ~active ~first ~pan =
3482 ignore (uioh, first, pan);
3483 if not cancel then set active;
3484 None
3485 method hasaction _ = true
3486 end)
3488 state.text <- E.s;
3489 let modehash = findkeyhash conf "info" in
3490 coe (new listview ~zebra:false ~helpmode:false
3491 ~source ~trusted:true ~modehash)
3492 )) :: m_l
3494 method paxmark name get set =
3495 m_l <-
3496 (name, `string get, 1,
3497 Action (
3498 fun _ ->
3499 let source =
3500 (object
3501 inherit lvsourcebase
3503 initializer
3504 m_active <- MTE.to_int conf.paxmark;
3505 m_first <- 0;
3507 method getitemcount = Array.length MTE.names
3508 method getitem n = (MTE.names.(n), 0)
3509 method exit ~uioh ~cancel ~active ~first ~pan =
3510 ignore (uioh, first, pan);
3511 if not cancel then set active;
3512 None
3513 method hasaction _ = true
3514 end)
3516 state.text <- E.s;
3517 let modehash = findkeyhash conf "info" in
3518 coe (new listview ~zebra:false ~helpmode:false
3519 ~source ~trusted:true ~modehash)
3520 )) :: m_l
3522 method fitmodel name get set =
3523 m_l <-
3524 (name, `string get, 1,
3525 Action (
3526 fun _ ->
3527 let source =
3528 (object
3529 inherit lvsourcebase
3531 initializer
3532 m_active <- FMTE.to_int conf.fitmodel;
3533 m_first <- 0;
3535 method getitemcount = Array.length FMTE.names
3536 method getitem n = (FMTE.names.(n), 0)
3537 method exit ~uioh ~cancel ~active ~first ~pan =
3538 ignore (uioh, first, pan);
3539 if not cancel then set active;
3540 None
3541 method hasaction _ = true
3542 end)
3544 state.text <- E.s;
3545 let modehash = findkeyhash conf "info" in
3546 coe (new listview ~zebra:false ~helpmode:false
3547 ~source ~trusted:true ~modehash)
3548 )) :: m_l
3550 method caption s offset =
3551 m_l <- (s, `empty, offset, Noaction) :: m_l
3553 method caption2 s f offset =
3554 m_l <- (s, `string f, offset, Noaction) :: m_l
3556 method getitemcount = Array.length m_a
3558 method getitem n =
3559 let tostr = function
3560 | `int f -> string_of_int (f ())
3561 | `intws f -> string_with_suffix_of_int (f ())
3562 | `string f -> f ()
3563 | `color f -> color_to_string (f ())
3564 | `bool (btos, f) -> btos (f ())
3565 | `empty -> E.s
3567 let name, t, offset, _ = m_a.(n) in
3568 ((let s = tostr t in
3569 if nonemptystr s
3570 then Printf.sprintf "%s\t%s" name s
3571 else name),
3572 offset)
3574 method exit ~uioh ~cancel ~active ~first ~pan =
3575 let uiohopt =
3576 if not cancel
3577 then (
3578 let uioh =
3579 match m_a.(active) with
3580 | _, _, _, Action f -> f uioh
3581 | _, _, _, Noaction -> uioh
3583 Some uioh
3585 else None
3587 m_active <- active;
3588 m_first <- first;
3589 m_pan <- pan;
3590 uiohopt
3592 method hasaction n =
3593 match m_a.(n) with
3594 | _, _, _, Action _ -> true
3595 | _, _, _, Noaction -> false
3597 initializer m_active <- 1
3598 end)
3600 let rec fillsrc prevmode prevuioh =
3601 let sep () = src#caption E.s 0 in
3602 let colorp name get set =
3603 src#string name
3604 (fun () -> color_to_string (get ()))
3605 (fun v ->
3607 let c = color_of_string v in
3608 set c
3609 with exn ->
3610 state.text <-
3611 Printf.sprintf "bad color `%s': %s" v @@ exntos exn
3614 let oldmode = state.mode in
3615 let birdseye = isbirdseye state.mode in
3617 src#caption (if birdseye then "Setup (Bird's eye)" else "Setup") 0;
3619 src#bool "presentation mode"
3620 (fun () -> conf.presentation)
3621 (fun v -> setpresentationmode v);
3623 src#bool "ignore case in searches"
3624 (fun () -> conf.icase)
3625 (fun v -> conf.icase <- v);
3627 src#bool "preload"
3628 (fun () -> conf.preload)
3629 (fun v -> conf.preload <- v);
3631 src#bool "highlight links"
3632 (fun () -> conf.hlinks)
3633 (fun v -> conf.hlinks <- v);
3635 src#bool "under info"
3636 (fun () -> conf.underinfo)
3637 (fun v -> conf.underinfo <- v);
3639 src#bool "persistent bookmarks"
3640 (fun () -> conf.savebmarks)
3641 (fun v -> conf.savebmarks <- v);
3643 src#fitmodel "fit model"
3644 (fun () -> FMTE.to_string conf.fitmodel)
3645 (fun v -> reqlayout conf.angle (FMTE.of_int v));
3647 src#bool "trim margins"
3648 (fun () -> conf.trimmargins)
3649 (fun v -> settrim v conf.trimfuzz; fillsrc prevmode prevuioh);
3651 src#bool "persistent location"
3652 (fun () -> conf.jumpback)
3653 (fun v -> conf.jumpback <- v);
3655 sep ();
3656 src#int "inter-page space"
3657 (fun () -> conf.interpagespace)
3658 (fun n ->
3659 conf.interpagespace <- n;
3660 docolumns conf.columns;
3661 let pageno, py =
3662 match state.layout with
3663 | [] -> 0, 0
3664 | l :: _ ->
3665 l.pageno, l.pagey
3667 state.maxy <- calcheight ();
3668 let y = getpagey pageno in
3669 gotoxy state.x (y + py)
3672 src#int "page bias"
3673 (fun () -> conf.pagebias)
3674 (fun v -> conf.pagebias <- v);
3676 src#int "scroll step"
3677 (fun () -> conf.scrollstep)
3678 (fun n -> conf.scrollstep <- n);
3680 src#int "horizontal scroll step"
3681 (fun () -> conf.hscrollstep)
3682 (fun v -> conf.hscrollstep <- v);
3684 src#int "auto scroll step"
3685 (fun () ->
3686 match state.autoscroll with
3687 | Some step -> step
3688 | _ -> conf.autoscrollstep)
3689 (fun n ->
3690 let n = boundastep state.winh n in
3691 if state.autoscroll <> None
3692 then state.autoscroll <- Some n;
3693 conf.autoscrollstep <- n);
3695 src#int "zoom"
3696 (fun () -> truncate (conf.zoom *. 100.))
3697 (fun v -> pivotzoom ((float v) /. 100.));
3699 src#int "rotation"
3700 (fun () -> conf.angle)
3701 (fun v -> reqlayout v conf.fitmodel);
3703 src#int "scroll bar width"
3704 (fun () -> conf.scrollbw)
3705 (fun v ->
3706 conf.scrollbw <- v;
3707 reshape state.winw state.winh;
3710 src#int "scroll handle height"
3711 (fun () -> conf.scrollh)
3712 (fun v -> conf.scrollh <- v;);
3714 src#int "thumbnail width"
3715 (fun () -> conf.thumbw)
3716 (fun v ->
3717 conf.thumbw <- min 4096 v;
3718 match oldmode with
3719 | Birdseye beye ->
3720 leavebirdseye beye false;
3721 enterbirdseye ()
3722 | Textentry _
3723 | View
3724 | LinkNav _ -> ()
3727 let mode = state.mode in
3728 src#string "columns"
3729 (fun () ->
3730 match conf.columns with
3731 | Csingle _ -> "1"
3732 | Cmulti (multi, _) -> multicolumns_to_string multi
3733 | Csplit (count, _) -> "-" ^ string_of_int count
3735 (fun v ->
3736 let n, a, b = multicolumns_of_string v in
3737 setcolumns mode n a b);
3739 sep ();
3740 src#caption "Pixmap cache" 0;
3741 src#int_with_suffix "size (advisory)"
3742 (fun () -> conf.memlimit)
3743 (fun v -> conf.memlimit <- v);
3745 src#caption2 "used"
3746 (fun () ->
3747 Printf.sprintf "%s bytes, %d tiles"
3748 (string_with_suffix_of_int state.memused)
3749 (Hashtbl.length state.tilemap)) 1;
3751 sep ();
3752 src#caption "Layout" 0;
3753 src#caption2 "Dimension"
3754 (fun () ->
3755 Printf.sprintf "%dx%d (virtual %dx%d)"
3756 state.winw state.winh
3757 state.w state.maxy)
3759 if conf.debug
3760 then
3761 src#caption2 "Position" (fun () ->
3762 Printf.sprintf "%dx%d" state.x state.y
3764 else
3765 src#caption2 "Position" (fun () -> describe_location ()) 1
3768 sep ();
3769 src#bool ~offset:0 ~btos:(fun v -> if v then "(on)" else "(off)")
3770 "Save these parameters as global defaults at exit"
3771 (fun () -> conf.bedefault)
3772 (fun v -> conf.bedefault <- v)
3775 sep ();
3776 let btos b = if b then UniSyms.lguillemet else UniSyms.rguillemet in
3777 src#bool ~offset:0 ~btos "Extended parameters"
3778 (fun () -> !showextended)
3779 (fun v -> showextended := v; fillsrc prevmode prevuioh);
3780 if !showextended
3781 then (
3782 src#bool "checkers"
3783 (fun () -> conf.checkers)
3784 (fun v -> conf.checkers <- v; setcheckers v);
3785 src#bool "update cursor"
3786 (fun () -> conf.updatecurs)
3787 (fun v -> conf.updatecurs <- v);
3788 src#bool "scroll-bar on the left"
3789 (fun () -> conf.leftscroll)
3790 (fun v -> conf.leftscroll <- v);
3791 src#bool "verbose"
3792 (fun () -> conf.verbose)
3793 (fun v -> conf.verbose <- v);
3794 src#bool "invert colors"
3795 (fun () -> conf.invert)
3796 (fun v -> conf.invert <- v);
3797 src#bool "max fit"
3798 (fun () -> conf.maxhfit)
3799 (fun v -> conf.maxhfit <- v);
3800 src#bool "pax mode"
3801 (fun () -> conf.pax != None)
3802 (fun v ->
3803 if v
3804 then conf.pax <- Some (ref (now (), 0, 0))
3805 else conf.pax <- None);
3806 src#string "uri launcher"
3807 (fun () -> conf.urilauncher)
3808 (fun v -> conf.urilauncher <- v);
3809 src#string "path launcher"
3810 (fun () -> conf.pathlauncher)
3811 (fun v -> conf.pathlauncher <- v);
3812 src#string "tile size"
3813 (fun () -> Printf.sprintf "%dx%d" conf.tilew conf.tileh)
3814 (fun v ->
3816 let w, h = Scanf.sscanf v "%dx%d" (fun w h -> w, h) in
3817 conf.tilew <- max 64 w;
3818 conf.tileh <- max 64 h;
3819 flushtiles ();
3820 with exn ->
3821 state.text <- Printf.sprintf "bad tile size `%s': %s"
3822 v @@ exntos exn
3824 src#int "texture count"
3825 (fun () -> conf.texcount)
3826 (fun v ->
3827 if realloctexts v
3828 then conf.texcount <- v
3829 else impmsg "failed to set texture count please retry later"
3831 src#int "slice height"
3832 (fun () -> conf.sliceheight)
3833 (fun v ->
3834 conf.sliceheight <- v;
3835 wcmd "sliceh %d" conf.sliceheight;
3837 src#int "anti-aliasing level"
3838 (fun () -> conf.aalevel)
3839 (fun v ->
3840 conf.aalevel <- bound v 0 8;
3841 state.anchor <- getanchor ();
3842 opendoc state.path state.password;
3844 src#string "page scroll scaling factor"
3845 (fun () -> string_of_float conf.pgscale)
3846 (fun v ->
3848 let s = float_of_string v in
3849 conf.pgscale <- s
3850 with exn ->
3851 state.text <- Printf.sprintf
3852 "bad page scroll scaling factor `%s': %s" v
3853 @@ exntos exn
3856 src#int "ui font size"
3857 (fun () -> fstate.fontsize)
3858 (fun v -> setfontsize (bound v 5 100));
3859 src#int "hint font size"
3860 (fun () -> conf.hfsize)
3861 (fun v -> conf.hfsize <- bound v 5 100);
3862 colorp "background color"
3863 (fun () -> conf.bgcolor)
3864 (fun v -> conf.bgcolor <- v; setbgcol v);
3865 src#bool "crop hack"
3866 (fun () -> conf.crophack)
3867 (fun v -> conf.crophack <- v);
3868 src#string "trim fuzz"
3869 (fun () -> irect_to_string conf.trimfuzz)
3870 (fun v ->
3872 conf.trimfuzz <- irect_of_string v;
3873 if conf.trimmargins
3874 then settrim true conf.trimfuzz;
3875 with exn ->
3876 state.text <- Printf.sprintf "bad irect `%s': %s" v
3877 @@ exntos exn
3879 src#string "throttle"
3880 (fun () ->
3881 match conf.maxwait with
3882 | None -> "show place holder if page is not ready"
3883 | Some time ->
3884 if time = infinity
3885 then "wait for page to fully render"
3886 else
3887 "wait " ^ string_of_float time
3888 ^ " seconds before showing placeholder"
3890 (fun v ->
3892 let f = float_of_string v in
3893 if f <= 0.0
3894 then conf.maxwait <- None
3895 else conf.maxwait <- Some f
3896 with exn ->
3897 state.text <- Printf.sprintf "bad time `%s': %s" v
3898 @@ exntos exn
3900 src#string "ghyll scroll"
3901 (fun () ->
3902 match conf.ghyllscroll with
3903 | None -> E.s
3904 | Some nab -> ghyllscroll_to_string nab
3906 (fun v ->
3907 try conf.ghyllscroll <- ghyllscroll_of_string v
3908 with
3909 | Failure msg ->
3910 state.text <- Printf.sprintf "bad ghyll `%s': %s" v msg
3911 | exn ->
3912 state.text <- Printf.sprintf "bad ghyll `%s': %s" v
3913 @@ exntos exn
3915 src#string "selection command"
3916 (fun () -> conf.selcmd)
3917 (fun v -> conf.selcmd <- v);
3918 src#string "synctex command"
3919 (fun () -> conf.stcmd)
3920 (fun v -> conf.stcmd <- v);
3921 src#string "pax command"
3922 (fun () -> conf.paxcmd)
3923 (fun v -> conf.paxcmd <- v);
3924 src#string "ask password command"
3925 (fun () -> conf.passcmd)
3926 (fun v -> conf.passcmd <- v);
3927 src#string "save path command"
3928 (fun () -> conf.savecmd)
3929 (fun v -> conf.savecmd <- v);
3930 src#colorspace "color space"
3931 (fun () -> CSTE.to_string conf.colorspace)
3932 (fun v ->
3933 conf.colorspace <- CSTE.of_int v;
3934 wcmd "cs %d" v;
3935 load state.layout;
3937 src#paxmark "pax mark method"
3938 (fun () -> MTE.to_string conf.paxmark)
3939 (fun v -> conf.paxmark <- MTE.of_int v);
3940 if bousable () && !opengl_has_pbo
3941 then
3942 src#bool "use PBO"
3943 (fun () -> conf.usepbo)
3944 (fun v -> conf.usepbo <- v);
3945 src#bool "mouse wheel scrolls pages"
3946 (fun () -> conf.wheelbypage)
3947 (fun v -> conf.wheelbypage <- v);
3948 src#bool "open remote links in a new instance"
3949 (fun () -> conf.riani)
3950 (fun v -> conf.riani <- v);
3951 src#bool "edit annotations inline"
3952 (fun () -> conf.annotinline)
3953 (fun v -> conf.annotinline <- v);
3954 src#bool "coarse positioning in presentation mode"
3955 (fun () -> conf.coarseprespos)
3956 (fun v -> conf.coarseprespos <- v);
3957 src#bool "use document CSS"
3958 (fun () -> conf.usedoccss)
3959 (fun v ->
3960 conf.usedoccss <- v;
3961 state.anchor <- getanchor ();
3962 opendoc state.path state.password;
3966 sep ();
3967 src#caption "Document" 0;
3968 List.iter (fun (_, s) -> src#caption s 1) state.docinfo;
3969 src#caption2 "Pages"
3970 (fun () -> string_of_int state.pagecount) 1;
3971 src#caption2 "Dimensions"
3972 (fun () -> string_of_int (List.length state.pdims)) 1;
3973 if nonemptystr conf.css
3974 then src#caption2 "CSS" (fun () -> conf.css) 1;
3975 if conf.trimmargins
3976 then (
3977 sep ();
3978 src#caption "Trimmed margins" 0;
3979 src#caption2 "Dimensions"
3980 (fun () -> string_of_int (List.length state.pdims)) 1;
3983 sep ();
3984 src#caption "OpenGL" 0;
3985 src#caption (Printf.sprintf "Vendor\t%s" (GlMisc.get_string `vendor)) 1;
3986 src#caption (Printf.sprintf "Renderer\t%s" (GlMisc.get_string `renderer)) 1;
3988 sep ();
3989 src#caption "Location" 0;
3990 if nonemptystr state.origin
3991 then src#caption ("Orign\t" ^ mbtoutf8 state.origin) 1;
3992 src#caption ("Path\t" ^ mbtoutf8 state.path) 1;
3994 src#reset prevmode prevuioh;
3996 fun () ->
3997 state.text <- E.s;
3998 resetmstate ();
3999 let prevmode = state.mode
4000 and prevuioh = state.uioh in
4001 fillsrc prevmode prevuioh;
4002 let source = (src :> lvsource) in
4003 let modehash = findkeyhash conf "info" in
4004 state.uioh <-
4005 coe (object (self)
4006 inherit listview ~zebra:false ~helpmode:false
4007 ~source ~trusted:true ~modehash as super
4008 val mutable m_prevmemused = 0
4009 method! infochanged = function
4010 | Memused ->
4011 if m_prevmemused != state.memused
4012 then (
4013 m_prevmemused <- state.memused;
4014 G.postRedisplay "memusedchanged";
4016 | Pdim -> G.postRedisplay "pdimchanged"
4017 | Docinfo -> fillsrc prevmode prevuioh
4019 method! key key mask =
4020 if not (Wsi.withctrl mask)
4021 then
4022 match [@warning "-4"] Wsi.kc2kt key with
4023 | Keys.Left -> coe (self#updownlevel ~-1)
4024 | Keys.Right -> coe (self#updownlevel 1)
4025 | _ -> super#key key mask
4026 else super#key key mask
4027 end);
4028 G.postRedisplay "info";
4031 let enterhelpmode =
4032 let source =
4033 (object
4034 inherit lvsourcebase
4035 method getitemcount = Array.length state.help
4036 method getitem n =
4037 let s, l, _ = state.help.(n) in
4038 (s, l)
4040 method exit ~uioh ~cancel ~active ~first ~pan =
4041 let optuioh =
4042 if not cancel
4043 then (
4044 match state.help.(active) with
4045 | _, _, Action f -> Some (f uioh)
4046 | _, _, Noaction -> Some uioh
4048 else None
4050 m_active <- active;
4051 m_first <- first;
4052 m_pan <- pan;
4053 optuioh
4055 method hasaction n =
4056 match state.help.(n) with
4057 | _, _, Action _ -> true
4058 | _, _, Noaction -> false
4060 initializer
4061 m_active <- -1
4062 end)
4063 in fun () ->
4064 let modehash = findkeyhash conf "help" in
4065 resetmstate ();
4066 state.uioh <- coe (new listview
4067 ~zebra:false ~helpmode:true
4068 ~source ~trusted:true ~modehash);
4069 G.postRedisplay "help";
4072 let entermsgsmode =
4073 let msgsource =
4074 (object
4075 inherit lvsourcebase
4076 val mutable m_items = E.a
4078 method getitemcount = 1 + Array.length m_items
4080 method getitem n =
4081 if n = 0
4082 then "[Clear]", 0
4083 else m_items.(n-1), 0
4085 method exit ~uioh ~cancel ~active ~first ~pan =
4086 ignore uioh;
4087 if not cancel
4088 then (
4089 if active = 0
4090 then Buffer.clear state.errmsgs;
4092 m_active <- active;
4093 m_first <- first;
4094 m_pan <- pan;
4095 None
4097 method hasaction n =
4098 n = 0
4100 method reset =
4101 state.newerrmsgs <- false;
4102 let l = Str.split newlinere (Buffer.contents state.errmsgs) in
4103 m_items <- Array.of_list l
4105 initializer
4106 m_active <- 0
4107 end)
4108 in fun () ->
4109 state.text <- E.s;
4110 resetmstate ();
4111 msgsource#reset;
4112 let source = (msgsource :> lvsource) in
4113 let modehash = findkeyhash conf "listview" in
4114 state.uioh <-
4115 coe (object
4116 inherit listview ~zebra:false ~helpmode:false
4117 ~source ~trusted:false ~modehash as super
4118 method! display =
4119 if state.newerrmsgs
4120 then msgsource#reset;
4121 super#display
4122 end);
4123 G.postRedisplay "msgs";
4126 let getusertext s =
4127 let editor = getenvwithdef "EDITOR" E.s in
4128 if emptystr editor
4129 then E.s
4130 else
4131 let tmppath = Filename.temp_file "llpp" "note" in
4132 if nonemptystr s
4133 then (
4134 let oc = open_out tmppath in
4135 output_string oc s;
4136 close_out oc;
4138 let execstr = editor ^ " " ^ tmppath in
4139 let s =
4140 match spawn execstr [] with
4141 | exception exn ->
4142 impmsg "spawn(%S) failed: %s" execstr @@ exntos exn;
4144 | pid ->
4145 match Unix.waitpid [] pid with
4146 | exception exn ->
4147 impmsg "waitpid(%d) failed: %s" pid @@ exntos exn;
4149 | (_pid, status) ->
4150 match status with
4151 | Unix.WEXITED 0 -> filecontents tmppath
4152 | Unix.WEXITED n ->
4153 impmsg "editor process(%s) exited abnormally: %d" execstr n;
4155 | Unix.WSIGNALED n ->
4156 impmsg "editor process(%s) was killed by signal %d" execstr n;
4158 | Unix.WSTOPPED n ->
4159 impmsg "editor(%s) process was stopped by signal %d" execstr n;
4162 match Unix.unlink tmppath with
4163 | exception exn ->
4164 impmsg "failed to ulink %S: %s" tmppath @@ exntos exn;
4166 | () -> s
4169 let enterannotmode opaque slinkindex =
4170 let msgsource =
4171 (object
4172 inherit lvsourcebase
4173 val mutable m_text = E.s
4174 val mutable m_items = E.a
4176 method getitemcount = Array.length m_items
4178 method getitem n =
4179 let label, _func = m_items.(n) in
4180 label, 0
4182 method exit ~uioh ~cancel ~active ~first ~pan =
4183 ignore (uioh, first, pan);
4184 if not cancel
4185 then (
4186 let _label, func = m_items.(active) in
4187 func ()
4189 None
4191 method hasaction n = nonemptystr @@ fst m_items.(n)
4193 method reset s =
4194 let rec split accu b i =
4195 let p = b+i in
4196 if p = String.length s
4197 then (String.sub s b (p-b), unit) :: accu
4198 else
4199 if (i > 70 && s.[p] = ' ') || s.[p] = '\r' || s.[p] = '\n'
4200 then
4201 let ss = if i = 0 then E.s else String.sub s b i in
4202 split ((ss, unit)::accu) (p+1) 0
4203 else
4204 split accu b (i+1)
4206 let cleanup () =
4207 wcmd "freepage %s" (~> opaque);
4208 let keys =
4209 Hashtbl.fold (fun key opaque' accu ->
4210 if opaque' = opaque'
4211 then key :: accu else accu) state.pagemap []
4213 List.iter (Hashtbl.remove state.pagemap) keys;
4214 flushtiles ();
4215 gotoxy state.x state.y
4217 let dele () =
4218 delannot opaque slinkindex;
4219 cleanup ();
4221 let edit inline () =
4222 let update s =
4223 if emptystr s
4224 then dele ()
4225 else (
4226 modannot opaque slinkindex s;
4227 cleanup ();
4230 if inline
4231 then
4232 let mode = state.mode in
4233 state.mode <-
4234 Textentry (
4235 ("annotation: ", m_text, None, textentry, update, true),
4236 fun _ -> state.mode <- mode);
4237 state.text <- E.s;
4238 enttext ();
4239 else
4240 let s = getusertext m_text in
4241 update s
4243 m_text <- s;
4244 m_items <-
4245 ( "[Copy]", fun () -> selstring m_text)
4246 :: ("[Delete]", dele)
4247 :: ("[Edit]", edit conf.annotinline)
4248 :: (E.s, unit)
4249 :: split [] 0 0 |> List.rev |> Array.of_list
4251 initializer
4252 m_active <- 0
4253 end)
4255 state.text <- E.s;
4256 let s = getannotcontents opaque slinkindex in
4257 resetmstate ();
4258 msgsource#reset s;
4259 let source = (msgsource :> lvsource) in
4260 let modehash = findkeyhash conf "listview" in
4261 state.uioh <- coe (object
4262 inherit listview ~zebra:false ~helpmode:false
4263 ~source ~trusted:false ~modehash
4264 end);
4265 G.postRedisplay "enterannotmode";
4268 let gotoremote spec =
4269 let filename, dest = splitatchar spec '#' in
4270 let getpath filename =
4271 let path =
4272 if nonemptystr filename
4273 then
4274 if Filename.is_relative filename
4275 then
4276 let dir = Filename.dirname state.path in
4277 let dir =
4278 if Filename.is_implicit dir
4279 then Filename.concat (Sys.getcwd ()) dir
4280 else dir
4282 Filename.concat dir filename
4283 else filename
4284 else E.s
4286 if Sys.file_exists path
4287 then path
4288 else E.s
4290 let path = getpath filename in
4291 let dospawn lcmd =
4292 if conf.riani
4293 then
4294 let cmd = Lazy.force_val lcmd in
4295 match spawn cmd with
4296 | _pid -> ()
4297 | exception exn -> dolog "failed to execute `%s': %s" cmd @@ exntos exn
4298 else
4299 let anchor = getanchor () in
4300 let ranchor = state.path, state.password, anchor, state.origin in
4301 state.origin <- E.s;
4302 state.ranchors <- ranchor :: state.ranchors;
4303 opendoc path E.s;
4305 if substratis spec 0 "page="
4306 then
4307 match Scanf.sscanf spec "page=%d" (fun n -> n) with
4308 | pageno ->
4309 state.anchor <- (pageno, 0.0, 0.0);
4310 dospawn @@ lazy (Printf.sprintf "%s -page %d %S" !selfexec pageno path);
4311 | exception exn ->
4312 adderrfmt "error parsing remote destination" "page: %s" @@ exntos exn
4313 else (
4314 state.nameddest <- dest;
4315 dospawn @@ lazy (!selfexec ^ " " ^ path ^ " -dest " ^ dest)
4319 let gotounder = function
4320 | Ulinkuri s when isexternallink s ->
4321 if substratis s 0 "file://"
4322 then gotoremote @@ String.sub s 7 (String.length s - 7)
4323 else gotouri s
4324 | Ulinkuri s ->
4325 let pageno, x, y = uritolocation s in
4326 addnav ();
4327 gotopagexy !wtmode pageno x y
4328 | Utext _ | Unone -> ()
4329 | Uannotation (opaque, slinkindex) -> enterannotmode opaque slinkindex
4332 let gotooutline (_, _, kind) =
4333 match kind with
4334 | Onone -> ()
4335 | Oanchor anchor ->
4336 let (pageno, y, _) = anchor in
4337 let y = getanchory
4338 (if conf.presentation then (pageno, y, 1.0) else anchor)
4340 addnav ();
4341 gotoghyll y