Update
[llpp.git] / main.ml
blob5f1ec2fa49bac37778a4bf1d0b37d26435c1bfe0
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 ignoredoctitlte = ref false;;
61 let opengl_has_pbo = ref false;;
62 let layouth = ref ~-1;;
64 let drawstring size x y s =
65 Gl.enable `blend;
66 Gl.enable `texture_2d;
67 GlFunc.blend_func ~src:`src_alpha ~dst:`one_minus_src_alpha;
68 ignore (drawstr size x y s);
69 Gl.disable `blend;
70 Gl.disable `texture_2d;
73 let drawstring1 size x y s =
74 drawstr size x y s;
77 let drawstring2 size x y fmt =
78 Printf.kprintf (drawstring size (x+1) (y+size+1)) fmt
81 module UniSyms = struct
82 let ellipsis = "\xe2\x80\xa6";;
83 let radical = "\xe2\x88\x9a";;
84 let lguillemet = "\xc2\xab";;
85 let rguillemet = "\xc2\xbb";;
86 end;;
88 let _debugl l =
89 dolog {|l %d dim=%d {
90 WxH %dx%d
91 vWxH %dx%d
92 pagex,y %d,%d
93 dispx,y %d,%d
94 column %d
95 }|}
96 l.pageno l.pagedimno
97 l.pagew l.pageh
98 l.pagevw l.pagevh
99 l.pagex l.pagey
100 l.pagedispx l.pagedispy
101 l.pagecol
104 let debugrect (x0, y0, x1, y1, x2, y2, x3, y3) =
105 dolog {|rect {
106 x0,y0=(% f, % f)
107 x1,y1=(% f, % f)
108 x2,y2=(% f, % f)
109 x3,y3=(% f, % f)
110 }|} x0 y0 x1 y1 x2 y2 x3 y3;
113 let isbirdseye = function
114 | Birdseye _ -> true
115 | Textentry _ | View | LinkNav _ -> false
118 let istextentry = function
119 | Textentry _ -> true
120 | Birdseye _ | View | LinkNav _ -> false
123 let pgscale h = truncate (float h *. conf.pgscale);;
125 let hscrollh () =
126 if state.uioh#alwaysscrolly || ((conf.scrollb land scrollbhv != 0)
127 && (state.w > state.winw))
128 then conf.scrollbw
129 else 0
132 let vscrollw () =
133 if state.uioh#alwaysscrolly || ((conf.scrollb land scrollbvv != 0)
134 && (state.maxy > state.winh))
135 then conf.scrollbw
136 else 0
139 let vscrollhit x =
140 if conf.leftscroll
141 then x < vscrollw ()
142 else x > state.winw - vscrollw ()
145 let setfontsize n =
146 fstate.fontsize <- n;
147 fstate.wwidth <- measurestr fstate.fontsize "w";
148 fstate.maxrows <- (state.winh - fstate.fontsize - 1) / (fstate.fontsize + 1);
151 let vlog fmt =
152 if conf.verbose
153 then dolog fmt
154 else Printf.kprintf ignore fmt
157 let launchpath () =
158 if emptystr conf.pathlauncher
159 then dolog "%s" state.path
160 else (
161 let command = Str.global_replace percentsre state.path conf.pathlauncher in
162 match spawn command [] with
163 | _pid -> ()
164 | exception exn ->
165 dolog "failed to execute `%s': %s" command @@ exntos exn
169 module G =
170 struct
171 let postRedisplay who =
172 vlog "redisplay for [%S]" who;
173 state.redisplay <- true;
175 end;;
177 let getopaque pageno =
178 try Some (Hashtbl.find state.pagemap (pageno, state.gen))
179 with Not_found -> None
182 let pagetranslatepoint l x y =
183 let dy = y - l.pagedispy in
184 let y = dy + l.pagey in
185 let dx = x - l.pagedispx in
186 let x = dx + l.pagex in
187 (x, y);
190 let onppundermouse g x y d =
191 let rec f = function
192 | l :: rest ->
193 begin match getopaque l.pageno with
194 | Some opaque ->
195 let x0 = l.pagedispx in
196 let x1 = x0 + l.pagevw in
197 let y0 = l.pagedispy in
198 let y1 = y0 + l.pagevh in
199 if y >= y0 && y <= y1 && x >= x0 && x <= x1
200 then
201 let px, py = pagetranslatepoint l x y in
202 match g opaque l px py with
203 | Some res -> res
204 | None -> f rest
205 else f rest
206 | _ ->
207 f rest
209 | [] -> d
211 f state.layout
214 let getunder x y =
215 let g opaque l px py =
216 if state.bzoom
217 then (
218 match rectofblock opaque px py with
219 | Some [|x0;x1;y0;y1|] ->
220 let rect = (x0, y0, x1, y0, x1, y1, x0, y1) in
221 let color = (0.0, 0.0, 1.0 /. (l.pageno mod 3 |> float), 0.5) in
222 state.rects <- [l.pageno, color, rect];
223 G.postRedisplay "getunder";
224 | _ -> ()
226 let under = whatsunder opaque px py in
227 if under = Unone then None else Some under
229 onppundermouse g x y Unone
232 let unproject x y =
233 let g opaque l x y =
234 match unproject opaque x y with
235 | Some (x, y) -> Some (Some (opaque, l.pageno, x, y))
236 | None -> None
238 onppundermouse g x y None;
241 let showtext c s =
242 state.text <- Printf.sprintf "%c%s" c s;
243 G.postRedisplay "showtext";
246 let impmsg fmt =
247 Format.ksprintf (fun s -> showtext '!' s) fmt;
250 let pipef ?(closew=true) cap f cmd =
251 match Unix.pipe () with
252 | exception exn -> dolog "%s cannot create pipe: %S" cap @@ exntos exn
253 | (r, w) ->
254 begin match spawn cmd [r, 0; w, -1] with
255 | exception exn -> dolog "%s: cannot execute %S: %s" cap cmd @@ exntos exn
256 | _pid -> f w
257 end;
258 Ne.clo r (dolog "%s failed to close r: %s" cap);
259 if closew then Ne.clo w (dolog "%s failed to close w: %s" cap);
262 let pipesel opaque cmd =
263 if hassel opaque
264 then pipef ~closew:false "pipesel"
265 (fun w ->
266 copysel w opaque;
267 G.postRedisplay "pipesel"
268 ) cmd
271 let paxunder x y =
272 let g opaque l px py =
273 if markunder opaque px py conf.paxmark
274 then (
275 Some (fun () ->
276 match getopaque l.pageno with
277 | None -> ()
278 | Some opaque -> pipesel opaque conf.paxcmd
281 else None
283 G.postRedisplay "paxunder";
284 if conf.paxmark = Mark_page
285 then
286 List.iter (fun l ->
287 match getopaque l.pageno with
288 | None -> ()
289 | Some opaque -> clearmark opaque) state.layout;
290 state.roam <- onppundermouse g x y (fun () -> impmsg "whoopsie daisy");
293 let selstring s =
294 pipef
295 "selstring" (fun w ->
297 let l = String.length s in
298 let bytes = Bytes.unsafe_of_string s in
299 let n = tempfailureretry (Unix.write w bytes 0) l in
300 if n != l
301 then impmsg "failed to write %d characters to sel pipe, wrote %d" l n;
302 with exn -> impmsg "failed to write to sel pipe: %s" @@ exntos exn
303 ) conf.selcmd
306 let undertext = function
307 | Unone -> "none"
308 | Ulinkuri s -> s
309 | Utext s -> "font: " ^ s
310 | Uannotation (opaque, slinkindex) ->
311 "annotation: " ^ getannotcontents opaque slinkindex
314 let updateunder x y =
315 match getunder x y with
316 | Unone -> Wsi.setcursor Wsi.CURSOR_INHERIT
317 | Ulinkuri uri ->
318 if conf.underinfo then showtext 'u' ("ri: " ^ uri);
319 Wsi.setcursor Wsi.CURSOR_INFO
320 | Utext s ->
321 if conf.underinfo then showtext 'f' ("ont: " ^ s);
322 Wsi.setcursor Wsi.CURSOR_TEXT
323 | Uannotation _ ->
324 if conf.underinfo then showtext 'a' "nnotation";
325 Wsi.setcursor Wsi.CURSOR_INFO
328 let showlinktype under =
329 if conf.underinfo && under != Unone
330 then showtext ' ' @@ undertext under
333 let [@warning "-4"] intentry_with_suffix text key =
334 let text =
335 match key with
336 | Keys.Ascii ('0'..'9' as c) -> addchar text c
337 | Keys.Ascii ('k' | 'm' | 'g' | 'K' | 'M' | 'G' as c) ->
338 addchar text @@ asciilower c
339 | _ ->
340 state.text <- Printf.sprintf "invalid key";
341 text
343 TEcont text
346 let wcmd fmt =
347 let b = Buffer.create 16 in
348 Printf.kbprintf
349 (fun b ->
350 let b = Buffer.to_bytes b in
351 wcmd state.ss b @@ Bytes.length b
352 ) b fmt
355 let nogeomcmds cmds =
356 match cmds with
357 | s, [] -> emptystr s
358 | _ -> false
361 let layoutN ((columns, coverA, coverB), b) x y sw sh =
362 let rec fold accu n =
363 if n = Array.length b
364 then accu
365 else
366 let pdimno, dx, vy, (_, w, h, xoff) = b.(n) in
367 if (vy - y) > sh &&
368 (n = coverA - 1
369 || n = state.pagecount - coverB
370 || (n - coverA) mod columns = columns - 1)
371 then accu
372 else
373 let accu =
374 if vy + h > y
375 then
376 let pagey = max 0 (y - vy) in
377 let pagedispy = if pagey > 0 then 0 else vy - y in
378 let pagedispx, pagex =
379 let pdx =
380 if n = coverA - 1 || n = state.pagecount - coverB
381 then x + (sw - w) / 2
382 else dx + xoff + x
384 if pdx < 0
385 then 0, -pdx
386 else pdx, 0
388 let pagevw =
389 let vw = sw - pagedispx in
390 let pw = w - pagex in
391 min vw pw
393 let pagevh = min (h - pagey) (sh - pagedispy) in
394 if pagevw > 0 && pagevh > 0
395 then
396 let e =
397 { pageno = n
398 ; pagedimno = pdimno
399 ; pagew = w
400 ; pageh = h
401 ; pagex = pagex
402 ; pagey = pagey
403 ; pagevw = pagevw
404 ; pagevh = pagevh
405 ; pagedispx = pagedispx
406 ; pagedispy = pagedispy
407 ; pagecol = 0
410 e :: accu
411 else
412 accu
413 else
414 accu
416 fold accu (n+1)
418 if Array.length b = 0
419 then []
420 else List.rev (fold [] (page_of_y y))
423 let layoutS (columns, b) x y sw sh =
424 let rec fold accu n =
425 if n = Array.length b
426 then accu
427 else
428 let pdimno, px, vy, (_, pagew, pageh, xoff) = b.(n) in
429 if (vy - y) > sh
430 then accu
431 else
432 let accu =
433 if vy + pageh > y
434 then
435 let x = xoff + x in
436 let pagey = max 0 (y - vy) in
437 let pagedispy = if pagey > 0 then 0 else vy - y in
438 let pagedispx, pagex =
439 if px = 0
440 then (
441 if x < 0
442 then 0, -x
443 else x, 0
445 else (
446 let px = px - x in
447 if px < 0
448 then -px, 0
449 else 0, px
452 let pagecolw = pagew/columns in
453 let pagedispx =
454 if pagecolw < sw
455 then pagedispx + ((sw - pagecolw) / 2)
456 else pagedispx
458 let pagevw =
459 let vw = sw - pagedispx in
460 let pw = pagew - pagex in
461 min vw pw
463 let pagevw = min pagevw pagecolw in
464 let pagevh = min (pageh - pagey) (sh - pagedispy) in
465 if pagevw > 0 && pagevh > 0
466 then
467 let e =
468 { pageno = n/columns
469 ; pagedimno = pdimno
470 ; pagew = pagew
471 ; pageh = pageh
472 ; pagex = pagex
473 ; pagey = pagey
474 ; pagevw = pagevw
475 ; pagevh = pagevh
476 ; pagedispx = pagedispx
477 ; pagedispy = pagedispy
478 ; pagecol = n mod columns
481 e :: accu
482 else
483 accu
484 else
485 accu
487 fold accu (n+1)
489 List.rev (fold [] 0)
492 let layout x y sw sh =
493 if nogeomcmds state.geomcmds
494 then
495 match conf.columns with
496 | Csingle b -> layoutN ((1, 0, 0), b) x y sw sh
497 | Cmulti c -> layoutN c x y sw sh
498 | Csplit s -> layoutS s x y sw sh
499 else []
502 let maxy () = state.maxy - if conf.maxhfit then state.winh else 0;;
504 let clamp incr = bound (state.y + incr) 0 @@ maxy ();;
506 let itertiles l f =
507 let tilex = l.pagex mod conf.tilew in
508 let tiley = l.pagey mod conf.tileh in
510 let col = l.pagex / conf.tilew in
511 let row = l.pagey / conf.tileh in
513 let rec rowloop row y0 dispy h =
514 if h = 0
515 then ()
516 else (
517 let dh = conf.tileh - y0 in
518 let dh = min h dh in
519 let rec colloop col x0 dispx w =
520 if w = 0
521 then ()
522 else (
523 let dw = conf.tilew - x0 in
524 let dw = min w dw in
525 f col row dispx dispy x0 y0 dw dh;
526 colloop (col+1) 0 (dispx+dw) (w-dw)
529 colloop col tilex l.pagedispx l.pagevw;
530 rowloop (row+1) 0 (dispy+dh) (h-dh)
533 if l.pagevw > 0 && l.pagevh > 0
534 then rowloop row tiley l.pagedispy l.pagevh;
537 let gettileopaque l col row =
538 let key =
539 l.pageno, state.gen, conf.colorspace, conf.angle, l.pagew, l.pageh, col, row
541 try Some (Hashtbl.find state.tilemap key)
542 with Not_found -> None
545 let puttileopaque l col row gen colorspace angle opaque size elapsed =
546 let key = l.pageno, gen, colorspace, angle, l.pagew, l.pageh, col, row in
547 Hashtbl.add state.tilemap key (opaque, size, elapsed)
550 let filledrect2 x0 y0 x1 y1 x2 y2 x3 y3 =
551 Raw.sets_float state.vraw ~pos:0 [| x0; y0; x1; y1; x2; y2; x3; y3 |];
552 GlArray.vertex `two state.vraw;
553 GlArray.draw_arrays `triangle_strip ~first:0 ~count:4;
556 let filledrect1 x0 y0 x1 y1 = filledrect2 x0 y0 x0 y1 x1 y0 x1 y1;;
558 let filledrect x0 y0 x1 y1 =
559 GlArray.disable `texture_coord;
560 filledrect1 x0 y0 x1 y1;
561 GlArray.enable `texture_coord;
564 let linerect x0 y0 x1 y1 =
565 GlArray.disable `texture_coord;
566 Raw.sets_float state.vraw ~pos:0 [| x0; y0; x0; y1; x1; y1; x1; y0 |];
567 GlArray.vertex `two state.vraw;
568 GlArray.draw_arrays `line_loop ~first:0 ~count:4;
569 GlArray.enable `texture_coord;
572 let drawtiles l color =
573 GlDraw.color color;
574 begintiles ();
575 let f col row x y tilex tiley w h =
576 match gettileopaque l col row with
577 | Some (opaque, _, t) ->
578 let params = x, y, w, h, tilex, tiley in
579 if conf.invert
580 then GlTex.env (`mode `blend);
581 drawtile params opaque;
582 if conf.invert
583 then GlTex.env (`mode `modulate);
584 if conf.debug
585 then (
586 endtiles ();
587 let s = Printf.sprintf
588 "%d[%d,%d] %f sec"
589 l.pageno col row t
591 let w = measurestr fstate.fontsize s in
592 GlDraw.color (0.0, 0.0, 0.0);
593 filledrect (float (x-2))
594 (float (y-2))
595 (float (x+2) +. w)
596 (float (y + fstate.fontsize + 2));
597 GlDraw.color color;
598 drawstring fstate.fontsize x (y + fstate.fontsize - 1) s;
599 begintiles ();
602 | None ->
603 endtiles ();
604 let w =
605 let lw = state.winw - x in
606 min lw w
607 and h =
608 let lh = state.winh - y in
609 min lh h
611 if conf.invert
612 then GlTex.env (`mode `blend);
613 begin match state.checkerstexid with
614 | Some id ->
615 Gl.enable `texture_2d;
616 GlTex.bind_texture ~target:`texture_2d id;
617 let x0 = float x
618 and y0 = float y
619 and x1 = float (x+w)
620 and y1 = float (y+h) in
622 let tw = float w /. 16.0
623 and th = float h /. 16.0 in
624 let tx0 = float tilex /. 16.0
625 and ty0 = float tiley /. 16.0 in
626 let tx1 = tx0 +. tw
627 and ty1 = ty0 +. th in
628 Raw.sets_float state.vraw ~pos:0
629 [| x0; y0; x0; y1; x1; y0; x1; y1 |];
630 Raw.sets_float state.traw ~pos:0
631 [| tx0; ty0; tx0; ty1; tx1; ty0; tx1; ty1 |];
632 GlArray.vertex `two state.vraw;
633 GlArray.tex_coord `two state.traw;
634 GlArray.draw_arrays `triangle_strip ~first:0 ~count:4;
635 Gl.disable `texture_2d;
637 | None ->
638 GlDraw.color (1.0, 1.0, 1.0);
639 filledrect (float x) (float y) (float (x+w)) (float (y+h));
640 end;
641 if conf.invert
642 then GlTex.env (`mode `modulate);
643 if w > 128 && h > fstate.fontsize + 10
644 then (
645 let c = if conf.invert then 1.0 else 0.0 in
646 GlDraw.color (c, c, c);
647 let c, r =
648 if conf.verbose
649 then (col*conf.tilew, row*conf.tileh)
650 else col, row
652 drawstring2 fstate.fontsize x y "Loading %d [%d,%d]" l.pageno c r;
654 GlDraw.color color;
655 begintiles ();
657 itertiles l f;
658 endtiles ();
661 let pagevisible layout n = List.exists (fun l -> l.pageno = n) layout;;
663 let tilevisible1 l x y =
664 let ax0 = l.pagex
665 and ax1 = l.pagex + l.pagevw
666 and ay0 = l.pagey
667 and ay1 = l.pagey + l.pagevh in
669 let bx0 = x
670 and by0 = y in
671 let bx1 = min (bx0 + conf.tilew) l.pagew
672 and by1 = min (by0 + conf.tileh) l.pageh in
674 let rx0 = max ax0 bx0
675 and ry0 = max ay0 by0
676 and rx1 = min ax1 bx1
677 and ry1 = min ay1 by1 in
679 let nonemptyintersection = rx1 > rx0 && ry1 > ry0 in
680 nonemptyintersection
683 let tilevisible layout n x y =
684 let rec findpageinlayout m = function
685 | l :: rest when l.pageno = n ->
686 tilevisible1 l x y || (
687 match conf.columns with
688 | Csplit (c, _) when c > m -> findpageinlayout (m+1) rest
689 | Csplit _ | Csingle _ | Cmulti _ -> false
691 | _ :: rest -> findpageinlayout 0 rest
692 | [] -> false
694 findpageinlayout 0 layout;
697 let tileready l x y =
698 tilevisible1 l x y &&
699 gettileopaque l (x/conf.tilew) (y/conf.tileh) != None
702 let tilepage n p layout =
703 let rec loop = function
704 | l :: rest ->
705 if l.pageno = n
706 then
707 let f col row _ _ _ _ _ _ =
708 if state.currently = Idle
709 then
710 match gettileopaque l col row with
711 | Some _ -> ()
712 | None ->
713 let x = col*conf.tilew
714 and y = row*conf.tileh in
715 let w =
716 let w = l.pagew - x in
717 min w conf.tilew
719 let h =
720 let h = l.pageh - y in
721 min h conf.tileh
723 let pbo =
724 if conf.usepbo
725 then getpbo w h conf.colorspace
726 else ~< "0"
728 wcmd "tile %s %d %d %d %d %s"
729 (~> p) x y w h (~> pbo);
730 state.currently <-
731 Tiling (
732 l, p, conf.colorspace, conf.angle,
733 state.gen, col, row, conf.tilew, conf.tileh
736 itertiles l f;
737 else
738 loop rest
740 | [] -> ()
742 if nogeomcmds state.geomcmds
743 then loop layout;
746 let preloadlayout x y sw sh =
747 let y = if y < sh then 0 else y - sh in
748 let x = min 0 (x + sw) in
749 let h = sh*3 in
750 let w = sw*3 in
751 layout x y w h;
754 let load pages =
755 let rec loop pages =
756 if state.currently != Idle
757 then ()
758 else
759 match pages with
760 | l :: rest ->
761 begin match getopaque l.pageno with
762 | None ->
763 wcmd "page %d %d" l.pageno l.pagedimno;
764 state.currently <- Loading (l, state.gen);
765 | Some opaque ->
766 tilepage l.pageno opaque pages;
767 loop rest
768 end;
769 | _ -> ()
771 if nogeomcmds state.geomcmds
772 then loop pages
775 let preload pages =
776 load pages;
777 if conf.preload && state.currently = Idle
778 then load (preloadlayout state.x state.y state.winw state.winh);
781 let layoutready layout =
782 let rec fold all ls =
783 all && match ls with
784 | l :: rest ->
785 let seen = ref false in
786 let allvisible = ref true in
787 let foo col row _ _ _ _ _ _ =
788 seen := true;
789 allvisible := !allvisible &&
790 begin match gettileopaque l col row with
791 | Some _ -> true
792 | None -> false
795 itertiles l foo;
796 fold (!seen && !allvisible) rest
797 | [] -> true
799 let alltilesvisible = fold true layout in
800 alltilesvisible;
803 let gotoxy x y =
804 let y = bound y 0 state.maxy in
805 let y, layout, proceed =
806 match conf.maxwait with
807 | Some time when state.ghyll == noghyll ->
808 begin match state.throttle with
809 | None ->
810 let layout = layout x y state.winw state.winh in
811 let ready = layoutready layout in
812 if not ready
813 then (
814 load layout;
815 state.throttle <- Some (layout, y, now ());
817 else G.postRedisplay "gotoxy showall (None)";
818 y, layout, ready
819 | Some (_, _, started) ->
820 let dt = now () -. started in
821 if dt > time
822 then (
823 state.throttle <- None;
824 let layout = layout x y state.winw state.winh in
825 load layout;
826 G.postRedisplay "maxwait";
827 y, layout, true
829 else -1, [], false
832 | _ ->
833 let layout = layout x y state.winw state.winh in
834 G.postRedisplay "gotoxy ready";
835 y, layout, true
837 if proceed
838 then (
839 state.x <- x;
840 state.y <- y;
841 state.layout <- layout;
842 begin match state.mode with
843 | LinkNav ln ->
844 begin match ln with
845 | Ltexact (pageno, linkno) ->
846 let rec loop = function
847 | [] ->
848 state.lnava <- Some (pageno, linkno);
849 state.mode <- LinkNav (Ltgendir 0)
850 | l :: _ when l.pageno = pageno ->
851 begin match getopaque pageno with
852 | None -> state.mode <- LinkNav (Ltnotready (pageno, 0))
853 | Some opaque ->
854 let x0, y0, x1, y1 = getlinkrect opaque linkno in
855 if not (x0 >= l.pagex && x1 <= l.pagex + l.pagevw
856 && y0 >= l.pagey && y1 <= l.pagey + l.pagevh)
857 then state.mode <- LinkNav (Ltgendir 0)
859 | _ :: rest -> loop rest
861 loop layout
862 | Ltnotready _ | Ltgendir _ -> ()
864 | Birdseye _ | Textentry _ | View -> ()
865 end;
866 begin match state.mode with
867 | Birdseye (conf, leftx, pageno, hooverpageno, anchor) ->
868 if not (pagevisible layout pageno)
869 then (
870 match state.layout with
871 | [] -> ()
872 | l :: _ ->
873 state.mode <- Birdseye (
874 conf, leftx, l.pageno, hooverpageno, anchor
877 | LinkNav lt ->
878 begin match lt with
879 | Ltnotready (_, dir)
880 | Ltgendir dir ->
881 let linknav =
882 let rec loop = function
883 | [] -> lt
884 | l :: rest ->
885 match getopaque l.pageno with
886 | None -> Ltnotready (l.pageno, dir)
887 | Some opaque ->
888 let link =
889 let ld =
890 if dir = 0
891 then LDfirstvisible (l.pagex, l.pagey, dir)
892 else (
893 if dir > 0 then LDfirst else LDlast
896 findlink opaque ld
898 match link with
899 | Lnotfound -> loop rest
900 | Lfound n ->
901 showlinktype (getlink opaque n);
902 Ltexact (l.pageno, n)
904 loop state.layout
906 state.mode <- LinkNav linknav
907 | Ltexact _ -> ()
909 | Textentry _ | View -> ()
910 end;
911 preload layout;
913 state.ghyll <- noghyll;
914 if conf.updatecurs
915 then (
916 let mx, my = state.mpos in
917 updateunder mx my;
921 let conttiling pageno opaque =
922 tilepage pageno opaque
923 (if conf.preload
924 then preloadlayout state.x state.y state.winw state.winh
925 else state.layout)
928 let gotoxy_and_clear_text x y =
929 if not conf.verbose then state.text <- E.s;
930 gotoxy x y;
933 let getanchory (n, top, dtop) =
934 let y, h = getpageyh n in
935 if conf.presentation
936 then
937 let ips = calcips h in
938 y + truncate (top*.float h -. dtop*.float ips) + ips;
939 else
940 y + truncate (top*.float h -. dtop*.float conf.interpagespace)
943 let gotoanchor anchor =
944 gotoxy state.x (getanchory anchor);
947 let addnav () =
948 getanchor () |> cbput state.hists.nav;
951 let addnavnorc () =
952 getanchor () |> cbput_dont_update_rc state.hists.nav;
955 let getnav dir =
956 let anchor = cbgetc state.hists.nav dir in
957 getanchory anchor;
960 let gotoghyll1 single y =
961 let scroll f n a b =
962 (* http://devmaster.net/forums/topic/9796-ease-in-ease-out-algorithm/ *)
963 let snake f a b =
964 let s x = 3.0*.x**2.0 -. 2.0*.x**3.0 in
965 if f < a
966 then s (float f /. float a)
967 else (
968 if f > b
969 then 1.0 -. s ((float (f-b) /. float (n-b)))
970 else 1.0
973 snake f a b
974 and summa n a b =
975 let ins = float a *. 0.5
976 and outs = float (n-b) *. 0.5 in
977 let ones = b - a in
978 ins +. outs +. float ones
980 let rec set nab y sy =
981 let (_N, _A, _B), y =
982 if single
983 then
984 let scl = if y > sy then 2 else -2 in
985 let _N, _, _ = nab in
986 (_N,0,_N), y+conf.scrollstep*scl
987 else nab,y in
988 let sum = summa _N _A _B in
989 let dy = float (y - sy) in
990 state.ghyll <- (
991 let rec gf n y1 o =
992 if n >= _N
993 then state.ghyll <- noghyll
994 else
995 let go n =
996 let s = scroll n _N _A _B in
997 let y1 = y1 +. ((s *. dy) /. sum) in
998 gotoxy_and_clear_text state.x (truncate y1);
999 state.ghyll <- gf (n+1) y1;
1001 match o with
1002 | None -> go n
1003 | Some y' when single -> set nab y' state.y
1004 | Some y' -> set (_N/2, 1, 1) y' state.y
1006 gf 0 (float state.y)
1009 match conf.ghyllscroll with
1010 | Some nab when not conf.presentation ->
1011 if state.ghyll == noghyll
1012 then set nab y state.y
1013 else state.ghyll (Some y)
1014 | _ ->
1015 gotoxy_and_clear_text state.x y
1018 let gotoghyll = gotoghyll1 false;;
1020 let gotopage n top =
1021 let y, h = getpageyh n in
1022 let y = y + (truncate (top *. float h)) in
1023 gotoghyll y
1026 let gotopage1 n top =
1027 let y = getpagey n in
1028 let y = y + top in
1029 gotoghyll y
1032 let invalidate s f =
1033 state.redisplay <- false;
1034 state.layout <- [];
1035 state.pdims <- [];
1036 state.rects <- [];
1037 state.rects1 <- [];
1038 match state.geomcmds with
1039 | ps, [] when emptystr ps ->
1040 f ();
1041 state.geomcmds <- s, [];
1043 | ps, [] ->
1044 state.geomcmds <- ps, [s, f];
1046 | ps, (s', _) :: rest when s' = s ->
1047 state.geomcmds <- ps, ((s, f) :: rest);
1049 | ps, cmds ->
1050 state.geomcmds <- ps, ((s, f) :: cmds);
1053 let flushpages () =
1054 Hashtbl.iter (fun _ opaque ->
1055 wcmd "freepage %s" (~> opaque);
1056 ) state.pagemap;
1057 Hashtbl.clear state.pagemap;
1060 let flushtiles () =
1061 if not (Queue.is_empty state.tilelru)
1062 then (
1063 Queue.iter (fun (k, p, s) ->
1064 wcmd "freetile %s" (~> p);
1065 state.memused <- state.memused - s;
1066 Hashtbl.remove state.tilemap k;
1067 ) state.tilelru;
1068 state.uioh#infochanged Memused;
1069 Queue.clear state.tilelru;
1071 load state.layout;
1074 let stateh h =
1075 let h = truncate (float h*.conf.zoom) in
1076 let d = conf.interpagespace lsl (if conf.presentation then 1 else 0) in
1077 h - d
1080 let fillhelp () =
1081 state.help <-
1082 let sl = keystostrlist conf in
1083 let rec loop accu =
1084 function | [] -> accu
1085 | s :: rest -> loop ((s, 0, Noaction) :: accu) rest
1086 in makehelp () @ (("", 0, Noaction) :: loop [] sl) |> Array.of_list
1089 let opendoc path password =
1090 state.path <- path;
1091 state.password <- password;
1092 state.gen <- state.gen + 1;
1093 state.docinfo <- [];
1094 state.outlines <- [||];
1096 flushpages ();
1097 setaalevel conf.aalevel;
1098 let titlepath =
1099 if emptystr state.origin
1100 then path
1101 else state.origin
1103 Wsi.settitle ("llpp " ^ (mbtoutf8 (Filename.basename titlepath)));
1104 wcmd "open %d %d %s\000%s\000%s\000"
1105 (btod conf.usedoccss) !layouth
1106 path password conf.css;
1107 invalidate "reqlayout"
1108 (fun () ->
1109 wcmd "reqlayout %d %d %d %s\000"
1110 conf.angle (FMTE.to_int conf.fitmodel)
1111 (stateh state.winh) state.nameddest
1113 fillhelp ();
1116 let reload () =
1117 state.anchor <- getanchor ();
1118 opendoc state.path state.password;
1121 let scalecolor c =
1122 let c = c *. conf.colorscale in
1123 (c, c, c);
1126 let scalecolor2 (r, g, b) =
1127 (r *. conf.colorscale, g *. conf.colorscale, b *. conf.colorscale);
1130 let docolumns columns =
1131 match columns with
1132 | Csingle _ ->
1133 let a = Array.make state.pagecount (-1, -1, -1, (-1, -1, -1, -1)) in
1134 let rec loop pageno pdimno pdim y ph pdims =
1135 if pageno = state.pagecount
1136 then ()
1137 else
1138 let pdimno, ((_, w, h, xoff) as pdim), pdims =
1139 match pdims with
1140 | ((pageno', _, _, _) as pdim) :: rest when pageno' = pageno ->
1141 pdimno+1, pdim, rest
1142 | _ ->
1143 pdimno, pdim, pdims
1145 let x = max 0 (((state.winw - w) / 2) - xoff) in
1146 let y =
1147 y + (if conf.presentation
1148 then (if pageno = 0 then calcips h else calcips ph + calcips h)
1149 else (if pageno = 0 then 0 else conf.interpagespace)
1152 a.(pageno) <- (pdimno, x, y, pdim);
1153 loop (pageno+1) pdimno pdim (y + h) h pdims
1155 loop 0 ~-1 (-1,-1,-1,-1) 0 0 state.pdims;
1156 conf.columns <- Csingle a;
1158 | Cmulti ((columns, coverA, coverB), _) ->
1159 let a = Array.make state.pagecount (-1, -1, -1, (-1, -1, -1, -1)) in
1160 let rec loop pageno pdimno pdim x y rowh pdims =
1161 let rec fixrow m =
1162 if m = pageno then () else
1163 let (pdimno, x, y, ((_, _, h, _) as pdim)) = a.(m) in
1164 if h < rowh
1165 then (
1166 let y = y + (rowh - h) / 2 in
1167 a.(m) <- (pdimno, x, y, pdim);
1169 fixrow (m+1)
1171 if pageno = state.pagecount
1172 then fixrow (((pageno - 1) / columns) * columns)
1173 else
1174 let pdimno, ((_, w, h, xoff) as pdim), pdims =
1175 match pdims with
1176 | ((pageno', _, _, _) as pdim) :: rest when pageno' = pageno ->
1177 pdimno+1, pdim, rest
1178 | _ ->
1179 pdimno, pdim, pdims
1181 let x, y, rowh' =
1182 if pageno = coverA - 1 || pageno = state.pagecount - coverB
1183 then (
1184 let x = (state.winw - w) / 2 in
1185 let ips =
1186 if conf.presentation then calcips h else conf.interpagespace in
1187 x, y + ips + rowh, h
1189 else (
1190 if (pageno - coverA) mod columns = 0
1191 then (
1192 let x = max 0 (state.winw - state.w) / 2 in
1193 let y =
1194 if conf.presentation
1195 then
1196 let ips = calcips h in
1197 y + (if pageno = 0 then 0 else calcips rowh + ips)
1198 else
1199 y + (if pageno = 0 then 0 else conf.interpagespace)
1201 x, y + rowh, h
1203 else x, y, max rowh h
1206 let y =
1207 if pageno > 1 && (pageno - coverA) mod columns = 0
1208 then (
1209 let y =
1210 if pageno = columns && conf.presentation
1211 then (
1212 let ips = calcips rowh in
1213 for i = 0 to pred columns
1215 let (pdimno, x, y, pdim) = a.(i) in
1216 a.(i) <- (pdimno, x, y+ips, pdim)
1217 done;
1218 y+ips;
1220 else y
1222 fixrow (pageno - columns);
1225 else y
1227 a.(pageno) <- (pdimno, x, y, pdim);
1228 let x = x + w + xoff*2 + conf.interpagespace in
1229 loop (pageno+1) pdimno pdim x y rowh' pdims
1231 loop 0 ~-1 (-1,-1,-1,-1) 0 0 0 state.pdims;
1232 conf.columns <- Cmulti ((columns, coverA, coverB), a);
1234 | Csplit (c, _) ->
1235 let a = Array.make (state.pagecount*c) (-1, -1, -1, (-1, -1, -1, -1)) in
1236 let rec loop pageno pdimno pdim y pdims =
1237 if pageno = state.pagecount
1238 then ()
1239 else
1240 let pdimno, ((_, w, h, _) as pdim), pdims =
1241 match pdims with
1242 | ((pageno', _, _, _) as pdim) :: rest when pageno' = pageno ->
1243 pdimno+1, pdim, rest
1244 | _ ->
1245 pdimno, pdim, pdims
1247 let cw = w / c in
1248 let rec loop1 n x y =
1249 if n = c then y else (
1250 a.(pageno*c + n) <- (pdimno, x, y, pdim);
1251 loop1 (n+1) (x+cw) (y + h + conf.interpagespace)
1254 let y = loop1 0 0 y in
1255 loop (pageno+1) pdimno pdim y pdims
1257 loop 0 ~-1 (-1,-1,-1,-1) 0 state.pdims;
1258 conf.columns <- Csplit (c, a);
1261 let represent () =
1262 docolumns conf.columns;
1263 state.maxy <- calcheight ();
1264 if state.reprf == noreprf
1265 then (
1266 match state.mode with
1267 | Birdseye (_, _, pageno, _, _) ->
1268 let y, h = getpageyh pageno in
1269 let top = (state.winh - h) / 2 in
1270 gotoxy state.x (max 0 (y - top))
1271 | Textentry _ | View | LinkNav _ ->
1272 let y = getanchory state.anchor in
1273 let y = min y (state.maxy - state.winh) in
1274 gotoxy state.x y;
1276 else (
1277 state.reprf ();
1278 state.reprf <- noreprf;
1282 let reshape ?(firsttime=false) w h =
1283 GlDraw.viewport ~x:0 ~y:0 ~w ~h;
1284 if not firsttime && nogeomcmds state.geomcmds
1285 then state.anchor <- getanchor ();
1287 state.winw <- w;
1288 let w = truncate (float w *. conf.zoom) in
1289 let w = max w 2 in
1290 state.winh <- h;
1291 setfontsize fstate.fontsize;
1292 GlMat.mode `modelview;
1293 GlMat.load_identity ();
1295 GlMat.mode `projection;
1296 GlMat.load_identity ();
1297 GlMat.rotate ~x:1.0 ~angle:180.0 ();
1298 GlMat.translate ~x:~-.1.0 ~y:~-.1.0 ();
1299 GlMat.scale3 (2.0 /. float state.winw, 2.0 /. float state.winh, 1.0);
1301 let relx =
1302 if conf.zoom <= 1.0
1303 then 0.0
1304 else float state.x /. float state.w
1306 invalidate "geometry"
1307 (fun () ->
1308 state.w <- w;
1309 if not firsttime
1310 then state.x <- truncate (relx *. float w);
1311 let w =
1312 match conf.columns with
1313 | Csingle _ -> w
1314 | Cmulti ((c, _, _), _) -> (w - (c-1)*conf.interpagespace) / c
1315 | Csplit (c, _) -> w * c
1317 wcmd "geometry %d %d %d"
1318 w (stateh h) (FMTE.to_int conf.fitmodel)
1322 let enttext () =
1323 let len = String.length state.text in
1324 let x0 = if conf.leftscroll then vscrollw () else 0 in
1325 let drawstring s =
1326 let hscrollh =
1327 match state.mode with
1328 | Textentry _ | View | LinkNav _ ->
1329 let h, _, _ = state.uioh#scrollpw in
1331 | Birdseye _ -> 0
1333 let rect x w =
1334 filledrect
1335 x (float (state.winh - (fstate.fontsize + 4) - hscrollh))
1336 (x+.w) (float (state.winh - hscrollh))
1339 let w = float (state.winw - 1 - vscrollw ()) in
1340 if state.progress >= 0.0 && state.progress < 1.0
1341 then (
1342 GlDraw.color (0.3, 0.3, 0.3);
1343 let w1 = w *. state.progress in
1344 rect (float x0) w1;
1345 GlDraw.color (0.0, 0.0, 0.0);
1346 rect (float x0+.w1) (float x0+.w-.w1)
1348 else (
1349 GlDraw.color (0.0, 0.0, 0.0);
1350 rect (float x0) w;
1353 GlDraw.color (1.0, 1.0, 1.0);
1354 drawstring
1355 fstate.fontsize
1356 (if conf.leftscroll then x0 + 2 else x0 + if len > 0 then 8 else 2)
1357 (state.winh - hscrollh - 5) s;
1359 let s =
1360 match state.mode with
1361 | Textentry ((prefix, text, _, _, _, _), _) ->
1362 let s =
1363 if len > 0
1364 then Printf.sprintf "%s%s_ [%s]" prefix text state.text
1365 else Printf.sprintf "%s%s_" prefix text
1369 | Birdseye _ | View | LinkNav _ -> state.text
1371 let s =
1372 if state.newerrmsgs
1373 then (
1374 if not (istextentry state.mode) && state.uioh#eformsgs
1375 then
1376 let s1 = "(press 'e' to review error messasges)" in
1377 if nonemptystr s then s ^ " " ^ s1 else s1
1378 else s
1380 else s
1382 if nonemptystr s
1383 then drawstring s
1386 let gctiles () =
1387 let len = Queue.length state.tilelru in
1388 let layout = lazy (
1389 match state.throttle with
1390 | None ->
1391 if conf.preload
1392 then preloadlayout state.x state.y state.winw state.winh
1393 else state.layout
1394 | Some (layout, _, _) ->
1395 layout
1396 ) in
1397 let rec loop qpos =
1398 if state.memused > conf.memlimit
1399 then (
1400 if qpos < len
1401 then
1402 let (k, p, s) as lruitem = Queue.pop state.tilelru in
1403 let n, gen, colorspace, angle, pagew, pageh, col, row = k in
1404 let (_, pw, ph, _) = getpagedim n in
1405 if gen = state.gen
1406 && colorspace = conf.colorspace
1407 && angle = conf.angle
1408 && pagew = pw
1409 && pageh = ph
1410 && (
1411 let x = col*conf.tilew
1412 and y = row*conf.tileh in
1413 tilevisible (Lazy.force_val layout) n x y
1415 then Queue.push lruitem state.tilelru
1416 else (
1417 freepbo p;
1418 wcmd "freetile %s" (~> p);
1419 state.memused <- state.memused - s;
1420 state.uioh#infochanged Memused;
1421 Hashtbl.remove state.tilemap k;
1423 loop (qpos+1)
1426 loop 0
1429 let onpagerect pageno f =
1430 let b =
1431 match conf.columns with
1432 | Cmulti (_, b) -> b
1433 | Csingle b -> b
1434 | Csplit (_, b) -> b
1436 if pageno >= 0 && pageno < Array.length b
1437 then
1438 let (_, _, _, (_, w, h, _)) = b.(pageno) in
1439 f w h
1442 let gotopagexy1 pageno x y =
1443 let _,w1,h1,leftx = getpagedim pageno in
1444 let top = y /. (float h1) in
1445 let left = x /. (float w1) in
1446 let py, w, h = getpageywh pageno in
1447 let wh = state.winh in
1448 let x = left *. (float w) in
1449 let x = leftx + state.x + truncate x in
1450 let sx =
1451 if x < 0 || x >= state.winw
1452 then state.x - x
1453 else state.x
1455 let pdy = truncate (top *. float h) in
1456 let y' = py + pdy in
1457 let dy = y' - state.y in
1458 let sy =
1459 if x != state.x || not (dy > 0 && dy < wh)
1460 then (
1461 if conf.presentation
1462 then
1463 if abs (py - y') > wh
1464 then y'
1465 else py
1466 else y';
1468 else state.y
1470 if state.x != sx || state.y != sy
1471 then gotoxy_and_clear_text sx sy
1472 else gotoxy_and_clear_text state.x state.y;
1475 let gotopagexy pageno x y =
1476 match state.mode with
1477 | Birdseye _ -> gotopage pageno 0.0
1478 | Textentry _ | View | LinkNav _ -> gotopagexy1 pageno x y
1481 let getpassword () =
1482 let passcmd = getenvwithdef "LLPP_ASKPASS" conf.passcmd in
1483 if emptystr passcmd
1484 then E.s
1485 else getcmdoutput
1486 (fun s ->
1487 impmsg "error getting password: %s" s;
1488 dolog "%s" s) passcmd;
1491 let pgoto opaque pageno x y =
1492 let pdimno = getpdimno pageno in
1493 let x, y = project opaque pageno pdimno x y in
1494 gotopagexy pageno x y;
1497 let act cmds =
1498 (* dolog "%S" cmds; *)
1499 let spl = splitatchar cmds ' ' in
1500 let scan s fmt f =
1501 try Scanf.sscanf s fmt f
1502 with exn ->
1503 dolog "error processing '%S': %s" cmds @@ exntos exn;
1504 exit 1
1506 let addoutline outline =
1507 match state.currently with
1508 | Outlining outlines -> state.currently <- Outlining (outline :: outlines)
1509 | Idle -> state.currently <- Outlining [outline]
1510 | Loading _ | Tiling _ ->
1511 dolog "invalid outlining state";
1512 logcurrently state.currently
1514 match spl with
1515 | "clear", "" ->
1516 state.pdims <- [];
1517 state.uioh#infochanged Pdim;
1519 | "clearrects", "" ->
1520 state.rects <- state.rects1;
1521 G.postRedisplay "clearrects";
1523 | "continue", args ->
1524 let n = scan args "%u" (fun n -> n) in
1525 state.pagecount <- n;
1526 begin match state.currently with
1527 | Outlining l ->
1528 state.currently <- Idle;
1529 state.outlines <- Array.of_list (List.rev l)
1530 | Idle | Loading _ | Tiling _ -> ()
1531 end;
1533 let cur, cmds = state.geomcmds in
1534 if emptystr cur
1535 then failwith "umpossible";
1537 begin match List.rev cmds with
1538 | [] ->
1539 state.geomcmds <- E.s, [];
1540 state.throttle <- None;
1541 represent ();
1542 | (s, f) :: rest ->
1543 f ();
1544 state.geomcmds <- s, List.rev rest;
1545 end;
1546 if conf.maxwait = None
1547 then G.postRedisplay "continue";
1549 | "msg", args ->
1550 showtext ' ' args
1552 | "vmsg", args ->
1553 if conf.verbose
1554 then showtext ' ' args
1556 | "emsg", args ->
1557 Buffer.add_string state.errmsgs args;
1558 state.newerrmsgs <- true;
1559 G.postRedisplay "error message"
1561 | "progress", args ->
1562 let progress, text =
1563 scan args "%f %n"
1564 (fun f pos ->
1565 f, String.sub args pos (String.length args - pos))
1567 state.text <- text;
1568 state.progress <- progress;
1569 G.postRedisplay "progress"
1571 | "firstmatch", args ->
1572 let pageno, c, x0, y0, x1, y1, x2, y2, x3, y3 =
1573 scan args "%u %d %f %f %f %f %f %f %f %f"
1574 (fun p c x0 y0 x1 y1 x2 y2 x3 y3 ->
1575 (p, c, x0, y0, x1, y1, x2, y2, x3, y3))
1577 let y = (getpagey pageno) + truncate y0 in
1578 let x =
1579 if (state.x < - truncate x0) || (state.x > state.winw - truncate x1)
1580 then state.winw/2 - truncate (x0 /. 2. +. x1 /. 2.)
1581 else state.x
1583 addnav ();
1584 gotoxy x y;
1585 let color = (0.0, 0.0, 1.0 /. float c, 0.5) in
1586 state.rects1 <- [pageno, color, (x0, y0, x1, y1, x2, y2, x3, y3)]
1588 | "match", args ->
1589 let pageno, c, x0, y0, x1, y1, x2, y2, x3, y3 =
1590 scan args "%u %d %f %f %f %f %f %f %f %f"
1591 (fun p c x0 y0 x1 y1 x2 y2 x3 y3 ->
1592 (p, c, x0, y0, x1, y1, x2, y2, x3, y3))
1594 let color = (0.0, 0.0, 1.0 /. float c, 0.5) in
1595 state.rects1 <-
1596 (pageno, color, (x0, y0, x1, y1, x2, y2, x3, y3)) :: state.rects1
1598 | "page", args ->
1599 let pageopaques, t = scan args "%s %f" (fun p t -> p, t) in
1600 let pageopaque = ~< pageopaques in
1601 begin match state.currently with
1602 | Loading (l, gen) ->
1603 vlog "page %d took %f sec" l.pageno t;
1604 Hashtbl.replace state.pagemap (l.pageno, gen) pageopaque;
1605 begin match state.throttle with
1606 | None ->
1607 let preloadedpages =
1608 if conf.preload
1609 then preloadlayout state.x state.y state.winw state.winh
1610 else state.layout
1612 let evict () =
1613 let set =
1614 List.fold_left (fun s l -> IntSet.add l.pageno s)
1615 IntSet.empty preloadedpages
1617 let evictedpages =
1618 Hashtbl.fold (fun ((pageno, _) as key) opaque accu ->
1619 if not (IntSet.mem pageno set)
1620 then (
1621 wcmd "freepage %s" (~> opaque);
1622 key :: accu
1624 else accu
1625 ) state.pagemap []
1627 List.iter (Hashtbl.remove state.pagemap) evictedpages;
1629 evict ();
1630 state.currently <- Idle;
1631 if gen = state.gen
1632 then (
1633 tilepage l.pageno pageopaque state.layout;
1634 load state.layout;
1635 load preloadedpages;
1636 let visible = pagevisible state.layout l.pageno in
1637 if visible
1638 then (
1639 match state.mode with
1640 | LinkNav (Ltnotready (pageno, dir)) ->
1641 if pageno = l.pageno
1642 then (
1643 let link =
1644 let ld =
1645 if dir = 0
1646 then LDfirstvisible (l.pagex, l.pagey, dir)
1647 else (
1648 if dir > 0 then LDfirst else LDlast
1651 findlink pageopaque ld
1653 match link with
1654 | Lnotfound -> ()
1655 | Lfound n ->
1656 showlinktype (getlink pageopaque n);
1657 state.mode <- LinkNav (Ltexact (l.pageno, n))
1659 | LinkNav (Ltgendir _)
1660 | LinkNav (Ltexact _)
1661 | View
1662 | Birdseye _
1663 | Textentry _ -> ()
1666 if visible && layoutready state.layout
1667 then (
1668 G.postRedisplay "page";
1672 | Some (layout, _, _) ->
1673 state.currently <- Idle;
1674 tilepage l.pageno pageopaque layout;
1675 load state.layout
1676 end;
1678 | Idle | Tiling _ | Outlining _ ->
1679 dolog "Inconsistent loading state";
1680 logcurrently state.currently;
1681 exit 1
1684 | "tile" , args ->
1685 let (x, y, opaques, size, t) =
1686 scan args "%u %u %s %u %f"
1687 (fun x y p size t -> (x, y, p, size, t))
1689 let opaque = ~< opaques in
1690 begin match state.currently with
1691 | Tiling (l, pageopaque, cs, angle, gen, col, row, tilew, tileh) ->
1692 vlog "tile %d [%d,%d] took %f sec" l.pageno col row t;
1694 unmappbo opaque;
1695 if tilew != conf.tilew || tileh != conf.tileh
1696 then (
1697 wcmd "freetile %s" (~> opaque);
1698 state.currently <- Idle;
1699 load state.layout;
1701 else (
1702 puttileopaque l col row gen cs angle opaque size t;
1703 state.memused <- state.memused + size;
1704 state.uioh#infochanged Memused;
1705 gctiles ();
1706 Queue.push ((l.pageno, gen, cs, angle, l.pagew, l.pageh, col, row),
1707 opaque, size) state.tilelru;
1709 let layout =
1710 match state.throttle with
1711 | None -> state.layout
1712 | Some (layout, _, _) -> layout
1715 state.currently <- Idle;
1716 if gen = state.gen
1717 && conf.colorspace = cs
1718 && conf.angle = angle
1719 && tilevisible layout l.pageno x y
1720 then conttiling l.pageno pageopaque;
1722 begin match state.throttle with
1723 | None ->
1724 preload state.layout;
1725 if gen = state.gen
1726 && conf.colorspace = cs
1727 && conf.angle = angle
1728 && tilevisible state.layout l.pageno x y
1729 && layoutready state.layout
1730 then G.postRedisplay "tile nothrottle";
1732 | Some (layout, y, _) ->
1733 let ready = layoutready layout in
1734 if ready
1735 then (
1736 state.y <- y;
1737 state.layout <- layout;
1738 state.throttle <- None;
1739 G.postRedisplay "throttle";
1741 else load layout;
1742 end;
1745 | Idle | Loading _ | Outlining _ ->
1746 dolog "Inconsistent tiling state";
1747 logcurrently state.currently;
1748 exit 1
1751 | "pdim", args ->
1752 let (n, w, h, _) as pdim =
1753 scan args "%u %u %u %u" (fun n w h x -> n, w, h, x)
1755 let pdim =
1756 match conf.fitmodel with
1757 | FitWidth -> pdim
1758 | FitPage | FitProportional ->
1759 match conf.columns with
1760 | Csplit _ -> (n, w, h, 0)
1761 | Csingle _ | Cmulti _ -> pdim
1763 state.pdims <- pdim :: state.pdims;
1764 state.uioh#infochanged Pdim
1766 | "o", args ->
1767 let (l, n, t, h, pos) =
1768 scan args "%u %u %d %u %n"
1769 (fun l n t h pos -> l, n, t, h, pos)
1771 let s = String.sub args pos (String.length args - pos) in
1772 addoutline (s, l, Oanchor (n, float t /. float h, 0.0))
1774 | "ou", args ->
1775 let (l, len, pos) = scan args "%u %u %n" (fun l len pos -> l, len, pos) in
1776 let s = String.sub args pos len in
1777 let pos2 = pos + len + 1 in
1778 let uri = String.sub args pos2 (String.length args - pos2) in
1779 addoutline (s, l, Ouri uri)
1781 | "on", args ->
1782 let (l, pos) = scan args "%u %n" (fun l pos -> l, pos) in
1783 let s = String.sub args pos (String.length args - pos) in
1784 addoutline (s, l, Onone)
1786 | "a", args ->
1787 let (n, l, t) =
1788 scan args "%u %d %d" (fun n l t -> n, l, t)
1790 state.reprf <- (fun () -> gotopagexy n (float l) (float t))
1792 | "info", args ->
1793 let c, v = splitatchar args '\t' in
1794 let s =
1795 if nonemptystr v
1796 then
1797 if c = "Title"
1798 then (
1799 conf.title <- v;
1800 if not !ignoredoctitlte
1801 then Wsi.settitle v;
1802 args
1804 else
1805 if let len = String.length c in
1806 len > 6 && ((String.sub c (len-4) 4) = "date")
1807 then (
1808 if String.length v >= 7 && v.[0] = 'D' && v.[1] = ':'
1809 then
1810 let b = Buffer.create 10 in
1811 Printf.bprintf b "%s\t" c;
1812 let sub p l c =
1814 Buffer.add_substring b v p l;
1815 Buffer.add_char b c;
1816 with exn -> Buffer.add_string b @@ exntos exn
1818 sub 2 4 '/';
1819 sub 6 2 '/';
1820 sub 8 2 ' ';
1821 sub 10 2 ':';
1822 sub 12 2 ':';
1823 sub 14 2 ' ';
1824 Buffer.add_char b '[';
1825 Buffer.add_string b v;
1826 Buffer.add_char b ']';
1827 Buffer.contents b
1828 else args
1830 else args
1831 else args
1833 state.docinfo <- (1, s) :: state.docinfo
1835 | "infoend", "" ->
1836 state.docinfo <- List.rev state.docinfo;
1837 state.uioh#infochanged Docinfo
1839 | "pass", args ->
1840 if args = "fail"
1841 then Wsi.settitle "Wrong password";
1842 let password = getpassword () in
1843 if emptystr password
1844 then error "document is password protected"
1845 else opendoc state.path password
1847 | _ ->
1848 error "unknown cmd `%S'" cmds
1851 let onhist cb =
1852 let rc = cb.rc in
1853 let action = function
1854 | HCprev -> cbget cb ~-1
1855 | HCnext -> cbget cb 1
1856 | HCfirst -> cbget cb ~-(cb.rc)
1857 | HClast -> cbget cb (cb.len - 1 - cb.rc)
1858 and cancel () = cb.rc <- rc
1859 in (action, cancel)
1862 let search pattern forward =
1863 match conf.columns with
1864 | Csplit _ -> impmsg "searching does not work properly in split columns mode"
1865 | Csingle _ | Cmulti _ ->
1866 if nonemptystr pattern
1867 then
1868 let pn, py =
1869 match state.layout with
1870 | [] -> 0, 0
1871 | l :: _ ->
1872 l.pageno, (l.pagey + if forward then 0 else 0*l.pagevh)
1874 wcmd "search %d %d %d %d,%s\000"
1875 (btod conf.icase) pn py (btod forward) pattern;
1878 let [@warning "-4"] intentry text key =
1879 let text =
1880 if emptystr text && key = Keys.Ascii '-'
1881 then addchar text '-'
1882 else
1883 match key with
1884 | Keys.Ascii ('0'..'9' as c) -> addchar text c
1885 | _ ->
1886 state.text <- "invalid key";
1887 text
1889 TEcont text
1892 let linknact f s =
1893 if nonemptystr s
1894 then (
1895 let n =
1896 let l = String.length s in
1897 let rec loop pos n =
1898 if pos = l
1899 then n
1900 else
1901 let m = Char.code s.[pos] - (if pos = 0 && l > 1 then 96 else 97) in
1902 loop (pos+1) (n*26 + m)
1903 in loop 0 0
1905 let rec loop n = function
1906 | [] -> ()
1907 | l :: rest ->
1908 match getopaque l.pageno with
1909 | None -> loop n rest
1910 | Some opaque ->
1911 let m = getlinkcount opaque in
1912 if n < m
1913 then (
1914 let under = getlink opaque n in
1915 f under
1917 else loop (n-m) rest
1919 loop n state.layout;
1923 let [@warning "-4"] linknentry text = function
1924 | Keys.Ascii c ->
1925 let text = addchar text c in
1926 linknact (fun under -> state.text <- undertext under) text;
1927 TEcont text
1928 | _ ->
1929 state.text <- Printf.sprintf "invalid key";
1930 TEcont text
1933 let [@warning "-4"] textentry text = function
1934 | Keys.Ascii c -> TEcont (addchar text c)
1935 | Keys.Code c -> TEcont (text ^ toutf8 c)
1936 | _ -> TEcont text
1939 let reqlayout angle fitmodel =
1940 match state.throttle with
1941 | None ->
1942 if nogeomcmds state.geomcmds
1943 then state.anchor <- getanchor ();
1944 conf.angle <- angle mod 360;
1945 if conf.angle != 0
1946 then (
1947 match state.mode with
1948 | LinkNav _ -> state.mode <- View
1949 | Birdseye _ | Textentry _ | View -> ()
1951 conf.fitmodel <- fitmodel;
1952 invalidate
1953 "reqlayout"
1954 (fun () ->
1955 wcmd "reqlayout %d %d %d"
1956 conf.angle (FMTE.to_int conf.fitmodel) (stateh state.winh)
1958 | _ -> ()
1961 let settrim trimmargins trimfuzz =
1962 if nogeomcmds state.geomcmds
1963 then state.anchor <- getanchor ();
1964 conf.trimmargins <- trimmargins;
1965 conf.trimfuzz <- trimfuzz;
1966 let x0, y0, x1, y1 = trimfuzz in
1967 invalidate
1968 "settrim" (fun () ->
1969 wcmd "settrim %d %d %d %d %d" (btod conf.trimmargins) x0 y0 x1 y1);
1970 flushpages ();
1973 let setzoom zoom =
1974 match state.throttle with
1975 | None ->
1976 let zoom = max 0.0001 zoom in
1977 if zoom <> conf.zoom
1978 then (
1979 state.prevzoom <- (conf.zoom, state.x);
1980 conf.zoom <- zoom;
1981 reshape state.winw state.winh;
1982 state.text <- Printf.sprintf "zoom is now %-5.2f" (zoom *. 100.0);
1985 | Some (layout, y, started) ->
1986 let time =
1987 match conf.maxwait with
1988 | None -> 0.0
1989 | Some t -> t
1991 let dt = now () -. started in
1992 if dt > time
1993 then (
1994 state.y <- y;
1995 load layout;
1999 let pivotzoom ?(vw=min state.w state.winw)
2000 ?(vh=min (state.maxy-state.y) state.winh)
2001 ?(x=vw/2) ?(y=vh/2) zoom =
2002 let w = float state.w /. zoom in
2003 let hw = w /. 2.0 in
2004 let ratio = float vh /. float vw in
2005 let hh = hw *. ratio in
2006 let x0 = float x -. hw
2007 and y0 = float y -. hh in
2008 gotoxy (state.x - truncate x0) (state.y + truncate y0);
2009 setzoom zoom;
2012 let pivotzoom ?vw ?vh ?x ?y zoom =
2013 if nogeomcmds state.geomcmds
2014 then
2015 if zoom > 1.0
2016 then pivotzoom ?vw ?vh ?x ?y zoom
2017 else setzoom zoom
2020 let setcolumns mode columns coverA coverB =
2021 state.prevcolumns <- Some (conf.columns, conf.zoom);
2022 if columns < 0
2023 then (
2024 if isbirdseye mode
2025 then impmsg "split mode doesn't work in bird's eye"
2026 else (
2027 conf.columns <- Csplit (-columns, E.a);
2028 state.x <- 0;
2029 conf.zoom <- 1.0;
2032 else (
2033 if columns < 2
2034 then (
2035 conf.columns <- Csingle E.a;
2036 state.x <- 0;
2037 setzoom 1.0;
2039 else (
2040 conf.columns <- Cmulti ((columns, coverA, coverB), E.a);
2041 conf.zoom <- 1.0;
2044 reshape state.winw state.winh;
2047 let resetmstate () =
2048 state.mstate <- Mnone;
2049 Wsi.setcursor Wsi.CURSOR_INHERIT;
2052 let enterbirdseye () =
2053 let zoom = float conf.thumbw /. float state.winw in
2054 let birdseyepageno =
2055 let cy = state.winh / 2 in
2056 let fold = function
2057 | [] -> 0
2058 | l :: rest ->
2059 let rec fold best = function
2060 | [] -> best.pageno
2061 | l :: rest ->
2062 let d = cy - (l.pagedispy + l.pagevh/2)
2063 and dbest = cy - (best.pagedispy + best.pagevh/2) in
2064 if abs d < abs dbest
2065 then fold l rest
2066 else best.pageno
2067 in fold l rest
2069 fold state.layout
2071 state.mode <-
2072 Birdseye (
2073 { conf with zoom = conf.zoom },
2074 state.x, birdseyepageno, -1, getanchor ()
2076 resetmstate ();
2077 conf.zoom <- zoom;
2078 conf.presentation <- false;
2079 conf.interpagespace <- 10;
2080 conf.hlinks <- false;
2081 conf.fitmodel <- FitPage;
2082 state.x <- 0;
2083 conf.maxwait <- None;
2084 conf.columns <- (
2085 match conf.beyecolumns with
2086 | Some c ->
2087 conf.zoom <- 1.0;
2088 Cmulti ((c, 0, 0), E.a)
2089 | None -> Csingle E.a
2091 if conf.verbose
2092 then
2093 state.text <- Printf.sprintf "birds eye mode on (zoom %3.1f%%)"
2094 (100.0*.zoom)
2095 else
2096 state.text <- E.s
2098 reshape state.winw state.winh;
2101 let leavebirdseye (c, leftx, pageno, _, anchor) goback =
2102 state.mode <- View;
2103 conf.zoom <- c.zoom;
2104 conf.presentation <- c.presentation;
2105 conf.interpagespace <- c.interpagespace;
2106 conf.maxwait <- c.maxwait;
2107 conf.hlinks <- c.hlinks;
2108 conf.fitmodel <- c.fitmodel;
2109 conf.beyecolumns <- (
2110 match conf.columns with
2111 | Cmulti ((c, _, _), _) -> Some c
2112 | Csingle _ -> None
2113 | Csplit _ -> failwith "leaving bird's eye split mode"
2115 conf.columns <- (
2116 match c.columns with
2117 | Cmulti (c, _) -> Cmulti (c, E.a)
2118 | Csingle _ -> Csingle E.a
2119 | Csplit (c, _) -> Csplit (c, E.a)
2121 if conf.verbose
2122 then
2123 state.text <- Printf.sprintf "birds eye mode off (zoom %3.1f%%)"
2124 (100.0*.conf.zoom)
2126 reshape state.winw state.winh;
2127 state.anchor <- if goback then anchor else (pageno, 0.0, 1.0);
2128 state.x <- leftx;
2131 let togglebirdseye () =
2132 match state.mode with
2133 | Birdseye vals -> leavebirdseye vals true
2134 | View -> enterbirdseye ()
2135 | Textentry _ | LinkNav _ -> ()
2138 let upbirdseye incr (conf, leftx, pageno, hooverpageno, anchor) =
2139 let pageno = max 0 (pageno - incr) in
2140 let rec loop = function
2141 | [] -> gotopage1 pageno 0
2142 | l :: _ when l.pageno = pageno ->
2143 if l.pagedispy >= 0 && l.pagey = 0
2144 then G.postRedisplay "upbirdseye"
2145 else gotopage1 pageno 0
2146 | _ :: rest -> loop rest
2148 loop state.layout;
2149 state.text <- E.s;
2150 state.mode <- Birdseye (conf, leftx, pageno, hooverpageno, anchor)
2153 let downbirdseye incr (conf, leftx, pageno, hooverpageno, anchor) =
2154 let pageno = min (state.pagecount - 1) (pageno + incr) in
2155 state.mode <- Birdseye (conf, leftx, pageno, hooverpageno, anchor);
2156 let rec loop = function
2157 | [] ->
2158 let y, h = getpageyh pageno in
2159 let dy = (y - state.y) - (state.winh - h - conf.interpagespace) in
2160 gotoxy state.x (clamp dy)
2161 | l :: _ when l.pageno = pageno ->
2162 if l.pagevh != l.pageh
2163 then gotoxy state.x (clamp (l.pageh - l.pagevh + conf.interpagespace))
2164 else G.postRedisplay "downbirdseye"
2165 | _ :: rest -> loop rest
2167 loop state.layout;
2168 state.text <- E.s;
2171 let [@warning "-4"] optentry mode _ key =
2172 let btos b = if b then "on" else "off" in
2173 match key with
2174 | Keys.Ascii 's' ->
2175 let ondone s =
2176 try conf.scrollstep <- int_of_string s with exn ->
2177 state.text <- Printf.sprintf "bad integer `%s': %s" s @@ exntos exn
2179 TEswitch ("scroll step: ", E.s, None, intentry, ondone, true)
2181 | Keys.Ascii 'A' ->
2182 let ondone s =
2184 conf.autoscrollstep <- boundastep state.winh (int_of_string s);
2185 if state.autoscroll <> None
2186 then state.autoscroll <- Some conf.autoscrollstep
2187 with exn ->
2188 state.text <- Printf.sprintf "bad integer `%s': %s" s @@ exntos exn
2190 TEswitch ("auto scroll step: ", E.s, None, intentry, ondone, true)
2192 | Keys.Ascii 'C' ->
2193 let ondone s =
2195 let n, a, b = multicolumns_of_string s in
2196 setcolumns mode n a b;
2197 with exn ->
2198 state.text <- Printf.sprintf "bad columns `%s': %s" s @@ exntos exn
2200 TEswitch ("columns: ", E.s, None, textentry, ondone, true)
2202 | Keys.Ascii 'Z' ->
2203 let ondone s =
2205 let zoom = float (int_of_string s) /. 100.0 in
2206 pivotzoom zoom
2207 with exn ->
2208 state.text <- Printf.sprintf "bad integer `%s': %s" s @@ exntos exn
2210 TEswitch ("zoom: ", E.s, None, intentry, ondone, true)
2212 | Keys.Ascii 't' ->
2213 let ondone s =
2215 conf.thumbw <- bound (int_of_string s) 2 4096;
2216 state.text <-
2217 Printf.sprintf "thumbnail width is set to %d" conf.thumbw;
2218 begin match mode with
2219 | Birdseye beye ->
2220 leavebirdseye beye false;
2221 enterbirdseye ();
2222 | Textentry _ | View | LinkNav _ -> ();
2224 with exn ->
2225 state.text <- Printf.sprintf "bad integer `%s': %s" s @@ exntos exn
2227 TEswitch ("thumbnail width: ", E.s, None, intentry, ondone, true)
2229 | Keys.Ascii 'R' ->
2230 let ondone s =
2231 match int_of_string s with
2232 | angle -> reqlayout angle conf.fitmodel
2233 | exception exn ->
2234 state.text <- Printf.sprintf "bad integer `%s': %s" s @@ exntos exn
2236 TEswitch ("rotation: ", E.s, None, intentry, ondone, true)
2238 | Keys.Ascii 'i' ->
2239 conf.icase <- not conf.icase;
2240 TEdone ("case insensitive search " ^ (btos conf.icase))
2242 | Keys.Ascii 'p' ->
2243 conf.preload <- not conf.preload;
2244 gotoxy state.x state.y;
2245 TEdone ("preload " ^ (btos conf.preload))
2247 | Keys.Ascii 'v' ->
2248 conf.verbose <- not conf.verbose;
2249 TEdone ("verbose " ^ (btos conf.verbose))
2251 | Keys.Ascii 'd' ->
2252 conf.debug <- not conf.debug;
2253 TEdone ("debug " ^ (btos conf.debug))
2255 | Keys.Ascii 'h' ->
2256 conf.maxhfit <- not conf.maxhfit;
2257 state.maxy <- calcheight ();
2258 TEdone ("maxhfit " ^ (btos conf.maxhfit))
2260 | Keys.Ascii 'c' ->
2261 conf.crophack <- not conf.crophack;
2262 TEdone ("crophack " ^ btos conf.crophack)
2264 | Keys.Ascii 'a' ->
2265 let s =
2266 match conf.maxwait with
2267 | None ->
2268 conf.maxwait <- Some infinity;
2269 "always wait for page to complete"
2270 | Some _ ->
2271 conf.maxwait <- None;
2272 "show placeholder if page is not ready"
2274 TEdone s
2276 | Keys.Ascii 'f' ->
2277 conf.underinfo <- not conf.underinfo;
2278 TEdone ("underinfo " ^ btos conf.underinfo)
2280 | Keys.Ascii 'P' ->
2281 conf.savebmarks <- not conf.savebmarks;
2282 TEdone ("persistent bookmarks " ^ btos conf.savebmarks)
2284 | Keys.Ascii 'S' ->
2285 let ondone s =
2287 let pageno, py =
2288 match state.layout with
2289 | [] -> 0, 0
2290 | l :: _ ->
2291 l.pageno, l.pagey
2293 conf.interpagespace <- int_of_string s;
2294 docolumns conf.columns;
2295 state.maxy <- calcheight ();
2296 let y = getpagey pageno in
2297 gotoxy state.x (y + py)
2298 with exn ->
2299 state.text <- Printf.sprintf "bad integer `%s': %s" s @@ exntos exn
2301 TEswitch ("vertical margin: ", E.s, None, intentry, ondone, true)
2303 | Keys.Ascii 'l' ->
2304 let fm =
2305 match conf.fitmodel with
2306 | FitProportional -> FitWidth
2307 | FitWidth | FitPage -> FitProportional
2309 reqlayout conf.angle fm;
2310 TEdone ("proportional display " ^ btos (fm == FitProportional))
2312 | Keys.Ascii 'T' ->
2313 settrim (not conf.trimmargins) conf.trimfuzz;
2314 TEdone ("trim margins " ^ btos conf.trimmargins)
2316 | Keys.Ascii 'I' ->
2317 conf.invert <- not conf.invert;
2318 TEdone ("invert colors " ^ btos conf.invert)
2320 | Keys.Ascii 'x' ->
2321 let ondone s =
2322 cbput state.hists.sel s;
2323 conf.selcmd <- s;
2325 TEswitch ("selection command: ", E.s, Some (onhist state.hists.sel),
2326 textentry, ondone, true)
2328 | Keys.Ascii 'M' ->
2329 if conf.pax == None
2330 then conf.pax <- Some 0.0
2331 else conf.pax <- None;
2332 TEdone ("PAX " ^ btos (conf.pax != None))
2334 | (Keys.Ascii c) ->
2335 state.text <- Printf.sprintf "bad option %d `%c'"
2336 (Char.code c) c;
2337 TEstop
2339 | _ ->
2340 TEcont state.text
2343 class type lvsource =
2344 object
2345 method getitemcount : int
2346 method getitem : int -> (string * int)
2347 method hasaction : int -> bool
2348 method exit : uioh:uioh ->
2349 cancel:bool ->
2350 active:int ->
2351 first:int ->
2352 pan:int ->
2353 uioh option
2354 method getactive : int
2355 method getfirst : int
2356 method getpan : int
2357 method getminfo : (int * int) array
2358 end;;
2360 class virtual lvsourcebase = object
2361 val mutable m_active = 0
2362 val mutable m_first = 0
2363 val mutable m_pan = 0
2364 method getactive = m_active
2365 method getfirst = m_first
2366 method getpan = m_pan
2367 method getminfo : (int * int) array = E.a
2368 end;;
2370 let [@warning "-4"]
2371 textentrykeyboard
2372 key _mask ((c, text, opthist, onkey, ondone, cancelonempty), onleave) =
2373 state.text <- E.s;
2374 let enttext te =
2375 state.mode <- Textentry (te, onleave);
2376 enttext ();
2377 G.postRedisplay "textentrykeyboard enttext";
2379 let histaction cmd =
2380 match opthist with
2381 | None -> ()
2382 | Some (action, _) ->
2383 state.mode <-
2384 Textentry (
2385 (c, action cmd, opthist, onkey, ondone, cancelonempty), onleave
2387 G.postRedisplay "textentry histaction"
2389 let open Keys in
2390 let kt = Wsi.kc2kt key in
2391 match kt with
2392 | Backspace ->
2393 if emptystr text && cancelonempty
2394 then (
2395 onleave Cancel;
2396 G.postRedisplay "textentrykeyboard after cancel";
2398 else
2399 let s = withoutlastutf8 text in
2400 enttext (c, s, opthist, onkey, ondone, cancelonempty)
2402 | Enter ->
2403 ondone text;
2404 onleave Confirm;
2405 G.postRedisplay "textentrykeyboard after confirm"
2407 | Up -> histaction HCprev
2408 | Down -> histaction HCnext
2409 | Home -> histaction HCfirst
2410 | End -> histaction HClast
2412 | Escape ->
2413 if emptystr text
2414 then (
2415 begin match opthist with
2416 | None -> ()
2417 | Some (_, onhistcancel) -> onhistcancel ()
2418 end;
2419 onleave Cancel;
2420 state.text <- E.s;
2421 G.postRedisplay "textentrykeyboard after cancel2"
2423 else (
2424 enttext (c, E.s, opthist, onkey, ondone, cancelonempty)
2427 | Delete -> ()
2429 | Code _ | Ascii _ ->
2430 begin match onkey text kt with
2431 | TEdone text ->
2432 ondone text;
2433 onleave Confirm;
2434 G.postRedisplay "textentrykeyboard after confirm2";
2436 | TEcont text ->
2437 enttext (c, text, opthist, onkey, ondone, cancelonempty);
2439 | TEstop ->
2440 onleave Cancel;
2441 G.postRedisplay "textentrykeyboard after cancel3"
2443 | TEswitch te ->
2444 state.mode <- Textentry (te, onleave);
2445 G.postRedisplay "textentrykeyboard switch";
2447 | _ -> vlog "unhandled key"
2450 let firstof first active =
2451 if first > active || abs (first - active) > fstate.maxrows - 1
2452 then max 0 (active - (fstate.maxrows/2))
2453 else first
2456 let calcfirst first active =
2457 if active > first
2458 then
2459 let rows = active - first in
2460 if rows > fstate.maxrows then active - fstate.maxrows else first
2461 else active
2464 let scrollph y maxy =
2465 let sh = float (maxy + state.winh) /. float state.winh in
2466 let sh = float state.winh /. sh in
2467 let sh = max sh (float conf.scrollh) in
2469 let percent = float y /. float maxy in
2470 let position = (float state.winh -. sh) *. percent in
2472 let position =
2473 if position +. sh > float state.winh
2474 then float state.winh -. sh
2475 else position
2477 position, sh;
2480 let adderrmsg src msg =
2481 Buffer.add_string state.errmsgs msg;
2482 state.newerrmsgs <- true;
2483 G.postRedisplay src
2486 let adderrfmt src fmt =
2487 Format.ksprintf (fun s -> adderrmsg src s) fmt;
2490 let coe s = (s :> uioh);;
2492 class listview ~zebra ~helpmode ~(source:lvsource) ~trusted ~modehash =
2493 object (self)
2494 val m_pan = source#getpan
2495 val m_first = source#getfirst
2496 val m_active = source#getactive
2497 val m_qsearch = E.s
2498 val m_prev_uioh = state.uioh
2500 method private elemunder y =
2501 if y < 0
2502 then None
2503 else
2504 let n = y / (fstate.fontsize+1) in
2505 if m_first + n < source#getitemcount
2506 then (
2507 if source#hasaction (m_first + n)
2508 then Some (m_first + n)
2509 else None
2511 else None
2513 method display =
2514 Gl.enable `blend;
2515 GlFunc.blend_func ~src:`src_alpha ~dst:`one_minus_src_alpha;
2516 GlDraw.color (0., 0., 0.) ~alpha:0.85;
2517 filledrect 0. 0. (float state.winw) (float state.winh);
2518 GlDraw.color (1., 1., 1.);
2519 Gl.enable `texture_2d;
2520 let fs = fstate.fontsize in
2521 let nfs = fs + 1 in
2522 let hw = state.winw/3 in
2523 let ww = fstate.wwidth in
2524 let tabw = 17.0*.ww in
2525 let itemcount = source#getitemcount in
2526 let minfo = source#getminfo in
2527 if conf.leftscroll
2528 then (
2529 GlMat.push ();
2530 GlMat.translate ~x:(float conf.scrollbw) ();
2532 let x0 = 0.0 and x1 = float (state.winw - conf.scrollbw - 1) in
2533 let rec loop row =
2534 if (row - m_first) > fstate.maxrows
2535 then ()
2536 else (
2537 if row >= 0 && row < itemcount
2538 then (
2539 let (s, level) = source#getitem row in
2540 let y = (row - m_first) * nfs in
2541 let x = 5.0 +. (float (level + m_pan)) *. ww in
2542 if helpmode
2543 then GlDraw.color
2544 (let c = if row land 1 = 0 then 1.0 else 0.92 in (c,c,c));
2546 if row = m_active
2547 then (
2548 Gl.disable `texture_2d;
2549 let alpha = if source#hasaction row then 0.9 else 0.3 in
2550 GlDraw.color (1., 1., 1.) ~alpha;
2551 linerect (x0 +. 1.) (float (y + 1)) (x1) (float (y + fs + 3));
2552 Gl.enable `texture_2d;
2554 let c =
2555 if zebra && row land 1 = 1
2556 then 0.8
2557 else 1.0
2559 GlDraw.color (c,c,c);
2560 let drawtabularstring s =
2561 let drawstr x s =
2562 let x' = truncate (x0 +. x) in
2563 let s1, s2 = splitatchar s '\000' in
2564 if emptystr s2
2565 then drawstring1 fs x' (y+nfs) s
2566 else
2567 let rec e s =
2568 if emptystr s
2569 then s
2570 else
2571 let s' = withoutlastutf8 s in
2572 let s = s' ^ UniSyms.ellipsis in
2573 let w = measurestr fs s in
2574 if float x' +. w +. ww < float (hw + x')
2575 then s
2576 else e s'
2578 let s1 =
2579 if float x' +. ww +. measurestr fs s1 > float (hw + x')
2580 then e s1
2581 else s1
2583 ignore (drawstring1 fs x' (y+nfs) s1);
2584 drawstring1 fs (hw + x') (y+nfs) s2
2586 if trusted
2587 then
2588 let x = if helpmode && row > 0 then x +. ww else x in
2589 let s1, s2 = splitatchar s '\t' in
2590 if nonemptystr s2
2591 then
2592 let nx = drawstr x s1 in
2593 let sw = nx -. x in
2594 let x = x +. (max tabw sw) in
2595 drawstr x s2
2596 else
2597 let len = String.length s - 2 in
2598 if len > 0 && s.[0] = '\xc2' && s.[1] = '\xb7'
2599 then
2600 let s = String.sub s 2 len in
2601 let x = if not helpmode then x +. ww else x in
2602 GlDraw.color (1.2, 1.2, 1.2);
2603 let vinc = drawstring1 (fs+fs/4)
2604 (truncate (x -. ww)) (y+nfs) s in
2605 GlDraw.color (1., 1., 1.);
2606 vinc +. (float fs *. 0.8)
2607 else
2608 drawstr x s
2609 else
2610 drawstr x s
2612 ignore (drawtabularstring s);
2613 loop (row+1)
2617 loop m_first;
2618 GlDraw.color (1.0, 1.0, 1.0) ~alpha:0.5;
2619 let xadj = 5.0 in
2620 let rec loop row =
2621 if (row - m_first) <= fstate.maxrows
2622 then
2623 if row >= 0 && row < itemcount
2624 then (
2625 let (s, level) = source#getitem row in
2626 let pos0 = nindex s '\000' in
2627 let y = (row - m_first) * nfs in
2628 let x = float (level + m_pan) *. ww in
2629 let (first, last) = minfo.(row) in
2630 let prefix =
2631 if pos0 > 0 && first > pos0
2632 then String.sub s (pos0+1) (first-pos0-1)
2633 else String.sub s 0 first
2635 let suffix = String.sub s first (last - first) in
2636 let w1 = measurestr fstate.fontsize prefix in
2637 let w2 = measurestr fstate.fontsize suffix in
2638 let x = x +. if conf.leftscroll then xadj else 5.0 in
2639 let x = if pos0 > 0 && first > pos0 then x +. float hw else x in
2640 let x0 = x +. w1
2641 and y0 = float (y+2) in
2642 let x1 = x0 +. w2
2643 and y1 = float (y+fs+3) in
2644 filledrect x0 y0 x1 y1;
2645 loop (row+1)
2648 Gl.disable `texture_2d;
2649 if Array.length minfo > 0 then loop m_first;
2650 Gl.disable `blend;
2651 if conf.leftscroll
2652 then GlMat.pop ()
2654 method updownlevel incr =
2655 let len = source#getitemcount in
2656 let curlevel =
2657 if m_active >= 0 && m_active < len
2658 then snd (source#getitem m_active)
2659 else -1
2661 let rec flow i =
2662 if i = len then i-1 else if i = -1 then 0 else
2663 let _, l = source#getitem i in
2664 if l != curlevel then i else flow (i+incr)
2666 let active = flow m_active in
2667 let first = calcfirst m_first active in
2668 G.postRedisplay "outline updownlevel";
2669 {< m_active = active; m_first = first >}
2671 method private key1 key mask =
2672 let set1 active first qsearch =
2673 coe {< m_active = active; m_first = first; m_qsearch = qsearch >}
2675 let search active pattern incr =
2676 let active = if active = -1 then m_first else active in
2677 let dosearch re =
2678 let rec loop n =
2679 if n >= 0 && n < source#getitemcount
2680 then (
2681 let s, _ = source#getitem n in
2682 match Str.search_forward re s 0 with
2683 | exception Not_found -> loop (n + incr)
2684 | _ -> Some n
2686 else None
2688 loop active
2690 let qpat = Str.quote pattern in
2691 match Str.regexp_case_fold qpat with
2692 | s -> dosearch s
2693 | exception exn ->
2694 adderrfmt "listview key1" "regexp_case_fold for `%S' failed: %S\n"
2695 qpat @@ Printexc.to_string exn;
2696 None
2698 let itemcount = source#getitemcount in
2699 let find start incr =
2700 let rec find i =
2701 if i = -1 || i = itemcount
2702 then -1
2703 else (
2704 if source#hasaction i
2705 then i
2706 else find (i + incr)
2709 find start
2711 let set active first =
2712 let first = bound first 0 (itemcount - fstate.maxrows) in
2713 state.text <- E.s;
2714 coe {< m_active = active; m_first = first; m_qsearch = E.s >}
2716 let navigate incr =
2717 let isvisible first n = n >= first && n - first <= fstate.maxrows in
2718 let active, first =
2719 let incr1 = if incr > 0 then 1 else -1 in
2720 if isvisible m_first m_active
2721 then
2722 let next =
2723 let next = m_active + incr in
2724 let next =
2725 if next < 0 || next >= itemcount
2726 then -1
2727 else find next incr1
2729 if abs (m_active - next) > fstate.maxrows
2730 then -1
2731 else next
2733 if next = -1
2734 then
2735 let first = m_first + incr in
2736 let first = bound first 0 (itemcount - fstate.maxrows) in
2737 let next =
2738 let next = m_active + incr in
2739 let next = bound next 0 (itemcount - 1) in
2740 find next ~-incr1
2742 let active =
2743 if next = -1
2744 then m_active
2745 else (
2746 if isvisible first next
2747 then next
2748 else m_active
2751 active, first
2752 else
2753 let first = min next m_first in
2754 let first =
2755 if abs (next - first) > fstate.maxrows
2756 then first + incr
2757 else first
2759 next, first
2760 else
2761 let first = m_first + incr in
2762 let first = bound first 0 (itemcount - 1) in
2763 let active =
2764 let next = m_active + incr in
2765 let next = bound next 0 (itemcount - 1) in
2766 let next = find next incr1 in
2767 let active =
2768 if next = -1 || abs (m_active - first) > fstate.maxrows
2769 then (
2770 let active = if m_active = -1 then next else m_active in
2771 active
2773 else next
2775 if isvisible first active
2776 then active
2777 else -1
2779 active, first
2781 G.postRedisplay "listview navigate";
2782 set active first;
2784 let open Keys in
2785 let kt = Wsi.kc2kt key in
2786 match [@warning "-4"] kt with
2787 | Ascii (('r'|'s') as c) when Wsi.withctrl mask ->
2788 let incr = if c = 'r' then -1 else 1 in
2789 let active, first =
2790 match search (m_active + incr) m_qsearch incr with
2791 | None ->
2792 state.text <- m_qsearch ^ " [not found]";
2793 m_active, m_first
2794 | Some active ->
2795 state.text <- m_qsearch;
2796 active, firstof m_first active
2798 G.postRedisplay "listview ctrl-r/s";
2799 set1 active first m_qsearch;
2801 | Insert when Wsi.withctrl mask ->
2802 if m_active >= 0 && m_active < source#getitemcount
2803 then (
2804 let s, _ = source#getitem m_active in
2805 selstring s;
2807 coe self
2809 | Backspace ->
2810 if emptystr m_qsearch
2811 then coe self
2812 else (
2813 let qsearch = withoutlastutf8 m_qsearch in
2814 if emptystr qsearch
2815 then (
2816 state.text <- E.s;
2817 G.postRedisplay "listview empty qsearch";
2818 set1 m_active m_first E.s;
2820 else
2821 let active, first =
2822 match search m_active qsearch ~-1 with
2823 | None ->
2824 state.text <- qsearch ^ " [not found]";
2825 m_active, m_first
2826 | Some active ->
2827 state.text <- qsearch;
2828 active, firstof m_first active
2830 G.postRedisplay "listview backspace qsearch";
2831 set1 active first qsearch
2834 | Ascii _ | Code _ ->
2835 let utf8 =
2836 match [@warning "-8"] kt with
2837 | Ascii c -> String.make 1 c
2838 | Code code -> toutf8 code
2840 let pattern = m_qsearch ^ utf8 in
2841 let active, first =
2842 match search m_active pattern 1 with
2843 | None ->
2844 state.text <- pattern ^ " [not found]";
2845 m_active, m_first
2846 | Some active ->
2847 state.text <- pattern;
2848 active, firstof m_first active
2850 G.postRedisplay "listview qsearch add";
2851 set1 active first pattern;
2853 | Escape ->
2854 state.text <- E.s;
2855 if emptystr m_qsearch
2856 then (
2857 G.postRedisplay "list view escape";
2858 let mx, my = state.mpos in
2859 updateunder mx my;
2860 match source#exit ~uioh:(coe self) ~cancel:true ~active:m_active
2861 ~first:m_first ~pan:m_pan with
2862 | None -> m_prev_uioh
2863 | Some uioh -> uioh
2865 else (
2866 G.postRedisplay "list view kill qsearch";
2867 coe {< m_qsearch = E.s >}
2870 | Enter ->
2871 state.text <- E.s;
2872 let self = {< m_qsearch = E.s >} in
2873 let opt =
2874 G.postRedisplay "listview enter";
2875 let cancel = not (m_active >= 0 && m_active < source#getitemcount) in
2876 source#exit ~uioh:(coe self) ~cancel
2877 ~active:m_active ~first:m_first ~pan:m_pan;
2879 begin match opt with
2880 | None -> m_prev_uioh
2881 | Some uioh -> uioh
2884 | Delete ->
2885 coe self
2887 | Up -> navigate ~-1
2888 | Down -> navigate 1
2889 | Prior -> navigate ~-(fstate.maxrows)
2890 | Next -> navigate fstate.maxrows
2892 | Right ->
2893 state.text <- E.s;
2894 G.postRedisplay "listview right";
2895 coe {< m_pan = m_pan - 1 >}
2897 | Left ->
2898 state.text <- E.s;
2899 G.postRedisplay "listview left";
2900 coe {< m_pan = m_pan + 1 >}
2902 | Home ->
2903 let active = find 0 1 in
2904 G.postRedisplay "listview home";
2905 set active 0;
2907 | End ->
2908 let first = max 0 (itemcount - fstate.maxrows) in
2909 let active = find (itemcount - 1) ~-1 in
2910 G.postRedisplay "listview end";
2911 set active first;
2913 | _ -> coe self
2915 method key key mask =
2916 match state.mode with
2917 | Textentry te ->
2918 textentrykeyboard key mask te;
2919 coe self
2920 | Birdseye _ | View | LinkNav _ -> self#key1 key mask
2922 method button button down x y _ =
2923 let opt =
2924 match button with
2925 | 1 when vscrollhit x ->
2926 G.postRedisplay "listview scroll";
2927 if down
2928 then
2929 let _, position, sh = self#scrollph in
2930 if y > truncate position && y < truncate (position +. sh)
2931 then (
2932 state.mstate <- Mscrolly;
2933 Some (coe self)
2935 else
2936 let s = float (max 0 (y - conf.scrollh)) /. float state.winh in
2937 let first = truncate (s *. float source#getitemcount) in
2938 let first = min source#getitemcount first in
2939 Some (coe {< m_first = first; m_active = first >})
2940 else (
2941 state.mstate <- Mnone;
2942 Some (coe self);
2944 | 1 when down ->
2945 begin match self#elemunder y with
2946 | Some n ->
2947 G.postRedisplay "listview click";
2948 source#exit ~uioh:(coe {< m_active = n >})
2949 ~cancel:false ~active:n ~first:m_first ~pan:m_pan
2950 | _ ->
2951 Some (coe self)
2953 | n when (n == 4 || n == 5) && not down ->
2954 let len = source#getitemcount in
2955 let first =
2956 if n = 5 && m_first + fstate.maxrows >= len
2957 then
2958 m_first
2959 else
2960 let first = m_first + (if n == 4 then -1 else 1) in
2961 bound first 0 (len - 1)
2963 G.postRedisplay "listview wheel";
2964 Some (coe {< m_first = first >})
2965 | n when (n = 6 || n = 7) && not down ->
2966 let inc = if n = 7 then -1 else 1 in
2967 G.postRedisplay "listview hwheel";
2968 Some (coe {< m_pan = m_pan + inc >})
2969 | _ ->
2970 Some (coe self)
2972 match opt with
2973 | None -> m_prev_uioh
2974 | Some uioh -> uioh
2976 method multiclick _ x y = self#button 1 true x y
2978 method motion _ y =
2979 match state.mstate with
2980 | Mscrolly ->
2981 let s = float (max 0 (y - conf.scrollh)) /. float state.winh in
2982 let first = truncate (s *. float source#getitemcount) in
2983 let first = min source#getitemcount first in
2984 G.postRedisplay "listview motion";
2985 coe {< m_first = first; m_active = first >}
2986 | Msel _
2987 | Mpan _
2988 | Mscrollx
2989 | Mzoom _
2990 | Mzoomrect _
2991 | Mnone -> coe self
2993 method pmotion x y =
2994 if x < state.winw - conf.scrollbw
2995 then
2996 let n =
2997 match self#elemunder y with
2998 | None -> Wsi.setcursor Wsi.CURSOR_INHERIT; m_active
2999 | Some n -> Wsi.setcursor Wsi.CURSOR_INFO; n
3001 let o =
3002 if n != m_active
3003 then (G.postRedisplay "listview pmotion"; {< m_active = n >})
3004 else self
3006 coe o
3007 else (
3008 Wsi.setcursor Wsi.CURSOR_INHERIT;
3009 coe self
3012 method infochanged _ = ()
3014 method scrollpw = (0, 0.0, 0.0)
3015 method scrollph =
3016 let nfs = fstate.fontsize + 1 in
3017 let y = m_first * nfs in
3018 let itemcount = source#getitemcount in
3019 let maxi = max 0 (itemcount - fstate.maxrows) in
3020 let maxy = maxi * nfs in
3021 let p, h = scrollph y maxy in
3022 conf.scrollbw, p, h
3024 method modehash = modehash
3025 method eformsgs = false
3026 method alwaysscrolly = true
3027 method scroll _ dy =
3028 let self =
3029 if dy != 0 then begin
3030 let len = source#getitemcount in
3031 let first =
3032 if dy > 0 && m_first + fstate.maxrows >= len
3033 then
3034 m_first
3035 else
3036 let first = m_first + dy / 10 in
3037 bound first 0 (len - 1)
3039 G.postRedisplay "listview wheel";
3040 {< m_first = first >}
3041 end else
3042 self
3044 coe self
3046 method zoom _ _ _ = ()
3047 end;;
3049 class outlinelistview ~zebra ~source =
3050 let settext autonarrow s =
3051 if autonarrow
3052 then
3053 let ss = source#statestr in
3054 state.text <-
3055 if emptystr ss
3056 then "[" ^ s ^ "]"
3057 else "{" ^ ss ^ "} [" ^ s ^ "]"
3058 else state.text <- s
3060 object (self)
3061 inherit listview
3062 ~zebra
3063 ~helpmode:false
3064 ~source:(source :> lvsource)
3065 ~trusted:false
3066 ~modehash:(findkeyhash conf "outline")
3067 as super
3069 val m_autonarrow = false
3071 method! key key mask =
3072 let maxrows =
3073 if emptystr state.text
3074 then fstate.maxrows
3075 else fstate.maxrows - 2
3077 let calcfirst first active =
3078 if active > first
3079 then
3080 let rows = active - first in
3081 if rows > maxrows then active - maxrows else first
3082 else active
3084 let navigate incr =
3085 let active = m_active + incr in
3086 let active = bound active 0 (source#getitemcount - 1) in
3087 let first = calcfirst m_first active in
3088 G.postRedisplay "outline navigate";
3089 coe {< m_active = active; m_first = first >}
3091 let navscroll first =
3092 let active =
3093 let dist = m_active - first in
3094 if dist < 0
3095 then first
3096 else (
3097 if dist < maxrows
3098 then m_active
3099 else first + maxrows
3102 G.postRedisplay "outline navscroll";
3103 coe {< m_first = first; m_active = active >}
3105 let ctrl = Wsi.withctrl mask in
3106 let open Keys in
3107 match Wsi.kc2kt key with
3108 | Ascii 'a' when ctrl ->
3109 let text =
3110 if m_autonarrow
3111 then (source#denarrow; E.s)
3112 else (
3113 let pattern = source#renarrow in
3114 if nonemptystr m_qsearch
3115 then (source#narrow m_qsearch; m_qsearch)
3116 else pattern
3119 settext (not m_autonarrow) text;
3120 G.postRedisplay "toggle auto narrowing";
3121 coe {< m_first = 0; m_active = 0; m_autonarrow = not m_autonarrow >}
3123 | Ascii '/' when emptystr m_qsearch && not m_autonarrow ->
3124 settext true E.s;
3125 G.postRedisplay "toggle auto narrowing";
3126 coe {< m_first = 0; m_active = 0; m_autonarrow = true >}
3128 | Ascii 'n' when ctrl ->
3129 source#narrow m_qsearch;
3130 if not m_autonarrow
3131 then source#add_narrow_pattern m_qsearch;
3132 G.postRedisplay "outline ctrl-n";
3133 coe {< m_first = 0; m_active = 0 >}
3135 | Ascii 'S' when ctrl ->
3136 let active = source#calcactive (getanchor ()) in
3137 let first = firstof m_first active in
3138 G.postRedisplay "outline ctrl-s";
3139 coe {< m_first = first; m_active = active >}
3141 | Ascii 'u' when ctrl ->
3142 G.postRedisplay "outline ctrl-u";
3143 if m_autonarrow && nonemptystr m_qsearch
3144 then (
3145 ignore (source#renarrow);
3146 settext m_autonarrow E.s;
3147 coe {< m_first = 0; m_active = 0; m_qsearch = E.s >}
3149 else (
3150 source#del_narrow_pattern;
3151 let pattern = source#renarrow in
3152 let text =
3153 if emptystr pattern then E.s else "Narrowed to " ^ pattern
3155 settext m_autonarrow text;
3156 coe {< m_first = 0; m_active = 0; m_qsearch = E.s >}
3159 | Ascii 'l' when ctrl ->
3160 let first = max 0 (m_active - (fstate.maxrows / 2)) in
3161 G.postRedisplay "outline ctrl-l";
3162 coe {< m_first = first >}
3164 | Ascii '\t' when m_autonarrow ->
3165 if nonemptystr m_qsearch
3166 then (
3167 G.postRedisplay "outline list view tab";
3168 source#add_narrow_pattern m_qsearch;
3169 settext true E.s;
3170 coe {< m_qsearch = E.s >}
3172 else coe self
3174 | Escape when m_autonarrow ->
3175 if nonemptystr m_qsearch
3176 then source#add_narrow_pattern m_qsearch;
3177 super#key key mask
3179 | Enter when m_autonarrow ->
3180 if nonemptystr m_qsearch
3181 then source#add_narrow_pattern m_qsearch;
3182 super#key key mask
3184 | (Ascii _ | Code _) when m_autonarrow ->
3185 let pattern = m_qsearch ^ toutf8 key in
3186 G.postRedisplay "outlinelistview autonarrow add";
3187 source#narrow pattern;
3188 settext true pattern;
3189 coe {< m_first = 0; m_active = 0; m_qsearch = pattern >}
3191 | Backspace when m_autonarrow ->
3192 if emptystr m_qsearch
3193 then coe self
3194 else
3195 let pattern = withoutlastutf8 m_qsearch in
3196 G.postRedisplay "outlinelistview autonarrow backspace";
3197 ignore (source#renarrow);
3198 source#narrow pattern;
3199 settext true pattern;
3200 coe {< m_first = 0; m_active = 0; m_qsearch = pattern >}
3202 | Up when ctrl ->
3203 navscroll (max 0 (m_first - 1))
3205 | Down when ctrl ->
3206 navscroll (min (source#getitemcount - 1) (m_first + 1))
3208 | Up -> navigate ~-1
3209 | Down -> navigate 1
3210 | Prior -> navigate ~-(fstate.maxrows)
3211 | Next -> navigate fstate.maxrows
3213 | Right ->
3214 let o =
3215 if ctrl
3216 then (
3217 G.postRedisplay "outline ctrl right";
3218 {< m_pan = m_pan + 1 >}
3220 else self#updownlevel 1
3222 coe o
3224 | Left ->
3225 let o =
3226 if ctrl
3227 then (
3228 G.postRedisplay "outline ctrl left";
3229 {< m_pan = m_pan - 1 >}
3231 else self#updownlevel ~-1
3233 coe o
3235 | Home ->
3236 G.postRedisplay "outline home";
3237 coe {< m_first = 0; m_active = 0 >}
3239 | End ->
3240 let active = source#getitemcount - 1 in
3241 let first = max 0 (active - fstate.maxrows) in
3242 G.postRedisplay "outline end";
3243 coe {< m_active = active; m_first = first >}
3245 | Delete|Escape|Insert|Enter|Ascii _|Code _|Ctrl _|Backspace|Fn _ ->
3246 super#key key mask
3247 end;;
3249 let genhistoutlines () =
3250 Config.gethist ()
3251 |> List.sort (fun (_, c1, _, _, _, _) (_, c2, _, _, _, _) ->
3252 compare c2.lastvisit c1.lastvisit)
3253 |> List.map (fun ((path, c, _, _, _, origin) as hist) ->
3254 let path = if nonemptystr origin then origin else path in
3255 let base = mbtoutf8 @@ Filename.basename path in
3256 (base ^ "\000" ^ c.title, 1, Ohistory hist)
3260 let gotohist (path, c, bookmarks, x, anchor, origin) =
3261 Config.save leavebirdseye;
3262 state.anchor <- anchor;
3263 state.bookmarks <- bookmarks;
3264 state.origin <- origin;
3265 state.x <- x;
3266 setconf conf c;
3267 let x0, y0, x1, y1 = conf.trimfuzz in
3268 wcmd "trimset %d %d %d %d %d" (btod conf.trimmargins) x0 y0 x1 y1;
3269 reshape ~firsttime:true state.winw state.winh;
3270 opendoc path origin;
3271 setzoom c.zoom;
3274 let makecheckers () =
3275 (* Based on lablGL-1.04/LablGlut/examples/lablGL/checker.ml which had
3276 following to say:
3277 converted by Issac Trotts. July 25, 2002 *)
3278 let image = GlPix.create `ubyte ~format:`luminance ~width:2 ~height:2 in
3279 Raw.sets_string (GlPix.to_raw image) ~pos:0 "\255\200\200\255";
3280 let id = GlTex.gen_texture () in
3281 GlTex.bind_texture ~target:`texture_2d id;
3282 GlPix.store (`unpack_alignment 1);
3283 GlTex.image2d image;
3284 List.iter (GlTex.parameter ~target:`texture_2d)
3285 [ `mag_filter `nearest; `min_filter `nearest ];
3289 let setcheckers enabled =
3290 match state.checkerstexid with
3291 | None ->
3292 if enabled then state.checkerstexid <- Some (makecheckers ())
3294 | Some checkerstexid ->
3295 if not enabled
3296 then (
3297 GlTex.delete_texture checkerstexid;
3298 state.checkerstexid <- None;
3302 let describe_layout layout =
3303 let d =
3304 match layout with
3305 | [] -> "Page 0"
3306 | l :: [] -> Printf.sprintf "Page %d" (l.pageno+1)
3307 | l :: rest ->
3308 let rangestr a b =
3309 if a.pageno = b.pageno then Printf.sprintf "%d" (a.pageno+1)
3310 else
3311 let sep = if a.pageno+1 = b.pageno then ", " else UniSyms.ellipsis in
3312 Printf.sprintf "%d%s%d" (a.pageno+1) sep (b.pageno+1)
3314 let rec fold s la lb = function
3315 | [] -> Printf.sprintf "%s %s" s (rangestr la lb)
3316 | l :: rest when l.pageno = succ lb.pageno -> fold s la l rest
3317 | l :: rest -> fold (s ^ " " ^ rangestr la lb ^ ",") l l rest
3319 fold "Pages" l l rest
3321 let percent =
3322 let maxy = maxy () in
3323 if maxy <= 0
3324 then 100.
3325 else 100. *. (float state.y /. float maxy)
3327 Printf.sprintf "%s of %d [%.2f%%]" d state.pagecount percent
3330 let setpresentationmode v =
3331 let n = page_of_y state.y in
3332 state.anchor <- (n, 0.0, 1.0);
3333 conf.presentation <- v;
3334 if conf.fitmodel = FitPage
3335 then reqlayout conf.angle conf.fitmodel;
3336 represent ();
3339 let enterinfomode =
3340 let btos b = if b then UniSyms.radical else E.s in
3341 let showextended = ref false in
3342 let showcolors = ref false in
3343 let leave mode _ = state.mode <- mode in
3344 let src =
3345 (object
3346 val mutable m_l = []
3347 val mutable m_a = E.a
3348 val mutable m_prev_uioh = nouioh
3349 val mutable m_prev_mode = View
3351 inherit lvsourcebase
3353 method reset prev_mode prev_uioh =
3354 m_a <- Array.of_list (List.rev m_l);
3355 m_l <- [];
3356 m_prev_mode <- prev_mode;
3357 m_prev_uioh <- prev_uioh;
3359 method int name get set =
3360 m_l <-
3361 (name, `int get, 1,
3362 Action (
3363 fun u ->
3364 let ondone s =
3365 try set (int_of_string s)
3366 with exn ->
3367 state.text <- Printf.sprintf "bad integer `%s': %s"
3368 s @@ exntos exn
3370 state.text <- E.s;
3371 let te = name ^ ": ", E.s, None, intentry, ondone, true in
3372 state.mode <- Textentry (te, leave m_prev_mode);
3374 )) :: m_l
3376 method int_with_suffix name get set =
3377 m_l <-
3378 (name, `intws get, 1,
3379 Action (
3380 fun u ->
3381 let ondone s =
3382 try set (int_of_string_with_suffix s)
3383 with exn ->
3384 state.text <- Printf.sprintf "bad integer `%s': %s"
3385 s @@ exntos exn
3387 state.text <- E.s;
3388 let te =
3389 name ^ ": ", E.s, None, intentry_with_suffix, ondone, true
3391 state.mode <- Textentry (te, leave m_prev_mode);
3393 )) :: m_l
3395 method bool ?(offset=1) ?(btos=btos) name get set =
3396 m_l <-
3397 (name, `bool (btos, get), offset, Action (
3398 fun u ->
3399 let v = get () in
3400 set (not v);
3402 )) :: m_l
3404 method color name get set =
3405 m_l <-
3406 (name, `color get, 1,
3407 Action (
3408 fun u ->
3409 let invalid = (nan, nan, nan) in
3410 let ondone s =
3411 let c =
3412 try color_of_string s
3413 with exn ->
3414 state.text <- Printf.sprintf "bad color `%s': %s"
3415 s @@ exntos exn;
3416 invalid
3418 if c <> invalid
3419 then set c;
3421 let te = name ^ ": ", E.s, None, textentry, ondone, true in
3422 state.text <- color_to_string (get ());
3423 state.mode <- Textentry (te, leave m_prev_mode);
3425 )) :: m_l
3427 method string name get set =
3428 m_l <-
3429 (name, `string get, 1,
3430 Action (
3431 fun u ->
3432 let ondone s = set s in
3433 let te = name ^ ": ", E.s, None, textentry, ondone, true in
3434 state.mode <- Textentry (te, leave m_prev_mode);
3436 )) :: m_l
3438 method colorspace name get set =
3439 m_l <-
3440 (name, `string get, 1,
3441 Action (
3442 fun _ ->
3443 let source =
3444 (object
3445 inherit lvsourcebase
3447 initializer
3448 m_active <- CSTE.to_int conf.colorspace;
3449 m_first <- 0;
3451 method getitemcount =
3452 Array.length CSTE.names
3453 method getitem n =
3454 (CSTE.names.(n), 0)
3455 method exit ~uioh ~cancel ~active ~first ~pan =
3456 ignore (uioh, first, pan);
3457 if not cancel then set active;
3458 None
3459 method hasaction _ = true
3460 end)
3462 state.text <- E.s;
3463 let modehash = findkeyhash conf "info" in
3464 coe (new listview ~zebra:false ~helpmode:false
3465 ~source ~trusted:true ~modehash)
3466 )) :: m_l
3468 method paxmark name get set =
3469 m_l <-
3470 (name, `string get, 1,
3471 Action (
3472 fun _ ->
3473 let source =
3474 (object
3475 inherit lvsourcebase
3477 initializer
3478 m_active <- MTE.to_int conf.paxmark;
3479 m_first <- 0;
3481 method getitemcount = Array.length MTE.names
3482 method getitem n = (MTE.names.(n), 0)
3483 method exit ~uioh ~cancel ~active ~first ~pan =
3484 ignore (uioh, first, pan);
3485 if not cancel then set active;
3486 None
3487 method hasaction _ = true
3488 end)
3490 state.text <- E.s;
3491 let modehash = findkeyhash conf "info" in
3492 coe (new listview ~zebra:false ~helpmode:false
3493 ~source ~trusted:true ~modehash)
3494 )) :: m_l
3496 method fitmodel name get set =
3497 m_l <-
3498 (name, `string get, 1,
3499 Action (
3500 fun _ ->
3501 let source =
3502 (object
3503 inherit lvsourcebase
3505 initializer
3506 m_active <- FMTE.to_int conf.fitmodel;
3507 m_first <- 0;
3509 method getitemcount = Array.length FMTE.names
3510 method getitem n = (FMTE.names.(n), 0)
3511 method exit ~uioh ~cancel ~active ~first ~pan =
3512 ignore (uioh, first, pan);
3513 if not cancel then set active;
3514 None
3515 method hasaction _ = true
3516 end)
3518 state.text <- E.s;
3519 let modehash = findkeyhash conf "info" in
3520 coe (new listview ~zebra:false ~helpmode:false
3521 ~source ~trusted:true ~modehash)
3522 )) :: m_l
3524 method caption s offset =
3525 m_l <- (s, `empty, offset, Noaction) :: m_l
3527 method caption2 s f offset =
3528 m_l <- (s, `string f, offset, Noaction) :: m_l
3530 method getitemcount = Array.length m_a
3532 method getitem n =
3533 let tostr = function
3534 | `int f -> string_of_int (f ())
3535 | `intws f -> string_with_suffix_of_int (f ())
3536 | `string f -> f ()
3537 | `color f -> color_to_string (f ())
3538 | `bool (btos, f) -> btos (f ())
3539 | `empty -> E.s
3541 let name, t, offset, _ = m_a.(n) in
3542 ((let s = tostr t in
3543 if nonemptystr s
3544 then Printf.sprintf "%s\t%s" name s
3545 else name),
3546 offset)
3548 method exit ~uioh ~cancel ~active ~first ~pan =
3549 let uiohopt =
3550 if not cancel
3551 then (
3552 let uioh =
3553 match m_a.(active) with
3554 | _, _, _, Action f -> f uioh
3555 | _, _, _, Noaction -> uioh
3557 Some uioh
3559 else None
3561 m_active <- active;
3562 m_first <- first;
3563 m_pan <- pan;
3564 uiohopt
3566 method hasaction n =
3567 match m_a.(n) with
3568 | _, _, _, Action _ -> true
3569 | _, _, _, Noaction -> false
3571 initializer m_active <- 1
3572 end)
3574 let rec fillsrc prevmode prevuioh =
3575 let sep () = src#caption E.s 0 in
3576 let colorp name get set =
3577 src#string name
3578 (fun () -> color_to_string (get ()))
3579 (fun v ->
3581 let c = color_of_string v in
3582 set c
3583 with exn ->
3584 state.text <-
3585 Printf.sprintf "bad color `%s': %s" v @@ exntos exn
3588 let rgba name get set =
3589 src#string name
3590 (fun () -> rgba_to_string (get ()))
3591 (fun v ->
3593 let c = rgba_of_string v in
3594 set c
3595 with exn ->
3596 state.text <-
3597 Printf.sprintf "bad color `%s': %s" v @@ exntos exn
3600 let oldmode = state.mode in
3601 let birdseye = isbirdseye state.mode in
3603 src#caption (if birdseye then "Setup (Bird's eye)" else "Setup") 0;
3605 src#bool "presentation mode"
3606 (fun () -> conf.presentation)
3607 (fun v -> setpresentationmode v);
3609 src#bool "ignore case in searches"
3610 (fun () -> conf.icase)
3611 (fun v -> conf.icase <- v);
3613 src#bool "preload"
3614 (fun () -> conf.preload)
3615 (fun v -> conf.preload <- v);
3617 src#bool "highlight links"
3618 (fun () -> conf.hlinks)
3619 (fun v -> conf.hlinks <- v);
3621 src#bool "under info"
3622 (fun () -> conf.underinfo)
3623 (fun v -> conf.underinfo <- v);
3625 src#bool "persistent bookmarks"
3626 (fun () -> conf.savebmarks)
3627 (fun v -> conf.savebmarks <- v);
3629 src#fitmodel "fit model"
3630 (fun () -> FMTE.to_string conf.fitmodel)
3631 (fun v -> reqlayout conf.angle (FMTE.of_int v));
3633 src#bool "trim margins"
3634 (fun () -> conf.trimmargins)
3635 (fun v -> settrim v conf.trimfuzz; fillsrc prevmode prevuioh);
3637 src#bool "persistent location"
3638 (fun () -> conf.jumpback)
3639 (fun v -> conf.jumpback <- v);
3641 sep ();
3642 src#int "inter-page space"
3643 (fun () -> conf.interpagespace)
3644 (fun n ->
3645 conf.interpagespace <- n;
3646 docolumns conf.columns;
3647 let pageno, py =
3648 match state.layout with
3649 | [] -> 0, 0
3650 | l :: _ ->
3651 l.pageno, l.pagey
3653 state.maxy <- calcheight ();
3654 let y = getpagey pageno in
3655 gotoxy state.x (y + py)
3658 src#int "page bias"
3659 (fun () -> conf.pagebias)
3660 (fun v -> conf.pagebias <- v);
3662 src#int "scroll step"
3663 (fun () -> conf.scrollstep)
3664 (fun n -> conf.scrollstep <- n);
3666 src#int "horizontal scroll step"
3667 (fun () -> conf.hscrollstep)
3668 (fun v -> conf.hscrollstep <- v);
3670 src#int "auto scroll step"
3671 (fun () ->
3672 match state.autoscroll with
3673 | Some step -> step
3674 | _ -> conf.autoscrollstep)
3675 (fun n ->
3676 let n = boundastep state.winh n in
3677 if state.autoscroll <> None
3678 then state.autoscroll <- Some n;
3679 conf.autoscrollstep <- n);
3681 src#int "zoom"
3682 (fun () -> truncate (conf.zoom *. 100.))
3683 (fun v -> pivotzoom ((float v) /. 100.));
3685 src#int "rotation"
3686 (fun () -> conf.angle)
3687 (fun v -> reqlayout v conf.fitmodel);
3689 src#int "scroll bar width"
3690 (fun () -> conf.scrollbw)
3691 (fun v ->
3692 conf.scrollbw <- v;
3693 reshape state.winw state.winh;
3696 src#int "scroll handle height"
3697 (fun () -> conf.scrollh)
3698 (fun v -> conf.scrollh <- v;);
3700 src#int "thumbnail width"
3701 (fun () -> conf.thumbw)
3702 (fun v ->
3703 conf.thumbw <- min 4096 v;
3704 match oldmode with
3705 | Birdseye beye ->
3706 leavebirdseye beye false;
3707 enterbirdseye ()
3708 | Textentry _
3709 | View
3710 | LinkNav _ -> ()
3713 let mode = state.mode in
3714 src#string "columns"
3715 (fun () ->
3716 match conf.columns with
3717 | Csingle _ -> "1"
3718 | Cmulti (multi, _) -> multicolumns_to_string multi
3719 | Csplit (count, _) -> "-" ^ string_of_int count
3721 (fun v ->
3722 let n, a, b = multicolumns_of_string v in
3723 setcolumns mode n a b);
3725 sep ();
3726 src#caption "Pixmap cache" 0;
3727 src#int_with_suffix "size (advisory)"
3728 (fun () -> conf.memlimit)
3729 (fun v -> conf.memlimit <- v);
3731 src#caption2 "used"
3732 (fun () ->
3733 Printf.sprintf "%s bytes, %d tiles"
3734 (string_with_suffix_of_int state.memused)
3735 (Hashtbl.length state.tilemap)) 1;
3737 sep ();
3738 src#caption "Layout" 0;
3739 src#caption2 "Dimension"
3740 (fun () ->
3741 Printf.sprintf "%dx%d (virtual %dx%d)"
3742 state.winw state.winh
3743 state.w state.maxy)
3745 if conf.debug
3746 then
3747 src#caption2 "Position" (fun () ->
3748 Printf.sprintf "%dx%d" state.x state.y
3750 else
3751 src#caption2 "Position" (fun () -> describe_layout state.layout) 1;
3753 sep ();
3754 src#bool ~offset:0 ~btos:(fun v -> if v then "(on)" else "(off)")
3755 "Save these parameters as global defaults at exit"
3756 (fun () -> conf.bedefault)
3757 (fun v -> conf.bedefault <- v);
3759 sep ();
3760 let btos b = if b then UniSyms.lguillemet else UniSyms.rguillemet in
3761 src#bool ~offset:0 ~btos "Extended parameters"
3762 (fun () -> !showextended)
3763 (fun v -> showextended := v; fillsrc prevmode prevuioh);
3764 if !showextended
3765 then (
3766 src#bool "checkers"
3767 (fun () -> conf.checkers)
3768 (fun v -> conf.checkers <- v; setcheckers v);
3769 src#bool "update cursor"
3770 (fun () -> conf.updatecurs)
3771 (fun v -> conf.updatecurs <- v);
3772 src#bool "scroll-bar on the left"
3773 (fun () -> conf.leftscroll)
3774 (fun v -> conf.leftscroll <- v);
3775 src#bool "verbose"
3776 (fun () -> conf.verbose)
3777 (fun v -> conf.verbose <- v);
3778 src#bool "invert colors"
3779 (fun () -> conf.invert)
3780 (fun v -> conf.invert <- v);
3781 src#bool "max fit"
3782 (fun () -> conf.maxhfit)
3783 (fun v -> conf.maxhfit <- v);
3784 src#bool "pax mode"
3785 (fun () -> conf.pax != None)
3786 (fun v ->
3787 if v
3788 then conf.pax <- Some (now ())
3789 else conf.pax <- None);
3790 src#string "uri launcher"
3791 (fun () -> conf.urilauncher)
3792 (fun v -> conf.urilauncher <- v);
3793 src#string "path launcher"
3794 (fun () -> conf.pathlauncher)
3795 (fun v -> conf.pathlauncher <- v);
3796 src#string "tile size"
3797 (fun () -> Printf.sprintf "%dx%d" conf.tilew conf.tileh)
3798 (fun v ->
3800 let w, h = Scanf.sscanf v "%dx%d" (fun w h -> w, h) in
3801 conf.tilew <- max 64 w;
3802 conf.tileh <- max 64 h;
3803 flushtiles ();
3804 with exn ->
3805 state.text <- Printf.sprintf "bad tile size `%s': %s"
3806 v @@ exntos exn
3808 src#int "texture count"
3809 (fun () -> conf.texcount)
3810 (fun v ->
3811 if realloctexts v
3812 then conf.texcount <- v
3813 else impmsg "failed to set texture count please retry later"
3815 src#int "slice height"
3816 (fun () -> conf.sliceheight)
3817 (fun v ->
3818 conf.sliceheight <- v;
3819 wcmd "sliceh %d" conf.sliceheight;
3821 src#int "anti-aliasing level"
3822 (fun () -> conf.aalevel)
3823 (fun v ->
3824 conf.aalevel <- bound v 0 8;
3825 state.anchor <- getanchor ();
3826 opendoc state.path state.password;
3828 src#string "page scroll scaling factor"
3829 (fun () -> string_of_float conf.pgscale)
3830 (fun v ->
3832 let s = float_of_string v in
3833 conf.pgscale <- s
3834 with exn ->
3835 state.text <- Printf.sprintf
3836 "bad page scroll scaling factor `%s': %s" v
3837 @@ exntos exn
3840 src#int "ui font size"
3841 (fun () -> fstate.fontsize)
3842 (fun v -> setfontsize (bound v 5 100));
3843 src#int "hint font size"
3844 (fun () -> conf.hfsize)
3845 (fun v -> conf.hfsize <- bound v 5 100);
3846 src#bool "crop hack"
3847 (fun () -> conf.crophack)
3848 (fun v -> conf.crophack <- v);
3849 src#string "trim fuzz"
3850 (fun () -> irect_to_string conf.trimfuzz)
3851 (fun v ->
3853 conf.trimfuzz <- irect_of_string v;
3854 if conf.trimmargins
3855 then settrim true conf.trimfuzz;
3856 with exn ->
3857 state.text <- Printf.sprintf "bad irect `%s': %s" v
3858 @@ exntos exn
3860 src#string "throttle"
3861 (fun () ->
3862 match conf.maxwait with
3863 | None -> "show place holder if page is not ready"
3864 | Some time ->
3865 if time = infinity
3866 then "wait for page to fully render"
3867 else
3868 "wait " ^ string_of_float time
3869 ^ " seconds before showing placeholder"
3871 (fun v ->
3873 let f = float_of_string v in
3874 if f <= 0.0
3875 then conf.maxwait <- None
3876 else conf.maxwait <- Some f
3877 with exn ->
3878 state.text <- Printf.sprintf "bad time `%s': %s" v
3879 @@ exntos exn
3881 src#string "ghyll scroll"
3882 (fun () ->
3883 match conf.ghyllscroll with
3884 | None -> E.s
3885 | Some nab -> ghyllscroll_to_string nab
3887 (fun v ->
3888 try conf.ghyllscroll <- ghyllscroll_of_string v
3889 with
3890 | Failure msg ->
3891 state.text <- Printf.sprintf "bad ghyll `%s': %s" v msg
3892 | exn ->
3893 state.text <- Printf.sprintf "bad ghyll `%s': %s" v
3894 @@ exntos exn
3896 src#string "selection command"
3897 (fun () -> conf.selcmd)
3898 (fun v -> conf.selcmd <- v);
3899 src#string "synctex command"
3900 (fun () -> conf.stcmd)
3901 (fun v -> conf.stcmd <- v);
3902 src#string "pax command"
3903 (fun () -> conf.paxcmd)
3904 (fun v -> conf.paxcmd <- v);
3905 src#string "ask password command"
3906 (fun () -> conf.passcmd)
3907 (fun v -> conf.passcmd <- v);
3908 src#string "save path command"
3909 (fun () -> conf.savecmd)
3910 (fun v -> conf.savecmd <- v);
3911 src#colorspace "color space"
3912 (fun () -> CSTE.to_string conf.colorspace)
3913 (fun v ->
3914 conf.colorspace <- CSTE.of_int v;
3915 wcmd "cs %d" v;
3916 load state.layout;
3918 src#paxmark "pax mark method"
3919 (fun () -> MTE.to_string conf.paxmark)
3920 (fun v -> conf.paxmark <- MTE.of_int v);
3921 if bousable () && !opengl_has_pbo
3922 then
3923 src#bool "use PBO"
3924 (fun () -> conf.usepbo)
3925 (fun v -> conf.usepbo <- v);
3926 src#bool "mouse wheel scrolls pages"
3927 (fun () -> conf.wheelbypage)
3928 (fun v -> conf.wheelbypage <- v);
3929 src#bool "open remote links in a new instance"
3930 (fun () -> conf.riani)
3931 (fun v -> conf.riani <- v);
3932 src#bool "edit annotations inline"
3933 (fun () -> conf.annotinline)
3934 (fun v -> conf.annotinline <- v);
3935 src#bool "coarse positioning in presentation mode"
3936 (fun () -> conf.coarseprespos)
3937 (fun v -> conf.coarseprespos <- v);
3938 src#bool "use document CSS"
3939 (fun () -> conf.usedoccss)
3940 (fun v ->
3941 conf.usedoccss <- v;
3942 state.anchor <- getanchor ();
3943 opendoc state.path state.password;
3945 src#bool ~btos "colors"
3946 (fun () -> !showcolors)
3947 (fun v -> showcolors := v; fillsrc prevmode prevuioh);
3948 if !showcolors
3949 then (
3950 colorp " background"
3951 (fun () -> conf.bgcolor)
3952 (fun v -> conf.bgcolor <- v);
3953 rgba " scrollbar"
3954 (fun () -> conf.sbarcolor)
3955 (fun v -> conf.sbarcolor <- v);
3956 rgba " scrollbar handle"
3957 (fun () -> conf.sbarhndlcolor)
3958 (fun v -> conf.sbarhndlcolor <- v);
3962 sep ();
3963 src#caption "Document" 0;
3964 List.iter (fun (_, s) -> src#caption s 1) state.docinfo;
3965 src#caption2 "Pages"
3966 (fun () -> string_of_int state.pagecount) 1;
3967 src#caption2 "Dimensions"
3968 (fun () -> string_of_int (List.length state.pdims)) 1;
3969 if nonemptystr conf.css
3970 then src#caption2 "CSS" (fun () -> conf.css) 1;
3971 if conf.trimmargins
3972 then (
3973 sep ();
3974 src#caption "Trimmed margins" 0;
3975 src#caption2 "Dimensions"
3976 (fun () -> string_of_int (List.length state.pdims)) 1;
3979 sep ();
3980 src#caption "OpenGL" 0;
3981 src#caption (Printf.sprintf "Vendor\t%s" (GlMisc.get_string `vendor)) 1;
3982 src#caption (Printf.sprintf "Renderer\t%s" (GlMisc.get_string `renderer)) 1;
3984 sep ();
3985 src#caption "Location" 0;
3986 if nonemptystr state.origin
3987 then src#caption ("Orign\t" ^ mbtoutf8 state.origin) 1;
3988 src#caption ("Path\t" ^ mbtoutf8 state.path) 1;
3990 src#reset prevmode prevuioh;
3992 fun () ->
3993 state.text <- E.s;
3994 resetmstate ();
3995 let prevmode = state.mode
3996 and prevuioh = state.uioh in
3997 fillsrc prevmode prevuioh;
3998 let source = (src :> lvsource) in
3999 let modehash = findkeyhash conf "info" in
4000 state.uioh <-
4001 coe (object (self)
4002 inherit listview ~zebra:false ~helpmode:false
4003 ~source ~trusted:true ~modehash as super
4004 val mutable m_prevmemused = 0
4005 method! infochanged = function
4006 | Memused ->
4007 if m_prevmemused != state.memused
4008 then (
4009 m_prevmemused <- state.memused;
4010 G.postRedisplay "memusedchanged";
4012 | Pdim -> G.postRedisplay "pdimchanged"
4013 | Docinfo -> fillsrc prevmode prevuioh
4015 method! key key mask =
4016 if not (Wsi.withctrl mask)
4017 then
4018 match [@warning "-4"] Wsi.kc2kt key with
4019 | Keys.Left -> coe (self#updownlevel ~-1)
4020 | Keys.Right -> coe (self#updownlevel 1)
4021 | _ -> super#key key mask
4022 else super#key key mask
4023 end);
4024 G.postRedisplay "info";
4027 let enterhelpmode =
4028 let source =
4029 (object
4030 inherit lvsourcebase
4031 method getitemcount = Array.length state.help
4032 method getitem n =
4033 let s, l, _ = state.help.(n) in
4034 (s, l)
4036 method exit ~uioh ~cancel ~active ~first ~pan =
4037 let optuioh =
4038 if not cancel
4039 then (
4040 match state.help.(active) with
4041 | _, _, Action f -> Some (f uioh)
4042 | _, _, Noaction -> Some uioh
4044 else None
4046 m_active <- active;
4047 m_first <- first;
4048 m_pan <- pan;
4049 optuioh
4051 method hasaction n =
4052 match state.help.(n) with
4053 | _, _, Action _ -> true
4054 | _, _, Noaction -> false
4056 initializer
4057 m_active <- -1
4058 end)
4059 in fun () ->
4060 let modehash = findkeyhash conf "help" in
4061 resetmstate ();
4062 state.uioh <- coe (new listview
4063 ~zebra:false ~helpmode:true
4064 ~source ~trusted:true ~modehash);
4065 G.postRedisplay "help";
4068 let entermsgsmode =
4069 let msgsource =
4070 (object
4071 inherit lvsourcebase
4072 val mutable m_items = E.a
4074 method getitemcount = 1 + Array.length m_items
4076 method getitem n =
4077 if n = 0
4078 then "[Clear]", 0
4079 else m_items.(n-1), 0
4081 method exit ~uioh ~cancel ~active ~first ~pan =
4082 ignore uioh;
4083 if not cancel
4084 then (
4085 if active = 0
4086 then Buffer.clear state.errmsgs;
4088 m_active <- active;
4089 m_first <- first;
4090 m_pan <- pan;
4091 None
4093 method hasaction n =
4094 n = 0
4096 method reset =
4097 state.newerrmsgs <- false;
4098 let l = Str.split newlinere (Buffer.contents state.errmsgs) in
4099 m_items <- Array.of_list l
4101 initializer
4102 m_active <- 0
4103 end)
4104 in fun () ->
4105 state.text <- E.s;
4106 resetmstate ();
4107 msgsource#reset;
4108 let source = (msgsource :> lvsource) in
4109 let modehash = findkeyhash conf "listview" in
4110 state.uioh <-
4111 coe (object
4112 inherit listview ~zebra:false ~helpmode:false
4113 ~source ~trusted:false ~modehash as super
4114 method! display =
4115 if state.newerrmsgs
4116 then msgsource#reset;
4117 super#display
4118 end);
4119 G.postRedisplay "msgs";
4122 let getusertext s =
4123 let editor = getenvwithdef "EDITOR" E.s in
4124 if emptystr editor
4125 then E.s
4126 else
4127 let tmppath = Filename.temp_file "llpp" "note" in
4128 if nonemptystr s
4129 then (
4130 let oc = open_out tmppath in
4131 output_string oc s;
4132 close_out oc;
4134 let execstr = editor ^ " " ^ tmppath in
4135 let s =
4136 match spawn execstr [] with
4137 | exception exn ->
4138 impmsg "spawn(%S) failed: %s" execstr @@ exntos exn;
4140 | pid ->
4141 match Unix.waitpid [] pid with
4142 | exception exn ->
4143 impmsg "waitpid(%d) failed: %s" pid @@ exntos exn;
4145 | (_pid, status) ->
4146 match status with
4147 | Unix.WEXITED 0 -> filecontents tmppath
4148 | Unix.WEXITED n ->
4149 impmsg "editor process(%s) exited abnormally: %d" execstr n;
4151 | Unix.WSIGNALED n ->
4152 impmsg "editor process(%s) was killed by signal %d" execstr n;
4154 | Unix.WSTOPPED n ->
4155 impmsg "editor(%s) process was stopped by signal %d" execstr n;
4158 match Unix.unlink tmppath with
4159 | exception exn ->
4160 impmsg "failed to ulink %S: %s" tmppath @@ exntos exn;
4162 | () -> s
4165 let enterannotmode opaque slinkindex =
4166 let msgsource =
4167 (object
4168 inherit lvsourcebase
4169 val mutable m_text = E.s
4170 val mutable m_items = E.a
4172 method getitemcount = Array.length m_items
4174 method getitem n =
4175 let label, _func = m_items.(n) in
4176 label, 0
4178 method exit ~uioh ~cancel ~active ~first ~pan =
4179 ignore (uioh, first, pan);
4180 if not cancel
4181 then (
4182 let _label, func = m_items.(active) in
4183 func ()
4185 None
4187 method hasaction n = nonemptystr @@ fst m_items.(n)
4189 method reset s =
4190 let rec split accu b i =
4191 let p = b+i in
4192 if p = String.length s
4193 then (String.sub s b (p-b), unit) :: accu
4194 else
4195 if (i > 70 && s.[p] = ' ') || s.[p] = '\r' || s.[p] = '\n'
4196 then
4197 let ss = if i = 0 then E.s else String.sub s b i in
4198 split ((ss, unit)::accu) (p+1) 0
4199 else
4200 split accu b (i+1)
4202 let cleanup () =
4203 wcmd "freepage %s" (~> opaque);
4204 let keys =
4205 Hashtbl.fold (fun key opaque' accu ->
4206 if opaque' = opaque'
4207 then key :: accu else accu) state.pagemap []
4209 List.iter (Hashtbl.remove state.pagemap) keys;
4210 flushtiles ();
4211 gotoxy state.x state.y
4213 let dele () =
4214 delannot opaque slinkindex;
4215 cleanup ();
4217 let edit inline () =
4218 let update s =
4219 if emptystr s
4220 then dele ()
4221 else (
4222 modannot opaque slinkindex s;
4223 cleanup ();
4226 if inline
4227 then
4228 let mode = state.mode in
4229 state.mode <-
4230 Textentry (
4231 ("annotation: ", m_text, None, textentry, update, true),
4232 fun _ -> state.mode <- mode);
4233 state.text <- E.s;
4234 enttext ();
4235 else
4236 let s = getusertext m_text in
4237 update s
4239 m_text <- s;
4240 m_items <-
4241 ( "[Copy]", fun () -> selstring m_text)
4242 :: ("[Delete]", dele)
4243 :: ("[Edit]", edit conf.annotinline)
4244 :: (E.s, unit)
4245 :: split [] 0 0 |> List.rev |> Array.of_list
4247 initializer
4248 m_active <- 0
4249 end)
4251 state.text <- E.s;
4252 let s = getannotcontents opaque slinkindex in
4253 resetmstate ();
4254 msgsource#reset s;
4255 let source = (msgsource :> lvsource) in
4256 let modehash = findkeyhash conf "listview" in
4257 state.uioh <- coe (object
4258 inherit listview ~zebra:false ~helpmode:false
4259 ~source ~trusted:false ~modehash
4260 end);
4261 G.postRedisplay "enterannotmode";
4264 let gotoremote spec =
4265 let filename, dest = splitatchar spec '#' in
4266 let getpath filename =
4267 let path =
4268 if nonemptystr filename
4269 then
4270 if Filename.is_relative filename
4271 then
4272 let dir = Filename.dirname state.path in
4273 let dir =
4274 if Filename.is_implicit dir
4275 then Filename.concat (Sys.getcwd ()) dir
4276 else dir
4278 Filename.concat dir filename
4279 else filename
4280 else E.s
4282 if Sys.file_exists path
4283 then path
4284 else E.s
4286 let path = getpath filename in
4287 let dospawn lcmd =
4288 if conf.riani
4289 then
4290 let cmd = Lazy.force_val lcmd in
4291 match spawn cmd with
4292 | _pid -> ()
4293 | exception exn -> dolog "failed to execute `%s': %s" cmd @@ exntos exn
4294 else
4295 let anchor = getanchor () in
4296 let ranchor = state.path, state.password, anchor, state.origin in
4297 state.origin <- E.s;
4298 state.ranchors <- ranchor :: state.ranchors;
4299 opendoc path E.s;
4301 if substratis spec 0 "page="
4302 then
4303 match Scanf.sscanf spec "page=%d" (fun n -> n) with
4304 | pageno ->
4305 state.anchor <- (pageno, 0.0, 0.0);
4306 dospawn @@ lazy (Printf.sprintf "%s -page %d %S" !selfexec pageno path);
4307 | exception exn ->
4308 adderrfmt "error parsing remote destination" "page: %s" @@ exntos exn
4309 else (
4310 state.nameddest <- dest;
4311 dospawn @@ lazy (!selfexec ^ " " ^ path ^ " -dest " ^ dest)
4315 let gotounder = function
4316 | Ulinkuri s when isexternallink s ->
4317 if substratis s 0 "file://"
4318 then gotoremote @@ String.sub s 7 (String.length s - 7)
4319 else gotouri s
4320 | Ulinkuri s ->
4321 let pageno, x, y = uritolocation s in
4322 addnav ();
4323 gotopagexy pageno x y
4324 | Utext _ | Unone -> ()
4325 | Uannotation (opaque, slinkindex) -> enterannotmode opaque slinkindex
4328 let gotooutline (_, _, kind) =
4329 match kind with
4330 | Onone -> ()
4331 | Oanchor anchor ->
4332 let (pageno, y, _) = anchor in
4333 let y = getanchory
4334 (if conf.presentation then (pageno, y, 1.0) else anchor)
4336 addnav ();
4337 gotoghyll y
4338 | Ouri uri -> gotounder (Ulinkuri uri)
4339 | Olaunch _cmd -> failwith "gotounder (Ulaunch cmd)"
4340 | Oremote _remote -> failwith "gotounder (Uremote remote)"
4341 | Ohistory hist -> gotohist hist
4342 | Oremotedest _remotedest -> failwith "gotounder (Uremotedest remotedest)"
4345 class outlinesoucebase fetchoutlines = object (self)
4346 inherit lvsourcebase
4347 val mutable m_items = E.a
4348 val mutable m_minfo = E.a
4349 val mutable m_orig_items = E.a
4350 val mutable m_orig_minfo = E.a
4351 val mutable m_narrow_patterns = []
4352 val mutable m_gen = -1
4354 method getitemcount = Array.length m_items
4356 method getitem n =
4357 let s, n, _ = m_items.(n) in
4358 (s, n+0)
4360 method exit ~(uioh:uioh) ~cancel ~active ~(first:int) ~pan : uioh option =
4361 ignore (uioh, first);
4362 let items, minfo =
4363 if m_narrow_patterns = []
4364 then m_orig_items, m_orig_minfo
4365 else m_items, m_minfo
4367 m_pan <- pan;
4368 if not cancel
4369 then (
4370 m_items <- items;
4371 m_minfo <- minfo;
4372 gotooutline m_items.(active);
4374 else (
4375 m_items <- items;
4376 m_minfo <- minfo;
4378 None
4380 method hasaction (_:int) = true
4382 method greetmsg =
4383 if Array.length m_items != Array.length m_orig_items
4384 then
4385 let s =
4386 match m_narrow_patterns with
4387 | one :: [] -> one
4388 | many -> String.concat UniSyms.ellipsis (List.rev many)
4390 "Narrowed to " ^ s ^ " (ctrl-u to restore)"
4391 else E.s
4393 method statestr =
4394 match m_narrow_patterns with
4395 | [] -> E.s
4396 | one :: [] -> one
4397 | head :: _ -> UniSyms.ellipsis ^ head
4399 method narrow pattern =
4400 match Str.regexp_case_fold pattern with
4401 | exception _ -> ()
4402 | re ->
4403 let rec loop accu minfo n =
4404 if n = -1
4405 then (
4406 m_items <- Array.of_list accu;
4407 m_minfo <- Array.of_list minfo;
4409 else
4410 let (s, _, _) as o = m_items.(n) in
4411 let accu, minfo =
4412 match Str.search_forward re s 0 with
4413 | exception Not_found -> accu, minfo
4414 | first -> o :: accu, (first, Str.match_end ()) :: minfo
4416 loop accu minfo (n-1)
4418 loop [] [] (Array.length m_items - 1)
4420 method! getminfo = m_minfo
4422 method denarrow =
4423 m_orig_items <- fetchoutlines ();
4424 m_minfo <- m_orig_minfo;
4425 m_items <- m_orig_items
4427 method add_narrow_pattern pattern =
4428 m_narrow_patterns <- pattern :: m_narrow_patterns
4430 method del_narrow_pattern =
4431 match m_narrow_patterns with
4432 | _ :: rest -> m_narrow_patterns <- rest
4433 | [] -> ()
4435 method renarrow =
4436 self#denarrow;
4437 match m_narrow_patterns with
4438 | pattern :: [] -> self#narrow pattern; pattern
4439 | list ->
4440 List.fold_left (fun accu pattern ->
4441 self#narrow pattern;
4442 pattern ^ UniSyms.ellipsis ^ accu) E.s list
4444 method calcactive (_:anchor) = 0
4446 method reset anchor items =
4447 if state.gen != m_gen
4448 then (
4449 m_orig_items <- items;
4450 m_items <- items;
4451 m_narrow_patterns <- [];
4452 m_minfo <- E.a;
4453 m_orig_minfo <- E.a;
4454 m_gen <- state.gen;
4456 else (
4457 if items != m_orig_items
4458 then (
4459 m_orig_items <- items;
4460 if m_narrow_patterns == []
4461 then m_items <- items;
4464 let active = self#calcactive anchor in
4465 m_active <- active;
4466 m_first <- firstof m_first active
4470 let outlinesource fetchoutlines =
4471 (object
4472 inherit outlinesoucebase fetchoutlines
4473 method! calcactive anchor =
4474 let rely = getanchory anchor in
4475 let rec loop n best bestd =
4476 if n = Array.length m_items
4477 then best
4478 else
4479 let _, _, kind = m_items.(n) in
4480 match kind with
4481 | Oanchor anchor ->
4482 let orely = getanchory anchor in
4483 let d = abs (orely - rely) in
4484 if d < bestd
4485 then loop (n+1) n d
4486 else loop (n+1) best bestd
4487 | Onone | Oremote _ | Olaunch _
4488 | Oremotedest _ | Ouri _ | Ohistory _ ->
4489 loop (n+1) best bestd
4491 loop 0 ~-1 max_int
4492 end)
4495 let enteroutlinemode, enterbookmarkmode, enterhistmode =
4496 let mkselector sourcetype =
4497 let fetchoutlines () =
4498 match sourcetype with
4499 | `bookmarks -> Array.of_list state.bookmarks
4500 | `outlines -> state.outlines
4501 | `history -> genhistoutlines () |> Array.of_list
4503 let source =
4504 if sourcetype = `history
4505 then new outlinesoucebase fetchoutlines
4506 else outlinesource fetchoutlines
4508 (fun errmsg ->
4509 let outlines = fetchoutlines () in
4510 if Array.length outlines = 0
4511 then showtext ' ' errmsg
4512 else (
4513 resetmstate ();
4514 Wsi.setcursor Wsi.CURSOR_INHERIT;
4515 let anchor = getanchor () in
4516 source#reset anchor outlines;
4517 state.text <- source#greetmsg;
4518 state.uioh <-
4519 coe (new outlinelistview ~zebra:(sourcetype=`history) ~source);
4520 G.postRedisplay "enter selector";
4524 let mkenter sourcetype errmsg =
4525 let enter = mkselector sourcetype in
4526 fun () -> enter errmsg
4528 ( mkenter `outlines "document has no outline"
4529 , mkenter `bookmarks "document has no bookmarks (yet)"
4530 , mkenter `history "history is empty" )
4533 let quickbookmark ?title () =
4534 match state.layout with
4535 | [] -> ()
4536 | l :: _ ->
4537 let title =
4538 match title with
4539 | None ->
4540 Unix.(
4541 let tm = localtime (now ()) in
4542 Printf.sprintf
4543 "Quick (page %d) (bookmarked on %02d/%02d/%d at %02d:%02d)"
4544 (l.pageno+1)
4545 tm.tm_mday (tm.tm_mon+1) (tm.tm_year+1900) tm.tm_hour tm.tm_min
4547 | Some title -> title
4549 state.bookmarks <- (title, 0, Oanchor (getanchor1 l)) :: state.bookmarks
4552 let setautoscrollspeed step goingdown =
4553 let incr = max 1 ((abs step) / 2) in
4554 let incr = if goingdown then incr else -incr in
4555 let astep = boundastep state.winh (step + incr) in
4556 state.autoscroll <- Some astep;
4559 let canpan () =
4560 match conf.columns with
4561 | Csplit _ -> true
4562 | Csingle _ | Cmulti _ -> state.x != 0 || conf.zoom > 1.0
4565 let panbound x = bound x (-state.w) state.winw;;
4567 let existsinrow pageno (columns, coverA, coverB) p =
4568 let last = ((pageno - coverA) mod columns) + columns in
4569 let rec any = function
4570 | [] -> false
4571 | l :: rest ->
4572 if l.pageno = coverA - 1 || l.pageno = state.pagecount - coverB
4573 then p l
4574 else (
4575 if not (p l)
4576 then (if l.pageno = last then false else any rest)
4577 else true
4580 any state.layout
4583 let nextpage () =
4584 match state.layout with
4585 | [] ->
4586 let pageno = page_of_y state.y in
4587 gotoghyll (getpagey (pageno+1))
4588 | l :: rest ->
4589 match conf.columns with
4590 | Csingle _ ->
4591 if conf.presentation && rest == [] && l.pageh > l.pagey + l.pagevh
4592 then
4593 let y = clamp (pgscale state.winh) in
4594 gotoghyll y
4595 else
4596 let pageno = min (l.pageno+1) (state.pagecount-1) in
4597 gotoghyll (getpagey pageno)
4598 | Cmulti ((c, _, _) as cl, _) ->
4599 if conf.presentation
4600 && (existsinrow l.pageno cl
4601 (fun l -> l.pageh > l.pagey + l.pagevh))
4602 then
4603 let y = clamp (pgscale state.winh) in
4604 gotoghyll y
4605 else
4606 let pageno = min (l.pageno+c) (state.pagecount-1) in
4607 gotoghyll (getpagey pageno)
4608 | Csplit (n, _) ->
4609 if l.pageno < state.pagecount - 1 || l.pagecol < n - 1
4610 then
4611 let pagey, pageh = getpageyh l.pageno in
4612 let pagey = pagey + pageh * l.pagecol in
4613 let ips = if l.pagecol = 0 then 0 else conf.interpagespace in
4614 gotoghyll (pagey + pageh + ips)
4617 let prevpage () =
4618 match state.layout with
4619 | [] ->
4620 let pageno = page_of_y state.y in
4621 gotoghyll (getpagey (pageno-1))
4622 | l :: _ ->
4623 match conf.columns with
4624 | Csingle _ ->
4625 if conf.presentation && l.pagey != 0
4626 then
4627 gotoghyll (clamp (pgscale ~-(state.winh)))
4628 else
4629 let pageno = max 0 (l.pageno-1) in
4630 gotoghyll (getpagey pageno)
4631 | Cmulti ((c, _, coverB) as cl, _) ->
4632 if conf.presentation &&
4633 (existsinrow l.pageno cl (fun l -> l.pagey != 0))
4634 then
4635 gotoghyll (clamp (pgscale ~-(state.winh)))
4636 else
4637 let decr =
4638 if l.pageno = state.pagecount - coverB
4639 then 1
4640 else c
4642 let pageno = max 0 (l.pageno-decr) in
4643 gotoghyll (getpagey pageno)
4644 | Csplit (n, _) ->
4645 let y =
4646 if l.pagecol = 0
4647 then
4648 if l.pageno = 0
4649 then l.pagey
4650 else
4651 let pageno = max 0 (l.pageno-1) in
4652 let pagey, pageh = getpageyh pageno in
4653 pagey + (n-1)*pageh
4654 else
4655 let pagey, pageh = getpageyh l.pageno in
4656 pagey + pageh * (l.pagecol-1) - conf.interpagespace
4658 gotoghyll y
4661 let save () =
4662 if emptystr conf.savecmd
4663 then adderrmsg "savepath-command is empty"
4664 "don't know where to save modified document"
4665 else
4666 let savecmd = Str.global_replace percentsre state.path conf.savecmd in
4667 let path =
4668 getcmdoutput
4669 (fun exn ->
4670 adderrfmt savecmd "failed to produce path to the saved copy: %s" exn)
4671 savecmd
4673 if nonemptystr path
4674 then
4675 let tmp = path ^ ".tmp" in
4676 savedoc tmp;
4677 Unix.rename tmp path;
4680 let viewkeyboard key mask =
4681 let enttext te =
4682 let mode = state.mode in
4683 state.mode <- Textentry (te, fun _ -> state.mode <- mode);
4684 state.text <- E.s;
4685 enttext ();
4686 G.postRedisplay "view:enttext"
4688 let ctrl = Wsi.withctrl mask in
4689 let open Keys in
4690 match Wsi.kc2kt key with
4691 | Ascii 'S' -> state.slideshow <- state.slideshow lxor 1
4693 | Ascii 'Q' -> exit 0
4695 | Ascii 'W' ->
4696 if hasunsavedchanges ()
4697 then save ()
4699 | Insert ->
4700 if conf.angle mod 360 = 0 && not (isbirdseye state.mode)
4701 then (
4702 state.mode <- (
4703 match state.lnava with
4704 | None -> LinkNav (Ltgendir 0)
4705 | Some pn -> LinkNav (Ltexact pn)
4707 gotoxy state.x state.y;
4709 else impmsg "keyboard link navigation does not work under rotation"
4711 | Escape | Ascii 'q' ->
4712 begin match state.mstate with
4713 | Mzoomrect _ ->
4714 resetmstate ();
4715 G.postRedisplay "kill rect";
4716 | Msel _
4717 | Mpan _
4718 | Mscrolly | Mscrollx
4719 | Mzoom _
4720 | Mnone ->
4721 begin match state.mode with
4722 | LinkNav ln ->
4723 begin match ln with
4724 | Ltexact pl -> state.lnava <- Some pl
4725 | Ltgendir _ | Ltnotready _ -> state.lnava <- None
4726 end;
4727 state.mode <- View;
4728 G.postRedisplay "esc leave linknav"
4729 | Birdseye _ | Textentry _ | View ->
4730 match state.ranchors with
4731 | [] -> raise Quit
4732 | (path, password, anchor, origin) :: rest ->
4733 state.ranchors <- rest;
4734 state.anchor <- anchor;
4735 state.origin <- origin;
4736 state.nameddest <- E.s;
4737 opendoc path password
4738 end;
4739 end;
4741 | Backspace ->
4742 addnavnorc ();
4743 gotoghyll (getnav ~-1)
4745 | Ascii 'o' ->
4746 enteroutlinemode ()
4748 | Ascii 'H' ->
4749 enterhistmode ()
4751 | Ascii 'u' ->
4752 state.rects <- [];
4753 state.text <- E.s;
4754 Hashtbl.iter (fun _ opaque ->
4755 clearmark opaque;
4756 Hashtbl.clear state.prects) state.pagemap;
4757 G.postRedisplay "dehighlight";
4759 | Ascii (('/' | '?') as c) ->
4760 let ondone isforw s =
4761 cbput state.hists.pat s;
4762 state.searchpattern <- s;
4763 search s isforw
4765 let s = String.make 1 c in
4766 enttext (s, E.s, Some (onhist state.hists.pat),
4767 textentry, ondone (c = '/'), true)
4769 | Ascii '+' | Ascii '=' when ctrl ->
4770 let incr = if conf.zoom +. 0.01 > 0.1 then 0.1 else 0.01 in
4771 pivotzoom (conf.zoom +. incr)
4773 | Ascii '+' ->
4774 let ondone s =
4775 let n =
4776 try int_of_string s with exn ->
4777 state.text <-
4778 Printf.sprintf "bad integer `%s': %s" s @@ exntos exn;
4779 max_int
4781 if n != max_int
4782 then (
4783 conf.pagebias <- n;
4784 state.text <- "page bias is now " ^ string_of_int n;
4787 enttext ("page bias: ", E.s, None, intentry, ondone, true)
4789 | Ascii '-' when ctrl ->
4790 let decr = if conf.zoom -. 0.1 < 0.1 then 0.01 else 0.1 in
4791 pivotzoom (max 0.01 (conf.zoom -. decr))
4793 | Ascii '-' ->
4794 let ondone msg = state.text <- msg in
4795 enttext (
4796 "option [acfhilpstvxACFPRSZTISM]: ", E.s, None,
4797 optentry state.mode, ondone, true
4800 | Ascii '0' when ctrl ->
4801 if conf.zoom = 1.0
4802 then gotoxy 0 state.y
4803 else setzoom 1.0
4805 | Ascii ('1'|'2' as c) when ctrl && conf.fitmodel != FitPage ->
4806 let cols =
4807 match conf.columns with
4808 | Csingle _ | Cmulti _ -> 1
4809 | Csplit (n, _) -> n
4811 let h = state.winh -
4812 conf.interpagespace lsl (if conf.presentation then 1 else 0)
4814 let zoom = zoomforh state.winw h 0 cols in
4815 if zoom > 0.0 && (c = '2' || zoom < 1.0)
4816 then setzoom zoom
4818 | Ascii '3' when ctrl ->
4819 let fm =
4820 match conf.fitmodel with
4821 | FitWidth -> FitProportional
4822 | FitProportional -> FitPage
4823 | FitPage -> FitWidth
4825 state.text <- "fit model: " ^ FMTE.to_string fm;
4826 reqlayout conf.angle fm
4828 | Ascii '4' when ctrl ->
4829 let zoom = getmaxw () /. float state.winw in
4830 if zoom > 0.0 then setzoom zoom
4832 | Fn 9 ->
4833 togglebirdseye ()
4835 | Ascii '9' when ctrl ->
4836 togglebirdseye ()
4838 | Ascii ('0'..'9' as c) when not ctrl ->
4839 let ondone s =
4840 let n =
4841 try int_of_string s with exn ->
4842 state.text <- Printf.sprintf "bad integer `%s': %s" s @@ exntos exn;
4845 if n >= 0
4846 then (
4847 addnav ();
4848 cbput state.hists.pag (string_of_int n);
4849 gotopage1 (n + conf.pagebias - 1) 0;
4852 let [@warning "-4"] pageentry text = function
4853 | Keys.Ascii 'g' -> TEdone text
4854 | key -> intentry text key
4856 let text = String.make 1 c in
4857 enttext (":", text, Some (onhist state.hists.pag),
4858 pageentry, ondone, true)
4860 | Ascii 'b' ->
4861 conf.scrollb <- if conf.scrollb = 0 then (scrollbvv lor scrollbhv) else 0;
4862 G.postRedisplay "toggle scrollbar";
4864 | Ascii 'B' ->
4865 state.bzoom <- not state.bzoom;
4866 state.rects <- [];
4867 showtext ' ' ("block zoom " ^ if state.bzoom then "on" else "off")
4869 | Ascii 'l' ->
4870 conf.hlinks <- not conf.hlinks;
4871 state.text <- "highlightlinks " ^ if conf.hlinks then "on" else "off";
4872 G.postRedisplay "toggle highlightlinks";
4874 | Ascii 'F' ->
4875 if conf.angle mod 360 = 0
4876 then (
4877 state.glinks <- true;
4878 let mode = state.mode in
4879 state.mode <-
4880 Textentry (
4881 (":", E.s, None, linknentry, linknact gotounder, false),
4882 (fun _ ->
4883 state.glinks <- false;
4884 state.mode <- mode)
4886 state.text <- E.s;
4887 G.postRedisplay "view:linkent(F)"
4889 else impmsg "hint mode does not work under rotation"
4891 | Ascii 'y' ->
4892 state.glinks <- true;
4893 let mode = state.mode in
4894 state.mode <-
4895 Textentry (
4896 (":", E.s, None, linknentry,
4897 linknact (fun under -> selstring (undertext under)), false),
4898 (fun _ ->
4899 state.glinks <- false;
4900 state.mode <- mode)
4902 state.text <- E.s;
4903 G.postRedisplay "view:linkent"
4905 | Ascii 'a' ->
4906 begin match state.autoscroll with
4907 | Some step ->
4908 conf.autoscrollstep <- step;
4909 state.autoscroll <- None
4910 | None ->
4911 state.autoscroll <- Some conf.autoscrollstep;
4912 state.slideshow <- state.slideshow land lnot 2
4915 | Ascii 'p' when ctrl ->
4916 launchpath () (* XXX where do error messages go? *)
4918 | Ascii 'P' ->
4919 setpresentationmode (not conf.presentation);
4920 showtext ' ' ("presentation mode " ^
4921 if conf.presentation then "on" else "off");
4923 | Ascii 'f' ->
4924 if List.mem Wsi.Fullscreen state.winstate
4925 then Wsi.reshape conf.cwinw conf.cwinh
4926 else Wsi.fullscreen ()
4928 | Ascii ('p'|'N') ->
4929 search state.searchpattern false
4931 | Ascii 'n' | Fn 3 ->
4932 search state.searchpattern true
4934 | Ascii 't' ->
4935 begin match state.layout with
4936 | [] -> ()
4937 | l :: _ ->
4938 gotoghyll (getpagey l.pageno)
4941 | Ascii ' ' ->
4942 nextpage ()
4944 | Delete ->
4945 prevpage ()
4947 | Ascii '=' ->
4948 showtext ' ' (describe_layout state.layout);
4950 | Ascii 'w' ->
4951 begin match state.layout with
4952 | [] -> ()
4953 | l :: _ ->
4954 Wsi.reshape l.pagew l.pageh;
4955 G.postRedisplay "w"
4958 | Ascii '\'' ->
4959 enterbookmarkmode ()
4961 | Ascii 'h' | Fn 1 ->
4962 enterhelpmode ()
4964 | Ascii 'i' ->
4965 enterinfomode ()
4967 | Ascii 'e' when Buffer.length state.errmsgs > 0 ->
4968 entermsgsmode ()
4970 | Ascii 'm' ->
4971 let ondone s =
4972 match state.layout with
4973 | l :: _ ->
4974 if nonemptystr s
4975 then
4976 state.bookmarks <-
4977 (s, 0, Oanchor (getanchor1 l)) :: state.bookmarks
4978 | _ -> ()
4980 enttext ("bookmark: ", E.s, None, textentry, ondone, true)
4982 | Ascii '~' ->
4983 quickbookmark ();
4984 showtext ' ' "Quick bookmark added";
4986 | Ascii 'z' ->
4987 begin match state.layout with
4988 | l :: _ ->
4989 let rect = getpdimrect l.pagedimno in
4990 let w, h =
4991 if conf.crophack
4992 then
4993 (truncate (1.8 *. (rect.(1) -. rect.(0))),
4994 truncate (1.2 *. (rect.(3) -. rect.(0))))
4995 else
4996 (truncate (rect.(1) -. rect.(0)),
4997 truncate (rect.(3) -. rect.(0)))
4999 let w = truncate ((float w)*.conf.zoom)
5000 and h = truncate ((float h)*.conf.zoom) in
5001 if w != 0 && h != 0
5002 then (
5003 state.anchor <- getanchor ();
5004 Wsi.reshape w (h + conf.interpagespace)
5006 G.postRedisplay "z";
5008 | [] -> ()
5011 | Ascii 'x' -> state.roam ()
5013 | Ascii ('<'|'>' as c) ->
5014 reqlayout
5015 (conf.angle + (if c = '>' then 30 else -30)) conf.fitmodel
5017 | Ascii ('['|']' as c) ->
5018 conf.colorscale <-
5019 bound (conf.colorscale +. (if c = ']' then 0.1 else -0.1)) 0.0 1.0;
5020 G.postRedisplay "brightness";
5022 | Ascii 'c' when state.mode = View ->
5023 if Wsi.withalt mask
5024 then (
5025 if conf.zoom > 1.0
5026 then
5027 let m = (state.winw - state.w) / 2 in
5028 gotoxy_and_clear_text m state.y
5030 else
5031 let (c, a, b), z =
5032 match state.prevcolumns with
5033 | None -> (1, 0, 0), 1.0
5034 | Some (columns, z) ->
5035 let cab =
5036 match columns with
5037 | Csplit (c, _) -> -c, 0, 0
5038 | Cmulti ((c, a, b), _) -> c, a, b
5039 | Csingle _ -> 1, 0, 0
5041 cab, z
5043 setcolumns View c a b;
5044 setzoom z
5046 | Down | Up when ctrl && Wsi.withshift mask ->
5047 let zoom, x = state.prevzoom in
5048 setzoom zoom;
5049 state.x <- x;
5051 | Ascii 'k' | Up ->
5052 begin match state.autoscroll with
5053 | None ->
5054 begin match state.mode with
5055 | Birdseye beye -> upbirdseye 1 beye
5056 | Textentry _ | View | LinkNav _ ->
5057 if ctrl
5058 then gotoxy_and_clear_text state.x (clamp ~-(state.winh/2))
5059 else (
5060 if not (Wsi.withshift mask) && conf.presentation
5061 then prevpage ()
5062 else gotoghyll1 true (clamp (-conf.scrollstep))
5065 | Some n ->
5066 setautoscrollspeed n false
5069 | Ascii 'j' | Down ->
5070 begin match state.autoscroll with
5071 | None ->
5072 begin match state.mode with
5073 | Birdseye beye -> downbirdseye 1 beye
5074 | Textentry _ | View | LinkNav _ ->
5075 if ctrl
5076 then gotoxy_and_clear_text state.x (clamp (state.winh/2))
5077 else (
5078 if not (Wsi.withshift mask) && conf.presentation
5079 then nextpage ()
5080 else gotoghyll1 true (clamp (conf.scrollstep))
5083 | Some n ->
5084 setautoscrollspeed n true
5087 | Left | Right when not (Wsi.withalt mask) ->
5088 if canpan ()
5089 then
5090 let dx =
5091 if ctrl
5092 then state.winw / 2
5093 else conf.hscrollstep
5095 let dx =
5096 let pv = Wsi.kc2kt key in
5097 if pv = Keys.Left then dx else -dx
5099 gotoxy_and_clear_text (panbound (state.x + dx)) state.y
5100 else (
5101 state.text <- E.s;
5102 G.postRedisplay "left/right"
5105 | Prior ->
5106 let y =
5107 if ctrl
5108 then
5109 match state.layout with
5110 | [] -> state.y
5111 | l :: _ -> state.y - l.pagey
5112 else
5113 clamp (pgscale (-state.winh))
5115 gotoghyll y
5117 | Next ->
5118 let y =
5119 if ctrl
5120 then
5121 match List.rev state.layout with
5122 | [] -> state.y
5123 | l :: _ -> getpagey l.pageno
5124 else
5125 clamp (pgscale state.winh)
5127 gotoghyll y
5129 | Ascii 'g' | Home ->
5130 addnav ();
5131 gotoghyll 0
5132 | Ascii 'G' | End ->
5133 addnav ();
5134 gotoghyll (clamp state.maxy)
5136 | Right when Wsi.withalt mask ->
5137 addnavnorc ();
5138 gotoghyll (getnav 1)
5139 | Left when Wsi.withalt mask ->
5140 addnavnorc ();
5141 gotoghyll (getnav ~-1)
5143 | Ascii 'r' ->
5144 reload ()
5146 | Ascii 'v' when conf.debug ->
5147 state.rects <- [];
5148 List.iter (fun l ->
5149 match getopaque l.pageno with
5150 | None -> ()
5151 | Some opaque ->
5152 let x0, y0, x1, y1 = pagebbox opaque in
5153 let rect = (float x0, float y0,
5154 float x1, float y0,
5155 float x1, float y1,
5156 float x0, float y1) in
5157 debugrect rect;
5158 let color = (0.0, 0.0, 1.0 /. (l.pageno mod 3 |> float), 0.5) in
5159 state.rects <- (l.pageno, color, rect) :: state.rects;
5160 ) state.layout;
5161 G.postRedisplay "v";
5163 | Ascii '|' ->
5164 let mode = state.mode in
5165 let cmd = ref E.s in
5166 let onleave = function
5167 | Cancel -> state.mode <- mode
5168 | Confirm ->
5169 List.iter (fun l ->
5170 match getopaque l.pageno with
5171 | Some opaque -> pipesel opaque !cmd
5172 | None -> ()) state.layout;
5173 state.mode <- mode
5175 let ondone s =
5176 cbput state.hists.sel s;
5177 cmd := s
5179 let te =
5180 "| ", !cmd, Some (onhist state.hists.sel), textentry, ondone, true
5182 G.postRedisplay "|";
5183 state.mode <- Textentry (te, onleave);
5185 | (Ascii _|Fn _|Enter|Left|Right|Code _|Ctrl _) ->
5186 vlog "huh? %s" (Wsi.keyname key)
5189 let linknavkeyboard key mask linknav =
5190 let pv = Wsi.kc2kt key in
5191 let getpage pageno =
5192 let rec loop = function
5193 | [] -> None
5194 | l :: _ when l.pageno = pageno -> Some l
5195 | _ :: rest -> loop rest
5196 in loop state.layout
5198 let doexact (pageno, n) =
5199 match getopaque pageno, getpage pageno with
5200 | Some opaque, Some l ->
5201 if pv = Keys.Enter
5202 then
5203 let under = getlink opaque n in
5204 G.postRedisplay "link gotounder";
5205 gotounder under;
5206 state.mode <- View;
5207 else
5208 let opt, dir =
5209 let open Keys in
5210 match pv with
5211 | Home -> Some (findlink opaque LDfirst), -1
5212 | End -> Some (findlink opaque LDlast), 1
5213 | Left -> Some (findlink opaque (LDleft n)), -1
5214 | Right -> Some (findlink opaque (LDright n)), 1
5215 | Up -> Some (findlink opaque (LDup n)), -1
5216 | Down -> Some (findlink opaque (LDdown n)), 1
5218 | Delete|Escape|Insert|Enter|Next|Prior|Ascii _
5219 | Code _|Fn _|Ctrl _|Backspace -> None, 0
5221 let pwl l dir =
5222 begin match findpwl l.pageno dir with
5223 | Pwlnotfound -> ()
5224 | Pwl pageno ->
5225 let notfound dir =
5226 state.mode <- LinkNav (Ltgendir dir);
5227 let y, h = getpageyh pageno in
5228 let y =
5229 if dir < 0
5230 then y + h - state.winh
5231 else y
5233 gotoxy state.x y
5235 begin match getopaque pageno, getpage pageno with
5236 | Some opaque, Some _ ->
5237 let link =
5238 let ld = if dir > 0 then LDfirst else LDlast in
5239 findlink opaque ld
5241 begin match link with
5242 | Lfound m ->
5243 showlinktype (getlink opaque m);
5244 state.mode <- LinkNav (Ltexact (pageno, m));
5245 G.postRedisplay "linknav jpage";
5246 | Lnotfound -> notfound dir
5247 end;
5248 | _ -> notfound dir
5249 end;
5250 end;
5252 begin match opt with
5253 | Some Lnotfound -> pwl l dir;
5254 | Some (Lfound m) ->
5255 if m = n
5256 then pwl l dir
5257 else (
5258 let _, y0, _, y1 = getlinkrect opaque m in
5259 if y0 < l.pagey
5260 then gotopage1 l.pageno y0
5261 else (
5262 let d = fstate.fontsize + 1 in
5263 if y1 - l.pagey > l.pagevh - d
5264 then gotopage1 l.pageno (y1 - state.winh + d)
5265 else G.postRedisplay "linknav";
5267 showlinktype (getlink opaque m);
5268 state.mode <- LinkNav (Ltexact (l.pageno, m));
5271 | None -> viewkeyboard key mask
5272 end;
5273 | _ -> viewkeyboard key mask
5275 if pv = Keys.Insert
5276 then (
5277 begin match linknav with
5278 | Ltexact pa -> state.lnava <- Some pa
5279 | Ltgendir _ | Ltnotready _ -> ()
5280 end;
5281 state.mode <- View;
5282 G.postRedisplay "leave linknav"
5284 else
5285 match linknav with
5286 | Ltgendir _ | Ltnotready _ -> viewkeyboard key mask
5287 | Ltexact exact -> doexact exact
5290 let keyboard key mask =
5291 if (key = Char.code 'g' && Wsi.withctrl mask) && not (istextentry state.mode)
5292 then wcmd "interrupt"
5293 else state.uioh <- state.uioh#key key mask
5296 let birdseyekeyboard key mask
5297 ((oconf, leftx, pageno, hooverpageno, anchor) as beye) =
5298 let incr =
5299 match conf.columns with
5300 | Csingle _ -> 1
5301 | Cmulti ((c, _, _), _) -> c
5302 | Csplit _ -> failwith "bird's eye split mode"
5304 let pgh layout = List.fold_left
5305 (fun m l -> max l.pageh m) state.winh layout in
5306 let open Keys in
5307 match Wsi.kc2kt key with
5308 | Ascii 'l' when Wsi.withctrl mask ->
5309 let y, h = getpageyh pageno in
5310 let top = (state.winh - h) / 2 in
5311 gotoxy state.x (max 0 (y - top))
5312 | Enter -> leavebirdseye beye false
5313 | Escape -> leavebirdseye beye true
5314 | Up -> upbirdseye incr beye
5315 | Down -> downbirdseye incr beye
5316 | Left -> upbirdseye 1 beye
5317 | Right -> downbirdseye 1 beye
5319 | Prior ->
5320 begin match state.layout with
5321 | l :: _ ->
5322 if l.pagey != 0
5323 then (
5324 state.mode <- Birdseye (
5325 oconf, leftx, l.pageno, hooverpageno, anchor
5327 gotopage1 l.pageno 0;
5329 else (
5330 let layout = layout state.x (state.y-state.winh)
5331 state.winw
5332 (pgh state.layout) in
5333 match layout with
5334 | [] -> gotoxy state.x (clamp (-state.winh))
5335 | l :: _ ->
5336 state.mode <- Birdseye (
5337 oconf, leftx, l.pageno, hooverpageno, anchor
5339 gotopage1 l.pageno 0
5342 | [] -> gotoxy state.x (clamp (-state.winh))
5343 end;
5345 | Next ->
5346 begin match List.rev state.layout with
5347 | l :: _ ->
5348 let layout = layout state.x
5349 (state.y + (pgh state.layout))
5350 state.winw state.winh in
5351 begin match layout with
5352 | [] ->
5353 let incr = l.pageh - l.pagevh in
5354 if incr = 0
5355 then (
5356 state.mode <-
5357 Birdseye (
5358 oconf, leftx, state.pagecount - 1, hooverpageno, anchor
5360 G.postRedisplay "birdseye pagedown";
5362 else gotoxy state.x (clamp (incr + conf.interpagespace*2));
5364 | l :: _ ->
5365 state.mode <-
5366 Birdseye (oconf, leftx, l.pageno, hooverpageno, anchor);
5367 gotopage1 l.pageno 0;
5370 | [] -> gotoxy state.x (clamp state.winh)
5371 end;
5373 | Home ->
5374 state.mode <- Birdseye (oconf, leftx, 0, hooverpageno, anchor);
5375 gotopage1 0 0
5377 | End ->
5378 let pageno = state.pagecount - 1 in
5379 state.mode <- Birdseye (oconf, leftx, pageno, hooverpageno, anchor);
5380 if not (pagevisible state.layout pageno)
5381 then
5382 let h =
5383 match List.rev state.pdims with
5384 | [] -> state.winh
5385 | (_, _, h, _) :: _ -> h
5387 gotoxy
5388 state.x
5389 (max 0 (getpagey pageno - (state.winh - h - conf.interpagespace)))
5390 else G.postRedisplay "birdseye end";
5392 | Delete|Insert|Ascii _|Code _|Ctrl _|Fn _|Backspace -> viewkeyboard key mask
5395 let drawpage l =
5396 let color =
5397 match state.mode with
5398 | Textentry _ -> scalecolor 0.4
5399 | LinkNav _ | View -> scalecolor 1.0
5400 | Birdseye (_, _, pageno, hooverpageno, _) ->
5401 if l.pageno = hooverpageno
5402 then scalecolor 0.9
5403 else (
5404 if l.pageno = pageno
5405 then (
5406 let c = scalecolor 1.0 in
5407 GlDraw.color c;
5408 GlDraw.line_width 3.0;
5409 let dispx = l.pagedispx in
5410 linerect
5411 (float (dispx-1)) (float (l.pagedispy-1))
5412 (float (dispx+l.pagevw+1))
5413 (float (l.pagedispy+l.pagevh+1))
5415 GlDraw.line_width 1.0;
5418 else scalecolor 0.8
5421 drawtiles l color;
5424 let postdrawpage l linkindexbase =
5425 match getopaque l.pageno with
5426 | Some opaque ->
5427 if tileready l l.pagex l.pagey
5428 then
5429 let x = l.pagedispx - l.pagex
5430 and y = l.pagedispy - l.pagey in
5431 let hlmask =
5432 match conf.columns with
5433 | Csingle _ | Cmulti _ ->
5434 (if conf.hlinks then 1 else 0)
5435 + (if state.glinks
5436 && not (isbirdseye state.mode) then 2 else 0)
5437 | Csplit _ -> 0
5439 let s =
5440 match state.mode with
5441 | Textentry ((_, s, _, _, _, _), _) when state.glinks -> s
5442 | Textentry _
5443 | Birdseye _
5444 | View
5445 | LinkNav _ -> E.s
5447 Hashtbl.find_all state.prects l.pageno |>
5448 List.iter (fun vals -> drawprect opaque x y vals);
5449 let n = postprocess opaque hlmask x y (linkindexbase, s, conf.hfsize) in
5450 if n < 0
5451 then (state.redisplay <- true; 0)
5452 else n
5453 else 0
5454 | _ -> 0
5457 let scrollindicator () =
5458 let sbw, ph, sh = state.uioh#scrollph in
5459 let sbh, pw, sw = state.uioh#scrollpw in
5461 let x0,x1,hx0 =
5462 if conf.leftscroll
5463 then (0, sbw, sbw)
5464 else ((state.winw - sbw), state.winw, 0)
5467 Gl.enable `blend;
5468 GlFunc.blend_func ~src:`src_alpha ~dst:`one_minus_src_alpha;
5469 let (r, g, b, alpha) = conf.sbarcolor in
5470 GlDraw.color (r, g, b) ~alpha;
5471 filledrect (float x0) 0. (float x1) (float state.winh);
5472 filledrect
5473 (float hx0) (float (state.winh - sbh))
5474 (float (hx0 + state.winw)) (float state.winh);
5475 let (r, g, b, alpha) = conf.sbarhndlcolor in
5476 GlDraw.color (r, g, b) ~alpha;
5478 filledrect (float x0) ph (float x1) (ph +. sh);
5479 let pw = pw +. float hx0 in
5480 filledrect pw (float (state.winh - sbh)) (pw +. sw) (float state.winh);
5481 Gl.disable `blend;
5484 let showsel () =
5485 match state.mstate with
5486 | Mnone | Mscrolly | Mscrollx | Mpan _ | Mzoom _ | Mzoomrect _ ->
5489 | Msel ((x0, y0), (x1, y1)) ->
5490 let identify opaque l px py = Some (opaque, l.pageno, px, py) in
5491 let o0,n0,px0,py0 = onppundermouse identify x0 y0 (~< E.s, -1, 0, 0) in
5492 let _o1,n1,px1,py1 = onppundermouse identify x1 y1 (~< E.s, -1, 0, 0) in
5493 if n0 != -1 && n0 = n1 then seltext o0 (px0, py0, px1, py1);
5496 let showrects =
5497 function [] -> ()
5498 | rects ->
5499 Gl.enable `blend;
5500 GlDraw.color (0.0, 0.0, 1.0) ~alpha:0.5;
5501 GlFunc.blend_func ~src:`src_alpha ~dst:`one_minus_src_alpha;
5502 List.iter
5503 (fun (pageno, c, (x0, y0, x1, y1, x2, y2, x3, y3)) ->
5504 List.iter (fun l ->
5505 if l.pageno = pageno
5506 then (
5507 let dx = float (l.pagedispx - l.pagex) in
5508 let dy = float (l.pagedispy - l.pagey) in
5509 let r, g, b, alpha = c in
5510 GlDraw.color (r, g, b) ~alpha;
5511 filledrect2 (x0+.dx) (y0+.dy)
5512 (x1+.dx) (y1+.dy)
5513 (x3+.dx) (y3+.dy)
5514 (x2+.dx) (y2+.dy);
5516 ) state.layout
5517 ) rects;
5518 Gl.disable `blend;
5521 let display () =
5522 GlDraw.color (scalecolor2 conf.bgcolor);
5523 GlClear.color (scalecolor2 conf.bgcolor);
5524 GlClear.clear [`color];
5525 List.iter drawpage state.layout;
5526 let rects =
5527 match state.mode with
5528 | LinkNav (Ltexact (pageno, linkno)) ->
5529 begin match getopaque pageno with
5530 | Some opaque ->
5531 let x0, y0, x1, y1 = getlinkrect opaque linkno in
5532 let color = (0.0, 0.0, 0.5, 0.5) in
5533 (pageno, color,
5534 (float x0, float y0,
5535 float x1, float y0,
5536 float x1, float y1,
5537 float x0, float y1)
5538 ) :: state.rects
5539 | None -> state.rects
5541 | LinkNav (Ltgendir _) | LinkNav (Ltnotready _)
5542 | Birdseye _
5543 | Textentry _
5544 | View -> state.rects
5546 showrects rects;
5547 let rec postloop linkindexbase = function
5548 | l :: rest ->
5549 let linkindexbase = linkindexbase + postdrawpage l linkindexbase in
5550 postloop linkindexbase rest
5551 | [] -> ()
5553 showsel ();
5554 postloop 0 state.layout;
5555 state.uioh#display;
5556 begin match state.mstate with
5557 | Mzoomrect ((x0, y0), (x1, y1)) ->
5558 Gl.enable `blend;
5559 GlDraw.color (0.3, 0.3, 0.3) ~alpha:0.5;
5560 GlFunc.blend_func ~src:`src_alpha ~dst:`one_minus_src_alpha;
5561 filledrect (float x0) (float y0) (float x1) (float y1);
5562 Gl.disable `blend;
5563 | Msel _
5564 | Mpan _
5565 | Mscrolly | Mscrollx
5566 | Mzoom _
5567 | Mnone -> ()
5568 end;
5569 enttext ();
5570 scrollindicator ();
5571 Wsi.swapb ();
5574 let zoomrect x y x1 y1 =
5575 let x0 = min x x1
5576 and x1 = max x x1
5577 and y0 = min y y1 in
5578 let zoom = (float state.w) /. float (x1 - x0) in
5579 let margin =
5580 let simple () =
5581 if state.w < state.winw
5582 then (state.winw - state.w) / 2
5583 else 0
5585 match conf.fitmodel with
5586 | FitWidth | FitProportional -> simple ()
5587 | FitPage ->
5588 match conf.columns with
5589 | Csplit _ ->
5590 onppundermouse (fun _ l _ _ -> Some l.pagedispx) x0 y0 x0
5591 | Cmulti _ | Csingle _ -> simple ()
5593 gotoxy ((state.x + margin) - x0) (state.y + y0);
5594 state.anchor <- getanchor ();
5595 setzoom zoom;
5596 resetmstate ();
5599 let annot inline x y =
5600 match unproject x y with
5601 | Some (opaque, n, ux, uy) ->
5602 let add text =
5603 addannot opaque ux uy text;
5604 wcmd "freepage %s" (~> opaque);
5605 Hashtbl.remove state.pagemap (n, state.gen);
5606 flushtiles ();
5607 gotoxy state.x state.y
5609 if inline
5610 then
5611 let ondone s = add s in
5612 let mode = state.mode in
5613 state.mode <- Textentry (
5614 ("annotation: ", E.s, None, textentry, ondone, true),
5615 fun _ -> state.mode <- mode);
5616 state.text <- E.s;
5617 enttext ();
5618 G.postRedisplay "annot"
5619 else
5620 add @@ getusertext E.s
5621 | _ -> ()
5624 let zoomblock x y =
5625 let g opaque l px py =
5626 match rectofblock opaque px py with
5627 | Some a ->
5628 let x0 = a.(0) -. 20. in
5629 let x1 = a.(1) +. 20. in
5630 let y0 = a.(2) -. 20. in
5631 let zoom = (float state.w) /. (x1 -. x0) in
5632 let pagey = getpagey l.pageno in
5633 let margin = (state.w - l.pagew)/2 in
5634 let nx = -truncate x0 - margin in
5635 gotoxy_and_clear_text nx (pagey + truncate y0);
5636 state.anchor <- getanchor ();
5637 setzoom zoom;
5638 None
5639 | None -> None
5641 match conf.columns with
5642 | Csplit _ ->
5643 impmsg "block zooming does not work properly in split columns mode"
5644 | Cmulti _ | Csingle _ -> onppundermouse g x y ()
5647 let scrollx x =
5648 let winw = state.winw - 1 in
5649 let s = float x /. float winw in
5650 let destx = truncate (float (state.w + winw) *. s) in
5651 gotoxy_and_clear_text (winw - destx) state.y;
5652 state.mstate <- Mscrollx;
5655 let scrolly y =
5656 let s = float y /. float state.winh in
5657 let desty = truncate (s *. float (maxy ())) in
5658 gotoxy_and_clear_text state.x desty;
5659 state.mstate <- Mscrolly;
5662 let viewmulticlick clicks x y mask =
5663 let g opaque l px py =
5664 let mark =
5665 match clicks with
5666 | 2 -> Mark_word
5667 | 3 -> Mark_line
5668 | 4 -> Mark_block
5669 | _ -> Mark_page
5671 if markunder opaque px py mark
5672 then (
5673 Some (fun () ->
5674 let dopipe cmd =
5675 match getopaque l.pageno with
5676 | None -> ()
5677 | Some opaque -> pipesel opaque cmd
5679 state.roam <- (fun () -> dopipe conf.paxcmd);
5680 if not (Wsi.withctrl mask) then dopipe conf.selcmd;
5683 else None
5685 G.postRedisplay "viewmulticlick";
5686 onppundermouse g x y (fun () -> impmsg "nothing to select") ();
5689 let canselect () =
5690 match conf.columns with
5691 | Csplit _ -> false
5692 | Csingle _ | Cmulti _ -> conf.angle mod 360 = 0
5695 let viewmouse button down x y mask =
5696 match button with
5697 | n when (n == 4 || n == 5) && not down ->
5698 if Wsi.withctrl mask
5699 then (
5700 let incr =
5701 if n = 5
5702 then if conf.zoom +. 0.01 > 0.1 then 0.1 else 0.01
5703 else if conf.zoom -. 0.1 < 0.1 then -0.01 else -0.1
5705 let fx, fy =
5706 match state.mstate with
5707 | Mzoom (oldn, _, pos) when n = oldn -> pos
5708 | Mzoomrect _ | Mnone | Mpan _
5709 | Msel _ | Mscrollx | Mscrolly | Mzoom _ -> (x, y)
5711 let zoom = conf.zoom -. incr in
5712 state.mstate <- Mzoom (n, 0, (x, y));
5713 if false && abs (fx - x) > 5 || abs (fy - y) > 5
5714 then pivotzoom ~x ~y zoom
5715 else pivotzoom zoom
5717 else (
5718 match state.autoscroll with
5719 | Some step -> setautoscrollspeed step (n=4)
5720 | None ->
5721 if conf.wheelbypage || conf.presentation
5722 then (
5723 if n = 4
5724 then prevpage ()
5725 else nextpage ()
5727 else
5728 let incr =
5729 if n = 4
5730 then -conf.scrollstep
5731 else conf.scrollstep
5733 let incr = incr * 2 in
5734 let y = clamp incr in
5735 gotoxy_and_clear_text state.x y
5738 | n when (n = 6 || n = 7) && not down && canpan () ->
5739 let x =
5740 panbound (state.x + (if n = 7 then -2 else 2) * conf.hscrollstep) in
5741 gotoxy_and_clear_text x state.y
5743 | 1 when Wsi.withshift mask ->
5744 state.mstate <- Mnone;
5745 if not down
5746 then (
5747 match unproject x y with
5748 | None -> ()
5749 | Some (_, pageno, ux, uy) ->
5750 let cmd = Printf.sprintf
5751 "%s %s %d %d %d"
5752 conf.stcmd state.path pageno ux uy
5754 match spawn cmd [] with
5755 | exception exn ->
5756 impmsg "execution of synctex command(%S) failed: %S"
5757 conf.stcmd @@ exntos exn
5758 | _pid -> ()
5761 | 1 when Wsi.withctrl mask ->
5762 if down
5763 then (
5764 Wsi.setcursor Wsi.CURSOR_FLEUR;
5765 state.mstate <- Mpan (x, y)
5767 else
5768 state.mstate <- Mnone
5770 | 3 ->
5771 if down
5772 then (
5773 if Wsi.withshift mask
5774 then (
5775 annot conf.annotinline x y;
5776 G.postRedisplay "addannot"
5778 else
5779 let p = (x, y) in
5780 Wsi.setcursor Wsi.CURSOR_CYCLE;
5781 state.mstate <- Mzoomrect (p, p)
5783 else (
5784 match state.mstate with
5785 | Mzoomrect ((x0, y0), _) ->
5786 if abs (x-x0) > 10 && abs (y - y0) > 10
5787 then zoomrect x0 y0 x y
5788 else (
5789 resetmstate ();
5790 G.postRedisplay "kill accidental zoom rect";
5792 | Msel _
5793 | Mpan _
5794 | Mscrolly | Mscrollx
5795 | Mzoom _
5796 | Mnone -> resetmstate ()
5799 | 1 when vscrollhit x ->
5800 if down
5801 then
5802 let _, position, sh = state.uioh#scrollph in
5803 if y > truncate position && y < truncate (position +. sh)
5804 then state.mstate <- Mscrolly
5805 else scrolly y
5806 else
5807 state.mstate <- Mnone
5809 | 1 when y > state.winh - hscrollh () ->
5810 if down
5811 then
5812 let _, position, sw = state.uioh#scrollpw in
5813 if x > truncate position && x < truncate (position +. sw)
5814 then state.mstate <- Mscrollx
5815 else scrollx x
5816 else
5817 state.mstate <- Mnone
5819 | 1 when state.bzoom -> if not down then zoomblock x y
5821 | 1 ->
5822 let dest = if down then getunder x y else Unone in
5823 begin match dest with
5824 | Ulinkuri _ ->
5825 gotounder dest
5827 | Unone when down ->
5828 Wsi.setcursor Wsi.CURSOR_FLEUR;
5829 state.mstate <- Mpan (x, y);
5831 | Uannotation (opaque, slinkindex) -> enterannotmode opaque slinkindex
5833 | Unone | Utext _ ->
5834 if down
5835 then (
5836 if canselect ()
5837 then (
5838 state.mstate <- Msel ((x, y), (x, y));
5839 G.postRedisplay "mouse select";
5842 else (
5843 match state.mstate with
5844 | Mnone -> ()
5846 | Mzoom _ | Mscrollx | Mscrolly ->
5847 state.mstate <- Mnone
5849 | Mzoomrect ((x0, y0), _) ->
5850 zoomrect x0 y0 x y
5852 | Mpan _ ->
5853 Wsi.setcursor Wsi.CURSOR_INHERIT;
5854 state.mstate <- Mnone
5856 | Msel ((x0, y0), (x1, y1)) ->
5857 let rec loop = function
5858 | [] -> ()
5859 | l :: rest ->
5860 let inside =
5861 let a0 = l.pagedispy in
5862 let a1 = a0 + l.pagevh in
5863 let b0 = l.pagedispx in
5864 let b1 = b0 + l.pagevw in
5865 ((y0 >= a0 && y0 <= a1) || (y1 >= a0 && y1 <= a1))
5866 && ((x0 >= b0 && x0 <= b1) || (x1 >= b0 && x1 <= b1))
5868 if inside
5869 then
5870 match getopaque l.pageno with
5871 | Some opaque ->
5872 let dosel cmd () =
5873 pipef ~closew:false "Msel"
5874 (fun w ->
5875 copysel w opaque;
5876 G.postRedisplay "Msel") cmd
5878 dosel conf.selcmd ();
5879 state.roam <- dosel conf.paxcmd;
5880 | None -> ()
5881 else loop rest
5883 loop state.layout;
5884 resetmstate ();
5888 | _ -> ()
5891 let birdseyemouse button down x y mask
5892 (conf, leftx, _, hooverpageno, anchor) =
5893 match button with
5894 | 1 when down ->
5895 let rec loop = function
5896 | [] -> ()
5897 | l :: rest ->
5898 if y > l.pagedispy && y < l.pagedispy + l.pagevh
5899 && x > l.pagedispx && x < l.pagedispx + l.pagevw
5900 then (
5901 leavebirdseye (conf, leftx, l.pageno, hooverpageno, anchor) false;
5903 else loop rest
5905 loop state.layout
5906 | 3 -> ()
5907 | _ -> viewmouse button down x y mask
5910 let uioh = object
5911 method display = ()
5913 method key key mask =
5914 begin match state.mode with
5915 | Textentry textentry -> textentrykeyboard key mask textentry
5916 | Birdseye birdseye -> birdseyekeyboard key mask birdseye
5917 | View -> viewkeyboard key mask
5918 | LinkNav linknav -> linknavkeyboard key mask linknav
5919 end;
5920 state.uioh
5922 method button button bstate x y mask =
5923 begin match state.mode with
5924 | LinkNav _ | View -> viewmouse button bstate x y mask
5925 | Birdseye beye -> birdseyemouse button bstate x y mask beye
5926 | Textentry _ -> ()
5927 end;
5928 state.uioh
5930 method multiclick clicks x y mask =
5931 begin match state.mode with
5932 | LinkNav _ | View -> viewmulticlick clicks x y mask
5933 | Birdseye _ | Textentry _ -> ()
5934 end;
5935 state.uioh
5937 method motion x y =
5938 begin match state.mode with
5939 | Textentry _ -> ()
5940 | View | Birdseye _ | LinkNav _ ->
5941 match state.mstate with
5942 | Mzoom _ | Mnone -> ()
5944 | Mpan (x0, y0) ->
5945 let dx = x - x0
5946 and dy = y0 - y in
5947 state.mstate <- Mpan (x, y);
5948 let x = if canpan () then panbound (state.x + dx) else state.x in
5949 let y = clamp dy in
5950 gotoxy_and_clear_text x y
5952 | Msel (a, _) ->
5953 state.mstate <- Msel (a, (x, y));
5954 G.postRedisplay "motion select";
5956 | Mscrolly ->
5957 let y = min state.winh (max 0 y) in
5958 scrolly y
5960 | Mscrollx ->
5961 let x = min state.winw (max 0 x) in
5962 scrollx x
5964 | Mzoomrect (p0, _) ->
5965 state.mstate <- Mzoomrect (p0, (x, y));
5966 G.postRedisplay "motion zoomrect";
5967 end;
5968 state.uioh
5970 method pmotion x y =
5971 begin match state.mode with
5972 | Birdseye (conf, leftx, pageno, hooverpageno, anchor) ->
5973 let rec loop = function
5974 | [] ->
5975 if hooverpageno != -1
5976 then (
5977 state.mode <- Birdseye (conf, leftx, pageno, -1, anchor);
5978 G.postRedisplay "pmotion birdseye no hoover";
5980 | l :: rest ->
5981 if y > l.pagedispy && y < l.pagedispy + l.pagevh
5982 && x > l.pagedispx && x < l.pagedispx + l.pagevw
5983 then (
5984 state.mode <- Birdseye (conf, leftx, pageno, l.pageno, anchor);
5985 G.postRedisplay "pmotion birdseye hoover";
5987 else loop rest
5989 loop state.layout
5991 | Textentry _ -> ()
5993 | LinkNav _ | View ->
5994 match state.mstate with
5995 | Mpan _ | Msel _ | Mzoom _ | Mscrolly | Mscrollx | Mzoomrect _ -> ()
5996 | Mnone ->
5997 updateunder x y;
5998 if canselect ()
5999 then
6000 match conf.pax with
6001 | None -> ()
6002 | Some past ->
6003 let now = now () in
6004 let delta = now -. past in
6005 if delta > 0.01
6006 then paxunder x y
6007 else conf.pax <- Some now
6008 end;
6009 state.uioh
6011 method infochanged _ = ()
6013 method scrollph =
6014 let maxy = maxy () in
6015 let p, h =
6016 if maxy = 0
6017 then 0.0, float state.winh
6018 else scrollph state.y maxy
6020 vscrollw (), p, h
6022 method scrollpw =
6023 let fwinw = float (state.winw - vscrollw ()) in
6024 let sw =
6025 let sw = fwinw /. float state.w in
6026 let sw = fwinw *. sw in
6027 max sw (float conf.scrollh)
6029 let position =
6030 let maxx = state.w + state.winw in
6031 let x = state.winw - state.x in
6032 let percent = float x /. float maxx in
6033 (fwinw -. sw) *. percent
6035 hscrollh (), position, sw
6037 method modehash =
6038 let modename =
6039 match state.mode with
6040 | LinkNav _ -> "links"
6041 | Textentry _ -> "textentry"
6042 | Birdseye _ -> "birdseye"
6043 | View -> "view"
6045 findkeyhash conf modename
6047 method eformsgs = true
6048 method alwaysscrolly = false
6049 method scroll dx dy =
6050 let x = if canpan () then panbound (state.x + dx) else state.x in
6051 gotoxy_and_clear_text x (clamp (2 * dy));
6052 state.uioh
6053 method zoom z x y =
6054 pivotzoom ~x ~y (conf.zoom *. exp z);
6055 end;;
6057 let addrect pageno r g b a x0 y0 x1 y1 =
6058 Hashtbl.add state.prects pageno [|r; g; b; a; x0; y0; x1; y1|];
6061 let ract cmds =
6062 let cl = splitatchar cmds ' ' in
6063 let scan s fmt f =
6064 try Scanf.sscanf s fmt f
6065 with exn -> adderrfmt "remote exec" "error processing '%S': %s\n"
6066 cmds @@ exntos exn
6068 let rectx s pageno (r, g, b, a) x0 y0 x1 y1 =
6069 vlog "%s page %d color (%f %f %f %f) x0,y0,x1,y1 = %f %f %f %f"
6070 s pageno r g b a x0 y0 x1 y1;
6071 onpagerect
6072 pageno
6073 (fun w h ->
6074 let _,w1,h1,_ = getpagedim pageno in
6075 let sw = float w1 /. float w
6076 and sh = float h1 /. float h in
6077 let x0s = x0 *. sw
6078 and x1s = x1 *. sw
6079 and y0s = y0 *. sh
6080 and y1s = y1 *. sh in
6081 let rect = (x0s,y0s,x1s,y0s,x1s,y1s,x0s,y1s) in
6082 let color = (r, g, b, a) in
6083 if conf.verbose then debugrect rect;
6084 state.rects <- (pageno, color, rect) :: state.rects;
6085 G.postRedisplay s;
6088 match cl with
6089 | "reload", "" -> reload ()
6090 | "goto", args ->
6091 scan args "%u %f %f"
6092 (fun pageno x y ->
6093 let cmd, _ = state.geomcmds in
6094 if emptystr cmd
6095 then gotopagexy pageno x y
6096 else
6097 let f prevf () =
6098 gotopagexy pageno x y;
6099 prevf ()
6101 state.reprf <- f state.reprf
6103 | "goto1", args -> scan args "%u %f" gotopage
6104 | "gotor", args -> scan args "%S" gotoremote
6105 | "rect", args ->
6106 scan args "%u %u %f %f %f %f"
6107 (fun pageno c x0 y0 x1 y1 ->
6108 let color = (0.0, 0.0, 1.0 /. float c, 0.5) in
6109 rectx "rect" pageno color x0 y0 x1 y1;
6111 | "prect", args ->
6112 scan args "%u %f %f %f %f %f %f %f %f"
6113 (fun pageno r g b alpha x0 y0 x1 y1 ->
6114 addrect pageno r g b alpha x0 y0 x1 y1;
6115 G.postRedisplay "prect"
6117 | "pgoto", args ->
6118 scan args "%u %f %f"
6119 (fun pageno x y ->
6120 let optopaque =
6121 match getopaque pageno with
6122 | Some opaque -> opaque
6123 | None -> ~< E.s
6125 pgoto optopaque pageno x y;
6126 let rec fixx = function
6127 | [] -> ()
6128 | l :: rest ->
6129 if l.pageno = pageno
6130 then gotoxy (state.x - l.pagedispx) state.y
6131 else fixx rest
6133 let layout =
6134 let mult =
6135 match conf.columns with
6136 | Csingle _ | Csplit _ -> 1
6137 | Cmulti ((n, _, _), _) -> n
6139 layout 0 state.y (state.winw * mult) state.winh
6141 fixx layout
6143 | "activatewin", "" -> Wsi.activatewin ()
6144 | "quit", "" -> raise Quit
6145 | "keys", keys ->
6146 begin try
6147 let l = Config.keys_of_string keys in
6148 List.iter (fun (k, m) -> keyboard k m) l
6149 with exn -> adderrfmt "error processing keys" "`%S': %s\n"
6150 cmds @@ exntos exn
6152 | "clearrects", "" ->
6153 Hashtbl.clear state.prects;
6154 G.postRedisplay "clearrects"
6155 | _ ->
6156 adderrfmt "remote command"
6157 "error processing remote command: %S\n" cmds;
6160 let remote =
6161 let scratch = Bytes.create 80 in
6162 let buf = Buffer.create 80 in
6163 fun fd ->
6164 match tempfailureretry (Unix.read fd scratch 0) 80 with
6165 | exception Unix.Unix_error (Unix.EAGAIN, _, _) -> None
6166 | 0 ->
6167 Unix.close fd;
6168 if Buffer.length buf > 0
6169 then (
6170 let s = Buffer.contents buf in
6171 Buffer.clear buf;
6172 ract s;
6174 None
6175 | n ->
6176 let rec eat ppos =
6177 let nlpos =
6178 match Bytes.index_from scratch ppos '\n' with
6179 | pos -> if pos >= n then -1 else pos
6180 | exception Not_found -> -1
6182 if nlpos >= 0
6183 then (
6184 Buffer.add_subbytes buf scratch ppos (nlpos-ppos);
6185 let s = Buffer.contents buf in
6186 Buffer.clear buf;
6187 ract s;
6188 eat (nlpos+1);
6190 else (
6191 Buffer.add_subbytes buf scratch ppos (n-ppos);
6192 Some fd
6194 in eat 0
6197 let remoteopen path =
6198 try Some (Unix.openfile path [Unix.O_NONBLOCK; Unix.O_RDONLY] 0o0)
6199 with exn ->
6200 adderrfmt "remoteopen" "error opening %S: %s" path @@ exntos exn;
6201 None
6204 let () =
6205 let gcconfig = ref false in
6206 let trimcachepath = ref E.s in
6207 let rcmdpath = ref E.s in
6208 let pageno = ref None in
6209 let rootwid = ref 0 in
6210 let openlast = ref false in
6211 let doreap = ref false in
6212 let csspath = ref None in
6213 selfexec := Sys.executable_name;
6214 Arg.parse
6215 (Arg.align
6216 [("-p", Arg.String (fun s -> state.password <- s),
6217 "<password> Set password");
6219 ("-f", Arg.String
6220 (fun s ->
6221 Config.fontpath := s;
6222 selfexec := !selfexec ^ " -f " ^ Filename.quote s;
6224 "<path> Set path to the user interface font");
6226 ("-c", Arg.String
6227 (fun s ->
6228 selfexec := !selfexec ^ " -c " ^ Filename.quote s;
6229 Config.confpath := s),
6230 "<path> Set path to the configuration file");
6232 ("-last", Arg.Set openlast, " Open last document");
6234 ("-page", Arg.Int (fun pageno1 -> pageno := Some (pageno1-1)),
6235 "<page-number> Jump to page");
6237 ("-tcf", Arg.String (fun s -> trimcachepath := s),
6238 "<path> Set path to the trim cache file");
6240 ("-dest", Arg.String (fun s -> state.nameddest <- s),
6241 "<named-destination> Set named destination");
6243 ("-remote", Arg.String (fun s -> rcmdpath := s),
6244 "<path> Set path to the source of remote commands");
6246 ("-gc", Arg.Set gcconfig, " Collect config garbage");
6248 ("-v", Arg.Unit (fun () ->
6249 Printf.printf
6250 "%s\nconfiguration path: %s\n"
6251 (version ())
6252 Config.defconfpath;
6253 exit 0), " Print version and exit");
6255 ("-css", Arg.String (fun s -> csspath := Some s),
6256 "<path> Set path to the style sheet to use with EPUB/HTML");
6258 ("-embed", Arg.Set_int rootwid, "<window-id> Embed into window");
6260 ("-origin", Arg.String (fun s -> state.origin <- s),
6261 "<origin> <undocumented>");
6263 ("-no-title", Arg.Set ignoredoctitlte, " ignore document title");
6264 ("-layout-height", Arg.Set_int layouth,
6265 "<height> layout height html/epub/etc (-1, 0, N)");
6268 (fun s -> state.path <- s)
6269 ("Usage: " ^ Sys.argv.(0) ^ " [options] some.pdf\nOptions:");
6271 let histmode = emptystr state.path && not !openlast in
6273 if not (Config.load !openlast)
6274 then dolog "failed to load configuration";
6276 begin match !pageno with
6277 | Some pageno -> state.anchor <- (pageno, 0.0, 0.0)
6278 | None -> ()
6279 end;
6281 fillhelp ();
6282 if !gcconfig
6283 then (
6284 Config.gc ();
6285 exit 0
6288 let mu =
6289 object (self)
6290 val mutable m_clicks = 0
6291 val mutable m_click_x = 0
6292 val mutable m_click_y = 0
6293 val mutable m_lastclicktime = infinity
6295 method private cleanup =
6296 state.roam <- noroam;
6297 Hashtbl.iter (fun _ opaque -> clearmark opaque) state.pagemap
6298 method expose = G.postRedisplay "expose"
6299 method visible v =
6300 let name =
6301 match v with
6302 | Wsi.Unobscured -> "unobscured"
6303 | Wsi.PartiallyObscured -> "partiallyobscured"
6304 | Wsi.FullyObscured -> "fullyobscured"
6306 vlog "visibility change %s" name
6307 method display = display ()
6308 method map mapped = vlog "mapped %b" mapped
6309 method reshape w h =
6310 self#cleanup;
6311 reshape w h
6312 method mouse b d x y m =
6313 if d && canselect ()
6314 then (
6316 * http://blogs.msdn.com/b/oldnewthing/archive/2004/10/18/243925.aspx
6318 m_click_x <- x;
6319 m_click_y <- y;
6320 if b = 1
6321 then (
6322 let t = now () in
6323 if abs x - m_click_x > 10
6324 || abs y - m_click_y > 10
6325 || abs_float (t -. m_lastclicktime) > 0.3
6326 then m_clicks <- 0;
6327 m_clicks <- m_clicks + 1;
6328 m_lastclicktime <- t;
6329 if m_clicks = 1
6330 then (
6331 self#cleanup;
6332 G.postRedisplay "cleanup";
6333 state.uioh <- state.uioh#button b d x y m;
6335 else state.uioh <- state.uioh#multiclick m_clicks x y m
6337 else (
6338 self#cleanup;
6339 m_clicks <- 0;
6340 m_lastclicktime <- infinity;
6341 state.uioh <- state.uioh#button b d x y m
6344 else (
6345 state.uioh <- state.uioh#button b d x y m
6347 method motion x y =
6348 state.mpos <- (x, y);
6349 state.uioh <- state.uioh#motion x y
6350 method pmotion x y =
6351 state.mpos <- (x, y);
6352 state.uioh <- state.uioh#pmotion x y
6353 method key k m =
6354 vlog "k=%#x m=%#x" k m;
6355 let mascm = m land (
6356 Wsi.altmask + Wsi.shiftmask + Wsi.ctrlmask + Wsi.metamask
6357 ) in
6358 let keyboard k m =
6359 let x = state.x and y = state.y in
6360 keyboard k m;
6361 if x != state.x || y != state.y then self#cleanup
6363 match state.keystate with
6364 | KSnone ->
6365 let km = k, mascm in
6366 begin
6367 match
6368 let modehash = state.uioh#modehash in
6369 try Hashtbl.find modehash km
6370 with Not_found ->
6371 try Hashtbl.find (findkeyhash conf "global") km
6372 with Not_found -> KMinsrt (k, m)
6373 with
6374 | KMinsrt (k, m) -> keyboard k m
6375 | KMinsrl l -> List.iter (fun (k, m) -> keyboard k m) l
6376 | KMmulti (l, r) -> state.keystate <- KSinto (l, r)
6378 | KSinto ((k', m') :: [], insrt) when k'=k && m' land mascm = m' ->
6379 List.iter (fun (k, m) -> keyboard k m) insrt;
6380 state.keystate <- KSnone
6381 | KSinto ((k', m') :: keys, insrt) when k'=k && m' land mascm = m' ->
6382 state.keystate <- KSinto (keys, insrt)
6383 | KSinto _ -> state.keystate <- KSnone
6385 method enter x y =
6386 state.mpos <- (x, y);
6387 state.uioh <- state.uioh#pmotion x y
6388 method leave = state.mpos <- (-1, -1)
6389 method winstate wsl = state.winstate <- wsl
6390 method quit : 'a. 'a = raise Quit
6391 method scroll dx dy = state.uioh <- state.uioh#scroll dx dy
6392 method zoom z x y = state.uioh#zoom z x y
6393 method opendoc path =
6394 state.mode <- View;
6395 state.uioh <- uioh;
6396 G.postRedisplay "opendoc";
6397 opendoc path state.password
6400 let wsfd, winw, winh = Wsi.init mu !rootwid conf.cwinw conf.cwinh platform in
6401 state.wsfd <- wsfd;
6403 if not @@ List.exists GlMisc.check_extension
6404 [ "GL_ARB_texture_rectangle"
6405 ; "GL_EXT_texture_recangle"
6406 ; "GL_NV_texture_rectangle" ]
6407 then (dolog "OpenGL does not suppport rectangular textures"; exit 1);
6409 if substratis (GlMisc.get_string `renderer) 0 "Mesa DRI Intel("
6410 then (
6411 defconf.sliceheight <- 1024;
6412 defconf.texcount <- 32;
6413 defconf.usepbo <- true;
6416 let cs, ss =
6417 match Unix.socketpair Unix.PF_UNIX Unix.SOCK_STREAM 0 with
6418 | exception exn ->
6419 dolog "socketpair failed: %s" @@ exntos exn;
6420 exit 1
6421 | (r, w) ->
6422 cloexec r;
6423 cloexec w;
6424 r, w
6427 setcheckers conf.checkers;
6429 opengl_has_pbo := GlMisc.check_extension "GL_ARB_pixel_buffer_object";
6431 begin match !csspath with
6432 | None -> ()
6433 | Some "" -> conf.css <- E.s
6434 | Some path ->
6435 let css = filecontents path in
6436 let l = String.length css in
6437 conf.css <-
6438 if substratis css (l-2) "\r\n"
6439 then String.sub css 0 (l-2)
6440 else (if css.[l-1] = '\n'
6441 then String.sub css 0 (l-1)
6442 else css);
6443 end;
6444 init cs (
6445 conf.angle, conf.fitmodel, (conf.trimmargins, conf.trimfuzz),
6446 conf.texcount, conf.sliceheight, conf.mustoresize, conf.colorspace,
6447 !Config.fontpath, !trimcachepath, !opengl_has_pbo
6449 List.iter GlArray.enable [`texture_coord; `vertex];
6450 state.ss <- ss;
6451 reshape ~firsttime:true winw winh;
6452 state.uioh <- uioh;
6453 if histmode
6454 then (
6455 Wsi.settitle "llpp (history)";
6456 enterhistmode ();
6458 else (
6459 state.text <- "Opening " ^ (mbtoutf8 state.path);
6460 opendoc state.path state.password;
6462 display ();
6463 Wsi.mapwin ();
6464 Wsi.setcursor Wsi.CURSOR_INHERIT;
6465 Sys.set_signal Sys.sighup (Sys.Signal_handle (fun _ -> reload ()));
6467 let rec reap () =
6468 match Unix.waitpid [Unix.WNOHANG] ~-1 with
6469 | exception (Unix.Unix_error (Unix.ECHILD, _, _)) -> ()
6470 | exception exn -> dolog "Unix.waitpid: %s" @@ exntos exn
6471 | 0, _ -> ()
6472 | _pid, _status -> reap ()
6474 Sys.set_signal Sys.sigchld (Sys.Signal_handle (fun _ -> doreap := true));
6476 let optrfd =
6477 ref (
6478 if nonemptystr !rcmdpath
6479 then remoteopen !rcmdpath
6480 else None
6484 let rec loop deadline =
6485 if !doreap
6486 then (
6487 doreap := false;
6488 reap ()
6490 let r = [state.ss; state.wsfd] in
6491 let r =
6492 match !optrfd with
6493 | None -> r
6494 | Some fd -> fd :: r
6496 if state.redisplay
6497 then (
6498 state.redisplay <- false;
6499 display ();
6501 let timeout =
6502 let now = now () in
6503 if deadline > now
6504 then (
6505 if deadline = infinity
6506 then ~-.1.0
6507 else max 0.0 (deadline -. now)
6509 else 0.0
6511 let r, _, _ =
6512 try Unix.select r [] [] timeout
6513 with Unix.Unix_error (Unix.EINTR, _, _) -> [], [], []
6515 begin match r with
6516 | [] ->
6517 state.ghyll None;
6518 let newdeadline =
6519 if state.ghyll == noghyll
6520 then
6521 match state.autoscroll with
6522 | Some step when step != 0 ->
6523 if state.slideshow land 1 = 1
6524 then (
6525 if state.slideshow land 2 = 0
6526 then state.slideshow <- state.slideshow lor 2
6527 else if step < 0 then prevpage () else nextpage ();
6528 deadline +. (float (abs step))
6530 else
6531 let y = state.y + step in
6532 let fy = if conf.maxhfit then state.winh else 0 in
6533 let y =
6534 if y < 0
6535 then state.maxy - fy
6536 else if y >= state.maxy - fy then 0 else y
6538 if state.mode = View
6539 then gotoxy_and_clear_text state.x y
6540 else gotoxy state.x y;
6541 deadline +. 0.01
6542 | _ -> infinity
6543 else deadline +. 0.01
6545 loop newdeadline
6547 | l ->
6548 let rec checkfds = function
6549 | [] -> ()
6550 | fd :: rest when fd = state.ss ->
6551 let cmd = rcmd state.ss in
6552 act cmd;
6553 checkfds rest
6555 | fd :: rest when fd = state.wsfd ->
6556 Wsi.readresp fd;
6557 checkfds rest
6559 | fd :: rest when Some fd = !optrfd ->
6560 begin match remote fd with
6561 | None -> optrfd := remoteopen !rcmdpath;
6562 | opt -> optrfd := opt
6563 end;
6564 checkfds rest
6566 | _ :: rest ->
6567 dolog "select returned unknown descriptor";
6568 checkfds rest
6570 checkfds l;
6571 let newdeadline =
6572 let deadline1 =
6573 if deadline = infinity
6574 then now () +. 0.01
6575 else deadline
6577 match state.autoscroll with
6578 | Some step when step != 0 -> deadline1
6579 | _ -> if state.ghyll == noghyll then infinity else deadline1
6581 loop newdeadline
6582 end;
6584 match loop infinity with
6585 | exception Quit ->
6586 Config.save leavebirdseye;
6587 if hasunsavedchanges ()
6588 then save ()
6589 | _ -> error "umpossible - infinity reached"