Update
[llpp.git] / main.ml
bloba9b58cbab347dc9e8b836350407f6ebc01719b35
1 open Utils;;
2 open Config;;
3 open Glutils;;
4 open Listview;;
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 postprocess :
16 opaque -> int -> int -> int -> (int * string * int) -> int
17 = "ml_postprocess";;
18 external pagebbox : opaque -> (int * int * int * int) = "ml_getpagebox";;
19 external setaalevel : int -> unit = "ml_setaalevel";;
20 external realloctexts : int -> bool = "ml_realloctexts";;
21 external findlink : opaque -> linkdir -> link = "ml_findlink";;
22 external getlink : opaque -> int -> under = "ml_getlink";;
23 external getlinkrect : opaque -> int -> irect = "ml_getlinkrect";;
24 external getlinkcount : opaque -> int = "ml_getlinkcount";;
25 external findpwl : int -> int -> pagewithlinks = "ml_find_page_with_links";;
26 external getpbo : width -> height -> colorspace -> opaque = "ml_getpbo";;
27 external freepbo : opaque -> unit = "ml_freepbo";;
28 external unmappbo : opaque -> unit = "ml_unmappbo";;
29 external bousable : unit -> bool = "ml_bo_usable";;
30 external unproject :
31 opaque -> int -> int -> (int * int) option = "ml_unproject";;
32 external project :
33 opaque -> int -> int -> float -> float -> (float * float) = "ml_project";;
34 external drawtile :
35 tileparams -> opaque -> unit = "ml_drawtile";;
36 external rectofblock :
37 opaque -> int -> int -> float array option = "ml_rectofblock";;
38 external begintiles : unit -> unit = "ml_begintiles";;
39 external endtiles : unit -> unit = "ml_endtiles";;
40 external addannot : opaque -> int -> int -> string -> unit = "ml_addannot";;
41 external modannot : opaque -> slinkindex -> string -> unit = "ml_modannot";;
42 external delannot : opaque -> slinkindex -> unit = "ml_delannot";;
43 external hasunsavedchanges : unit -> bool = "ml_hasunsavedchanges";;
44 external savedoc : string -> unit = "ml_savedoc";;
45 external getannotcontents :
46 opaque -> slinkindex -> string = "ml_getannotcontents";;
47 external drawprect :
48 opaque -> int -> int -> float array -> unit = "ml_drawprect";;
49 external wcmd : Unix.file_descr -> bytes -> int -> unit = "ml_wcmd";;
50 external rcmd : Unix.file_descr -> string = "ml_rcmd";;
51 external uritolocation :
52 string -> (pageno * float * float) = "ml_uritolocation";;
53 external isexternallink : string -> bool = "ml_isexternallink";;
55 (* copysel _will_ close the supplied descriptor *)
56 external copysel : Unix.file_descr -> opaque -> unit = "ml_copysel";;
58 let selfexec = ref E.s;;
59 let ignoredoctitlte = ref false;;
60 let opengl_has_pbo = ref false;;
61 let layouth = ref ~-1;;
62 let checkerstexid = ref None;;
64 let debugrect (x0, y0, x1, y1, x2, y2, x3, y3) =
65 dolog {|rect {
66 x0,y0=(% f, % f)
67 x1,y1=(% f, % f)
68 x2,y2=(% f, % f)
69 x3,y3=(% f, % f)
70 }|} x0 y0 x1 y1 x2 y2 x3 y3;
73 let pgscale h = truncate (float h *. conf.pgscale);;
75 let hscrollh () =
76 if state.uioh#alwaysscrolly || ((conf.scrollb land scrollbhv != 0)
77 && (state.w > state.winw))
78 then conf.scrollbw
79 else 0
82 let setfontsize n =
83 fstate.fontsize <- n;
84 fstate.wwidth <- measurestr fstate.fontsize "w";
85 fstate.maxrows <- (state.winh - fstate.fontsize - 1) / (fstate.fontsize + 1);
88 let vlog fmt =
89 if conf.verbose
90 then dolog fmt
91 else Printf.kprintf ignore fmt
94 let launchpath () =
95 if emptystr conf.pathlauncher
96 then dolog "%s" state.path
97 else (
98 let command =
99 Str.global_replace Utils.Re.percent state.path conf.pathlauncher in
100 match spawn command [] with
101 | _pid -> ()
102 | exception exn -> dolog "failed to execute `%s': %s" command @@ exntos exn
106 let getopaque pageno =
107 try Some (Hashtbl.find state.pagemap (pageno, state.gen))
108 with Not_found -> None
111 let pagetranslatepoint l x y =
112 let dy = y - l.pagedispy in
113 let y = dy + l.pagey in
114 let dx = x - l.pagedispx in
115 let x = dx + l.pagex in
116 (x, y);
119 let onppundermouse g x y d =
120 let rec f = function
121 | l :: rest ->
122 begin match getopaque l.pageno with
123 | Some opaque ->
124 let x0 = l.pagedispx in
125 let x1 = x0 + l.pagevw in
126 let y0 = l.pagedispy in
127 let y1 = y0 + l.pagevh in
128 if y >= y0 && y <= y1 && x >= x0 && x <= x1
129 then
130 let px, py = pagetranslatepoint l x y in
131 match g opaque l px py with
132 | Some res -> res
133 | None -> f rest
134 else f rest
135 | _ -> f rest
137 | [] -> d
139 f state.layout
142 let getunder x y =
143 let g opaque l px py =
144 if state.bzoom
145 then (
146 match rectofblock opaque px py with
147 | Some [|x0;x1;y0;y1|] ->
148 let rect = (x0, y0, x1, y0, x1, y1, x0, y1) in
149 let color = (0.0, 0.0, 1.0 /. (l.pageno mod 3 |> float), 0.5) in
150 state.rects <- [l.pageno, color, rect];
151 postRedisplay "getunder";
152 | _ -> ()
154 let under = whatsunder opaque px py in
155 if under = Unone then None else Some under
157 onppundermouse g x y Unone
160 let unproject x y =
161 let g opaque l x y =
162 match unproject opaque x y with
163 | Some (x, y) -> Some (Some (opaque, l.pageno, x, y))
164 | None -> None
166 onppundermouse g x y None;
169 let showtext c s =
170 state.text <- Printf.sprintf "%c%s" c s;
171 postRedisplay "showtext";
174 let impmsg fmt = Format.ksprintf (fun s -> showtext '!' s) fmt;;
176 let pipesel opaque cmd =
177 if hassel opaque
178 then pipef ~closew:false "pipesel"
179 (fun w ->
180 copysel w opaque;
181 postRedisplay "pipesel"
182 ) cmd
185 let paxunder x y =
186 let g opaque l px py =
187 if markunder opaque px py conf.paxmark
188 then
189 Some (fun () ->
190 match getopaque l.pageno with
191 | None -> ()
192 | Some opaque -> pipesel opaque conf.paxcmd
194 else None
196 postRedisplay "paxunder";
197 if conf.paxmark = Mark_page
198 then
199 List.iter (fun l ->
200 match getopaque l.pageno with
201 | None -> ()
202 | Some opaque -> clearmark opaque) state.layout;
203 state.roam <- onppundermouse g x y (fun () -> impmsg "whoopsie daisy");
206 let undertext = function
207 | Unone -> "none"
208 | Ulinkuri s -> s
209 | Utext s -> "font: " ^ s
210 | Uannotation (opaque, slinkindex) ->
211 "annotation: " ^ getannotcontents opaque slinkindex
214 let updateunder x y =
215 match getunder x y with
216 | Unone -> Wsi.setcursor Wsi.CURSOR_INHERIT
217 | Ulinkuri uri ->
218 if conf.underinfo then showtext 'u' ("ri: " ^ uri);
219 Wsi.setcursor Wsi.CURSOR_INFO
220 | Utext s ->
221 if conf.underinfo then showtext 'f' ("ont: " ^ s);
222 Wsi.setcursor Wsi.CURSOR_TEXT
223 | Uannotation _ ->
224 if conf.underinfo then showtext 'a' "nnotation";
225 Wsi.setcursor Wsi.CURSOR_INFO
228 let showlinktype under =
229 if conf.underinfo && under != Unone
230 then showtext ' ' @@ undertext under
233 let intentry_with_suffix text key =
234 let text =
235 match [@warning "-4"] key with
236 | Keys.Ascii ('0'..'9' as c) -> addchar text c
237 | Keys.Ascii ('k' | 'm' | 'g' | 'K' | 'M' | 'G' as c) ->
238 addchar text @@ asciilower c
239 | _ ->
240 state.text <- "invalid key";
241 text
243 TEcont text
246 let wcmd fmt =
247 let b = Buffer.create 16 in
248 Printf.kbprintf
249 (fun b ->
250 let b = Buffer.to_bytes b in
251 wcmd state.ss b @@ Bytes.length b
252 ) b fmt
255 let nogeomcmds cmds =
256 match cmds with
257 | s, [] -> emptystr s
258 | _ -> false
261 let layoutN ((columns, coverA, coverB), b) x y sw sh =
262 let rec fold accu n =
263 if n = Array.length b
264 then accu
265 else
266 let pdimno, dx, vy, (_, w, h, xoff) = b.(n) in
267 if (vy - y) > sh &&
268 (n = coverA - 1
269 || n = state.pagecount - coverB
270 || (n - coverA) mod columns = columns - 1)
271 then accu
272 else
273 let accu =
274 if vy + h > y
275 then
276 let pagey = max 0 (y - vy) in
277 let pagedispy = if pagey > 0 then 0 else vy - y in
278 let pagedispx, pagex =
279 let pdx =
280 if n = coverA - 1 || n = state.pagecount - coverB
281 then x + (sw - w) / 2
282 else dx + xoff + x
284 if pdx < 0
285 then 0, -pdx
286 else pdx, 0
288 let pagevw =
289 let vw = sw - pagedispx in
290 let pw = w - pagex in
291 min vw pw
293 let pagevh = min (h - pagey) (sh - pagedispy) in
294 if pagevw > 0 && pagevh > 0
295 then
296 let e =
297 { pageno = n
298 ; pagedimno = pdimno
299 ; pagew = w
300 ; pageh = h
301 ; pagex = pagex
302 ; pagey = pagey
303 ; pagevw = pagevw
304 ; pagevh = pagevh
305 ; pagedispx = pagedispx
306 ; pagedispy = pagedispy
307 ; pagecol = 0
310 e :: accu
311 else accu
312 else accu
314 fold accu (n+1)
316 if Array.length b = 0
317 then []
318 else List.rev (fold [] (page_of_y y))
321 let layoutS (columns, b) x y sw sh =
322 let rec fold accu n =
323 if n = Array.length b
324 then accu
325 else
326 let pdimno, px, vy, (_, pagew, pageh, xoff) = b.(n) in
327 if (vy - y) > sh
328 then accu
329 else
330 let accu =
331 if vy + pageh > y
332 then
333 let x = xoff + x in
334 let pagey = max 0 (y - vy) in
335 let pagedispy = if pagey > 0 then 0 else vy - y in
336 let pagedispx, pagex =
337 if px = 0
338 then (
339 if x < 0
340 then 0, -x
341 else x, 0
343 else (
344 let px = px - x in
345 if px < 0
346 then -px, 0
347 else 0, px
350 let pagecolw = pagew/columns in
351 let pagedispx =
352 if pagecolw < sw
353 then pagedispx + ((sw - pagecolw) / 2)
354 else pagedispx
356 let pagevw =
357 let vw = sw - pagedispx in
358 let pw = pagew - pagex in
359 min vw pw
361 let pagevw = min pagevw pagecolw in
362 let pagevh = min (pageh - pagey) (sh - pagedispy) in
363 if pagevw > 0 && pagevh > 0
364 then
365 let e =
366 { pageno = n/columns
367 ; pagedimno = pdimno
368 ; pagew = pagew
369 ; pageh = pageh
370 ; pagex = pagex
371 ; pagey = pagey
372 ; pagevw = pagevw
373 ; pagevh = pagevh
374 ; pagedispx = pagedispx
375 ; pagedispy = pagedispy
376 ; pagecol = n mod columns
379 e :: accu
380 else accu
381 else accu
383 fold accu (n+1)
385 List.rev (fold [] 0)
388 let layout x y sw sh =
389 if nogeomcmds state.geomcmds
390 then
391 match conf.columns with
392 | Csingle b -> layoutN ((1, 0, 0), b) x y sw sh
393 | Cmulti c -> layoutN c x y sw sh
394 | Csplit s -> layoutS s x y sw sh
395 else []
398 let maxy () = state.maxy - if conf.maxhfit then state.winh else 0;;
399 let clamp incr = bound (state.y + incr) 0 @@ maxy ();;
401 let itertiles l f =
402 let tilex = l.pagex mod conf.tilew in
403 let tiley = l.pagey mod conf.tileh in
405 let col = l.pagex / conf.tilew in
406 let row = l.pagey / conf.tileh in
408 let rec rowloop row y0 dispy h =
409 if h != 0
410 then
411 let dh = conf.tileh - y0 in
412 let dh = min h dh in
413 let rec colloop col x0 dispx w =
414 if w != 0
415 then
416 let dw = conf.tilew - x0 in
417 let dw = min w dw in
418 f col row dispx dispy x0 y0 dw dh;
419 colloop (col+1) 0 (dispx+dw) (w-dw)
421 colloop col tilex l.pagedispx l.pagevw;
422 rowloop (row+1) 0 (dispy+dh) (h-dh)
424 if l.pagevw > 0 && l.pagevh > 0
425 then rowloop row tiley l.pagedispy l.pagevh;
428 let gettileopaque l col row =
429 let key = l.pageno, state.gen, conf.colorspace,
430 conf.angle, l.pagew, l.pageh, col, row in
431 try Some (Hashtbl.find state.tilemap key)
432 with Not_found -> None
435 let puttileopaque l col row gen colorspace angle opaque size elapsed =
436 let key = l.pageno, gen, colorspace, angle, l.pagew, l.pageh, col, row in
437 Hashtbl.add state.tilemap key (opaque, size, elapsed)
440 let drawtiles l color =
441 GlDraw.color color;
442 begintiles ();
443 let f col row x y tilex tiley w h =
444 match gettileopaque l col row with
445 | Some (opaque, _, t) ->
446 let params = x, y, w, h, tilex, tiley in
447 if conf.invert
448 then GlTex.env (`mode `blend);
449 drawtile params opaque;
450 if conf.invert
451 then GlTex.env (`mode `modulate);
452 if conf.debug
453 then (
454 endtiles ();
455 let s = Printf.sprintf "%d[%d,%d] %f sec" l.pageno col row t in
456 let w = measurestr fstate.fontsize s in
457 GlDraw.color (0.0, 0.0, 0.0);
458 filledrect
459 (float (x-2))
460 (float (y-2))
461 (float (x+2) +. w)
462 (float (y + fstate.fontsize + 2));
463 GlDraw.color color;
464 drawstring fstate.fontsize x (y + fstate.fontsize - 1) s;
465 begintiles ();
468 | None ->
469 endtiles ();
470 let w = let lw = state.winw - x in min lw w
471 and h = let lh = state.winh - y in min lh h
473 if conf.invert
474 then GlTex.env (`mode `blend);
475 begin match !checkerstexid with
476 | Some id ->
477 Gl.enable `texture_2d;
478 GlTex.bind_texture ~target:`texture_2d id;
479 let x0 = float x
480 and y0 = float y
481 and x1 = float (x+w)
482 and y1 = float (y+h) in
484 let tw = float w /. 16.0
485 and th = float h /. 16.0 in
486 let tx0 = float tilex /. 16.0
487 and ty0 = float tiley /. 16.0 in
488 let tx1 = tx0 +. tw
489 and ty1 = ty0 +. th in
490 Raw.sets_float Glutils.vraw ~pos:0
491 [| x0; y0; x0; y1; x1; y0; x1; y1 |];
492 Raw.sets_float Glutils.traw ~pos:0
493 [| tx0; ty0; tx0; ty1; tx1; ty0; tx1; ty1 |];
494 GlArray.vertex `two Glutils.vraw;
495 GlArray.tex_coord `two Glutils.traw;
496 GlArray.draw_arrays `triangle_strip ~first:0 ~count:4;
497 Gl.disable `texture_2d;
499 | None ->
500 GlDraw.color (1.0, 1.0, 1.0);
501 filledrect (float x) (float y) (float (x+w)) (float (y+h));
502 end;
503 if conf.invert
504 then GlTex.env (`mode `modulate);
505 if w > 128 && h > fstate.fontsize + 10
506 then (
507 let c = if conf.invert then 1.0 else 0.0 in
508 GlDraw.color (c, c, c);
509 let c, r =
510 if conf.verbose
511 then (col*conf.tilew, row*conf.tileh)
512 else col, row
514 drawstring2 fstate.fontsize x y "Loading %d [%d,%d]" l.pageno c r;
516 GlDraw.color color;
517 begintiles ();
519 itertiles l f;
520 endtiles ();
523 let pagevisible layout n = List.exists (fun l -> l.pageno = n) layout;;
525 let tilevisible1 l x y =
526 let ax0 = l.pagex
527 and ax1 = l.pagex + l.pagevw
528 and ay0 = l.pagey
529 and ay1 = l.pagey + l.pagevh in
531 let bx0 = x
532 and by0 = y in
533 let bx1 = min (bx0 + conf.tilew) l.pagew
534 and by1 = min (by0 + conf.tileh) l.pageh in
536 let rx0 = max ax0 bx0
537 and ry0 = max ay0 by0
538 and rx1 = min ax1 bx1
539 and ry1 = min ay1 by1 in
541 let nonemptyintersection = rx1 > rx0 && ry1 > ry0 in
542 nonemptyintersection
545 let tilevisible layout n x y =
546 let rec findpageinlayout m = function
547 | l :: rest when l.pageno = n ->
548 tilevisible1 l x y || (
549 match conf.columns with
550 | Csplit (c, _) when c > m -> findpageinlayout (m+1) rest
551 | Csplit _ | Csingle _ | Cmulti _ -> false
553 | _ :: rest -> findpageinlayout 0 rest
554 | [] -> false
556 findpageinlayout 0 layout;
559 let tileready l x y =
560 tilevisible1 l x y &&
561 gettileopaque l (x/conf.tilew) (y/conf.tileh) != None
564 let tilepage n p layout =
565 let rec loop = function
566 | l :: rest ->
567 if l.pageno = n
568 then
569 let f col row _ _ _ _ _ _ =
570 if state.currently = Idle
571 then
572 match gettileopaque l col row with
573 | Some _ -> ()
574 | None ->
575 let x = col*conf.tilew
576 and y = row*conf.tileh in
577 let w =
578 let w = l.pagew - x in
579 min w conf.tilew
581 let h =
582 let h = l.pageh - y in
583 min h conf.tileh
585 let pbo =
586 if conf.usepbo
587 then getpbo w h conf.colorspace
588 else ~< "0"
590 wcmd "tile %s %d %d %d %d %s" (~> p) x y w h (~> pbo);
591 state.currently <-
592 Tiling (
593 l, p, conf.colorspace, conf.angle,
594 state.gen, col, row, conf.tilew, conf.tileh
597 itertiles l f;
598 else
599 loop rest
601 | [] -> ()
603 if nogeomcmds state.geomcmds
604 then loop layout;
607 let preloadlayout x y sw sh =
608 let y = if y < sh then 0 else y - sh in
609 let x = min 0 (x + sw) in
610 let h = sh*3 in
611 let w = sw*3 in
612 layout x y w h;
615 let load pages =
616 let rec loop pages =
617 if state.currently = Idle
618 then
619 match pages with
620 | l :: rest ->
621 begin match getopaque l.pageno with
622 | None ->
623 wcmd "page %d %d" l.pageno l.pagedimno;
624 state.currently <- Loading (l, state.gen);
625 | Some opaque ->
626 tilepage l.pageno opaque pages;
627 loop rest
628 end;
629 | _ -> ()
631 if nogeomcmds state.geomcmds
632 then loop pages
635 let preload pages =
636 load pages;
637 if conf.preload && state.currently = Idle
638 then load (preloadlayout state.x state.y state.winw state.winh);
641 let layoutready layout =
642 let rec fold all ls =
643 all && match ls with
644 | l :: rest ->
645 let seen = ref false in
646 let allvisible = ref true in
647 let foo col row _ _ _ _ _ _ =
648 seen := true;
649 allvisible := !allvisible &&
650 begin match gettileopaque l col row with
651 | Some _ -> true
652 | None -> false
655 itertiles l foo;
656 fold (!seen && !allvisible) rest
657 | [] -> true
659 let alltilesvisible = fold true layout in
660 alltilesvisible;
663 let gotoxy x y =
664 let y = bound y 0 state.maxy in
665 let y, layout =
666 let layout = layout x y state.winw state.winh in
667 postRedisplay "gotoxy ready";
668 y, layout
670 state.x <- x;
671 state.y <- y;
672 state.layout <- layout;
673 begin match state.mode with
674 | LinkNav ln ->
675 begin match ln with
676 | Ltexact (pageno, linkno) ->
677 let rec loop = function
678 | [] ->
679 state.lnava <- Some (pageno, linkno);
680 state.mode <- LinkNav (Ltgendir 0)
681 | l :: _ when l.pageno = pageno ->
682 begin match getopaque pageno with
683 | None -> state.mode <- LinkNav (Ltnotready (pageno, 0))
684 | Some opaque ->
685 let x0, y0, x1, y1 = getlinkrect opaque linkno in
686 if not (x0 >= l.pagex && x1 <= l.pagex + l.pagevw
687 && y0 >= l.pagey && y1 <= l.pagey + l.pagevh)
688 then state.mode <- LinkNav (Ltgendir 0)
690 | _ :: rest -> loop rest
692 loop layout
693 | Ltnotready _ | Ltgendir _ -> ()
695 | Birdseye _ | Textentry _ | View -> ()
696 end;
697 begin match state.mode with
698 | Birdseye (conf, leftx, pageno, hooverpageno, anchor) ->
699 if not (pagevisible layout pageno)
700 then (
701 match state.layout with
702 | [] -> ()
703 | l :: _ ->
704 state.mode <- Birdseye (conf, leftx, l.pageno, hooverpageno, anchor)
706 | LinkNav lt ->
707 begin match lt with
708 | Ltnotready (_, dir)
709 | Ltgendir dir ->
710 let linknav =
711 let rec loop = function
712 | [] -> lt
713 | l :: rest ->
714 match getopaque l.pageno with
715 | None -> Ltnotready (l.pageno, dir)
716 | Some opaque ->
717 let link =
718 let ld =
719 if dir = 0
720 then LDfirstvisible (l.pagex, l.pagey, dir)
721 else (
722 if dir > 0 then LDfirst else LDlast
725 findlink opaque ld
727 match link with
728 | Lnotfound -> loop rest
729 | Lfound n ->
730 showlinktype (getlink opaque n);
731 Ltexact (l.pageno, n)
733 loop state.layout
735 state.mode <- LinkNav linknav
736 | Ltexact _ -> ()
738 | Textentry _ | View -> ()
739 end;
740 preload layout;
741 if conf.updatecurs
742 then (
743 let mx, my = state.mpos in
744 updateunder mx my;
748 let conttiling pageno opaque =
749 tilepage pageno opaque
750 (if conf.preload
751 then preloadlayout state.x state.y state.winw state.winh
752 else state.layout)
755 let gotoxy x y =
756 if not conf.verbose then state.text <- E.s;
757 gotoxy x y;
760 let getanchory (n, top, dtop) =
761 let y, h = getpageyh n in
762 if conf.presentation
763 then
764 let ips = calcips h in
765 y + truncate (top*.float h -. dtop*.float ips) + ips;
766 else y + truncate (top*.float h -. dtop*.float conf.interpagespace)
769 let gotoanchor anchor = gotoxy state.x (getanchory anchor);;
770 let addnav () = getanchor () |> cbput state.hists.nav;;
771 let addnavnorc () = getanchor () |> cbput_dont_update_rc state.hists.nav;;
773 let getnav dir =
774 let anchor = cbgetc state.hists.nav dir in
775 getanchory anchor;
778 let gotopage n top =
779 let y, h = getpageyh n in
780 let y = y + (truncate (top *. float h)) in
781 gotoxy state.x y
784 let gotopage1 n top =
785 let y = getpagey n in
786 let y = y + top in
787 gotoxy state.x y
790 let invalidate s f =
791 Glutils.redisplay := false;
792 state.layout <- [];
793 state.pdims <- [];
794 state.rects <- [];
795 state.rects1 <- [];
796 match state.geomcmds with
797 | ps, [] when emptystr ps ->
798 f ();
799 state.geomcmds <- s, [];
800 | ps, [] -> state.geomcmds <- ps, [s, f];
801 | ps, (s', _) :: rest when s' = s -> state.geomcmds <- ps, ((s, f) :: rest);
802 | ps, cmds -> state.geomcmds <- ps, ((s, f) :: cmds);
805 let flushpages () =
806 Hashtbl.iter (fun _ opaque -> wcmd "freepage %s" (~> opaque)) state.pagemap;
807 Hashtbl.clear state.pagemap;
810 let flushtiles () =
811 if not (Queue.is_empty state.tilelru)
812 then (
813 Queue.iter (fun (k, p, s) ->
814 wcmd "freetile %s" (~> p);
815 state.memused <- state.memused - s;
816 Hashtbl.remove state.tilemap k;
817 ) state.tilelru;
818 state.uioh#infochanged Memused;
819 Queue.clear state.tilelru;
821 load state.layout;
824 let stateh h =
825 let h = truncate (float h*.conf.zoom) in
826 let d = conf.interpagespace lsl (if conf.presentation then 1 else 0) in
827 h - d
830 let fillhelp () =
831 state.help <-
832 let sl = keystostrlist conf in
833 let rec loop accu =
834 function | [] -> accu
835 | s :: rest -> loop ((s, 0, Noaction) :: accu) rest
836 in Help.makehelp conf.urilauncher
837 @ (("", 0, Noaction) :: loop [] sl) |> Array.of_list
840 let opendoc path password =
841 state.path <- path;
842 state.password <- password;
843 state.gen <- state.gen + 1;
844 state.docinfo <- [];
845 state.outlines <- [||];
847 flushpages ();
848 setaalevel conf.aalevel;
849 let titlepath =
850 if emptystr state.origin
851 then path
852 else state.origin
854 Wsi.settitle ("llpp " ^ mbtoutf8 (Filename.basename titlepath));
855 wcmd "open %d %d %s\000%s\000%s\000"
856 (btod conf.usedoccss) !layouth
857 path password conf.css;
858 invalidate "reqlayout"
859 (fun () ->
860 wcmd "reqlayout %d %d %d %s\000"
861 conf.angle (FMTE.to_int conf.fitmodel)
862 (stateh state.winh) state.nameddest
864 fillhelp ();
867 let reload () =
868 state.anchor <- getanchor ();
869 opendoc state.path state.password;
872 let scalecolor c =
873 let c = c *. conf.colorscale in
874 (c, c, c);
877 let scalecolor2 (r, g, b) =
878 (r *. conf.colorscale, g *. conf.colorscale, b *. conf.colorscale);
881 let docolumns columns =
882 match columns with
883 | Csingle _ ->
884 let a = Array.make state.pagecount (-1, -1, -1, (-1, -1, -1, -1)) in
885 let rec loop pageno pdimno pdim y ph pdims =
886 if pageno != state.pagecount
887 then
888 let pdimno, ((_, w, h, xoff) as pdim), pdims =
889 match pdims with
890 | ((pageno', _, _, _) as pdim) :: rest when pageno' = pageno ->
891 pdimno+1, pdim, rest
892 | _ ->
893 pdimno, pdim, pdims
895 let x = max 0 (((state.winw - w) / 2) - xoff) in
896 let y =
897 y + (if conf.presentation
898 then (if pageno = 0 then calcips h else calcips ph + calcips h)
899 else (if pageno = 0 then 0 else conf.interpagespace))
901 a.(pageno) <- (pdimno, x, y, pdim);
902 loop (pageno+1) pdimno pdim (y + h) h pdims
904 loop 0 ~-1 (-1,-1,-1,-1) 0 0 state.pdims;
905 conf.columns <- Csingle a;
907 | Cmulti ((columns, coverA, coverB), _) ->
908 let a = Array.make state.pagecount (-1, -1, -1, (-1, -1, -1, -1)) in
909 let rec loop pageno pdimno pdim x y rowh pdims =
910 let rec fixrow m =
911 if m = pageno then () else
912 let (pdimno, x, y, ((_, _, h, _) as pdim)) = a.(m) in
913 if h < rowh
914 then (
915 let y = y + (rowh - h) / 2 in
916 a.(m) <- (pdimno, x, y, pdim);
918 fixrow (m+1)
920 if pageno = state.pagecount
921 then fixrow (((pageno - 1) / columns) * columns)
922 else
923 let pdimno, ((_, w, h, xoff) as pdim), pdims =
924 match pdims with
925 | ((pageno', _, _, _) as pdim) :: rest when pageno' = pageno ->
926 pdimno+1, pdim, rest
927 | _ -> pdimno, pdim, pdims
929 let x, y, rowh' =
930 if pageno = coverA - 1 || pageno = state.pagecount - coverB
931 then (
932 let x = (state.winw - w) / 2 in
933 let ips =
934 if conf.presentation then calcips h else conf.interpagespace in
935 x, y + ips + rowh, h
937 else (
938 if (pageno - coverA) mod columns = 0
939 then (
940 let x = max 0 (state.winw - state.w) / 2 in
941 let y =
942 if conf.presentation
943 then
944 let ips = calcips h in
945 y + (if pageno = 0 then 0 else calcips rowh + ips)
946 else
947 y + (if pageno = 0 then 0 else conf.interpagespace)
949 x, y + rowh, h
951 else x, y, max rowh h
954 let y =
955 if pageno > 1 && (pageno - coverA) mod columns = 0
956 then (
957 let y =
958 if pageno = columns && conf.presentation
959 then (
960 let ips = calcips rowh in
961 for i = 0 to pred columns
963 let (pdimno, x, y, pdim) = a.(i) in
964 a.(i) <- (pdimno, x, y+ips, pdim)
965 done;
966 y+ips;
968 else y
970 fixrow (pageno - columns);
973 else y
975 a.(pageno) <- (pdimno, x, y, pdim);
976 let x = x + w + xoff*2 + conf.interpagespace in
977 loop (pageno+1) pdimno pdim x y rowh' pdims
979 loop 0 ~-1 (-1,-1,-1,-1) 0 0 0 state.pdims;
980 conf.columns <- Cmulti ((columns, coverA, coverB), a);
982 | Csplit (c, _) ->
983 let a = Array.make (state.pagecount*c) (-1, -1, -1, (-1, -1, -1, -1)) in
984 let rec loop pageno pdimno pdim y pdims =
985 if pageno != state.pagecount
986 then
987 let pdimno, ((_, w, h, _) as pdim), pdims =
988 match pdims with
989 | ((pageno', _, _, _) as pdim) :: rest when pageno' = pageno ->
990 pdimno+1, pdim, rest
991 | _ -> pdimno, pdim, pdims
993 let cw = w / c in
994 let rec loop1 n x y =
995 if n = c then y else (
996 a.(pageno*c + n) <- (pdimno, x, y, pdim);
997 loop1 (n+1) (x+cw) (y + h + conf.interpagespace)
1000 let y = loop1 0 0 y in
1001 loop (pageno+1) pdimno pdim y pdims
1003 loop 0 ~-1 (-1,-1,-1,-1) 0 state.pdims;
1004 conf.columns <- Csplit (c, a);
1007 let represent () =
1008 docolumns conf.columns;
1009 state.maxy <- calcheight ();
1010 if state.reprf == noreprf
1011 then (
1012 match state.mode with
1013 | Birdseye (_, _, pageno, _, _) ->
1014 let y, h = getpageyh pageno in
1015 let top = (state.winh - h) / 2 in
1016 gotoxy state.x (max 0 (y - top))
1017 | Textentry _ | View | LinkNav _ ->
1018 let y = getanchory state.anchor in
1019 let y = min y (state.maxy - state.winh) in
1020 gotoxy state.x y;
1022 else (
1023 state.reprf ();
1024 state.reprf <- noreprf;
1028 let reshape ?(firsttime=false) w h =
1029 GlDraw.viewport ~x:0 ~y:0 ~w ~h;
1030 if not firsttime && nogeomcmds state.geomcmds
1031 then state.anchor <- getanchor ();
1033 state.winw <- w;
1034 let w = truncate (float w *. conf.zoom) in
1035 let w = max w 2 in
1036 state.winh <- h;
1037 setfontsize fstate.fontsize;
1038 GlMat.mode `modelview;
1039 GlMat.load_identity ();
1041 GlMat.mode `projection;
1042 GlMat.load_identity ();
1043 GlMat.rotate ~x:1.0 ~angle:180.0 ();
1044 GlMat.translate ~x:~-.1.0 ~y:~-.1.0 ();
1045 GlMat.scale3 (2.0 /. float state.winw, 2.0 /. float state.winh, 1.0);
1047 let relx =
1048 if conf.zoom <= 1.0
1049 then 0.0
1050 else float state.x /. float state.w
1052 invalidate "geometry"
1053 (fun () ->
1054 state.w <- w;
1055 if not firsttime
1056 then state.x <- truncate (relx *. float w);
1057 let w =
1058 match conf.columns with
1059 | Csingle _ -> w
1060 | Cmulti ((c, _, _), _) -> (w - (c-1)*conf.interpagespace) / c
1061 | Csplit (c, _) -> w * c
1063 wcmd "geometry %d %d %d" w (stateh h) (FMTE.to_int conf.fitmodel)
1067 let gctiles () =
1068 let len = Queue.length state.tilelru in
1069 let layout = lazy (if conf.preload
1070 then preloadlayout state.x state.y state.winw state.winh
1071 else state.layout) in
1072 let rec loop qpos =
1073 if state.memused > conf.memlimit
1074 then (
1075 if qpos < len
1076 then
1077 let (k, p, s) as lruitem = Queue.pop state.tilelru in
1078 let n, gen, colorspace, angle, pagew, pageh, col, row = k in
1079 let (_, pw, ph, _) = getpagedim n in
1080 if gen = state.gen
1081 && colorspace = conf.colorspace
1082 && angle = conf.angle
1083 && pagew = pw
1084 && pageh = ph
1085 && (
1086 let x = col*conf.tilew and y = row*conf.tileh in
1087 tilevisible (Lazy.force_val layout) n x y
1089 then Queue.push lruitem state.tilelru
1090 else (
1091 freepbo p;
1092 wcmd "freetile %s" (~> p);
1093 state.memused <- state.memused - s;
1094 state.uioh#infochanged Memused;
1095 Hashtbl.remove state.tilemap k;
1097 loop (qpos+1)
1100 loop 0
1103 let onpagerect pageno f =
1104 let b =
1105 match conf.columns with
1106 | Cmulti (_, b) -> b
1107 | Csingle b -> b
1108 | Csplit (_, b) -> b
1110 if pageno >= 0 && pageno < Array.length b
1111 then
1112 let (_, _, _, (_, w, h, _)) = b.(pageno) in
1113 f w h
1116 let gotopagexy1 pageno x y =
1117 let _,w1,h1,leftx = getpagedim pageno in
1118 let top = y /. (float h1) in
1119 let left = x /. (float w1) in
1120 let py, w, h = getpageywh pageno in
1121 let wh = state.winh in
1122 let x = left *. (float w) in
1123 let x = leftx + state.x + truncate x in
1124 let sx =
1125 if x < 0 || x >= state.winw
1126 then state.x - x
1127 else state.x
1129 let pdy = truncate (top *. float h) in
1130 let y' = py + pdy in
1131 let dy = y' - state.y in
1132 let sy =
1133 if x != state.x || not (dy > 0 && dy < wh)
1134 then (
1135 if conf.presentation
1136 then
1137 if abs (py - y') > wh
1138 then y'
1139 else py
1140 else y';
1142 else state.y
1144 if state.x != sx || state.y != sy
1145 then gotoxy sx sy
1146 else gotoxy state.x state.y;
1149 let gotopagexy pageno x y =
1150 match state.mode with
1151 | Birdseye _ -> gotopage pageno 0.0
1152 | Textentry _ | View | LinkNav _ -> gotopagexy1 pageno x y
1155 let getpassword () =
1156 let passcmd = getenvwithdef "LLPP_ASKPASS" conf.passcmd in
1157 if emptystr passcmd
1158 then E.s
1159 else getcmdoutput
1160 (fun s ->
1161 impmsg "error getting password: %s" s;
1162 dolog "%s" s) passcmd;
1165 let pgoto opaque pageno x y =
1166 let pdimno = getpdimno pageno in
1167 let x, y = project opaque pageno pdimno x y in
1168 gotopagexy pageno x y;
1171 let act cmds =
1172 (* dolog "%S" cmds; *)
1173 let spl = splitatchar cmds ' ' in
1174 let scan s fmt f =
1175 try Scanf.sscanf s fmt f
1176 with exn ->
1177 dolog "error processing '%S': %s" cmds @@ exntos exn;
1178 exit 1
1180 let addoutline outline =
1181 match state.currently with
1182 | Outlining outlines -> state.currently <- Outlining (outline :: outlines)
1183 | Idle -> state.currently <- Outlining [outline]
1184 | Loading _ | Tiling _ ->
1185 dolog "invalid outlining state";
1186 logcurrently state.currently
1188 match spl with
1189 | "clear", "" ->
1190 state.pdims <- [];
1191 state.uioh#infochanged Pdim;
1193 | "clearrects", "" ->
1194 state.rects <- state.rects1;
1195 postRedisplay "clearrects";
1197 | "continue", args ->
1198 let n = scan args "%u" (fun n -> n) in
1199 state.pagecount <- n;
1200 begin match state.currently with
1201 | Outlining l ->
1202 state.currently <- Idle;
1203 state.outlines <- Array.of_list (List.rev l)
1204 | Idle | Loading _ | Tiling _ -> ()
1205 end;
1207 let cur, cmds = state.geomcmds in
1208 if emptystr cur
1209 then error "empty geomcmd";
1211 begin match List.rev cmds with
1212 | [] ->
1213 state.geomcmds <- E.s, [];
1214 represent ();
1215 | (s, f) :: rest ->
1216 f ();
1217 state.geomcmds <- s, List.rev rest;
1218 end;
1219 postRedisplay "continue";
1221 | "msg", args ->
1222 showtext ' ' args
1224 | "vmsg", args ->
1225 if conf.verbose
1226 then showtext ' ' args
1228 | "emsg", args ->
1229 Buffer.add_string state.errmsgs args;
1230 state.newerrmsgs <- true;
1231 postRedisplay "error message"
1233 | "progress", args ->
1234 let progress, text =
1235 scan args "%f %n"
1236 (fun f pos ->
1237 f, String.sub args pos (String.length args - pos))
1239 state.text <- text;
1240 state.progress <- progress;
1241 postRedisplay "progress"
1243 | "firstmatch", args ->
1244 let pageno, c, x0, y0, x1, y1, x2, y2, x3, y3 =
1245 scan args "%u %d %f %f %f %f %f %f %f %f"
1246 (fun p c x0 y0 x1 y1 x2 y2 x3 y3 ->
1247 (p, c, x0, y0, x1, y1, x2, y2, x3, y3))
1249 let y = (getpagey pageno) + truncate y0 in
1250 let x =
1251 if (state.x < - truncate x0) || (state.x > state.winw - truncate x1)
1252 then state.winw/2 - truncate (x0 /. 2. +. x1 /. 2.)
1253 else state.x
1255 addnav ();
1256 gotoxy x y;
1257 let color = (0.0, 0.0, 1.0 /. float c, 0.5) in
1258 state.rects1 <- [pageno, color, (x0, y0, x1, y1, x2, y2, x3, y3)]
1260 | "match", args ->
1261 let pageno, c, x0, y0, x1, y1, x2, y2, x3, y3 =
1262 scan args "%u %d %f %f %f %f %f %f %f %f"
1263 (fun p c x0 y0 x1 y1 x2 y2 x3 y3 ->
1264 (p, c, x0, y0, x1, y1, x2, y2, x3, y3))
1266 let color = (0.0, 0.0, 1.0 /. float c, 0.5) in
1267 state.rects1 <-
1268 (pageno, color, (x0, y0, x1, y1, x2, y2, x3, y3)) :: state.rects1
1270 | "page", args ->
1271 let pageopaques, t = scan args "%s %f" (fun p t -> p, t) in
1272 let pageopaque = ~< pageopaques in
1273 begin match state.currently with
1274 | Loading (l, gen) ->
1275 vlog "page %d took %f sec" l.pageno t;
1276 Hashtbl.replace state.pagemap (l.pageno, gen) pageopaque;
1277 let preloadedpages =
1278 if conf.preload
1279 then preloadlayout state.x state.y state.winw state.winh
1280 else state.layout
1282 let evict () =
1283 let set = List.fold_left (fun s l -> IntSet.add l.pageno s)
1284 IntSet.empty preloadedpages
1286 let evictedpages =
1287 Hashtbl.fold (fun ((pageno, _) as key) opaque accu ->
1288 if not (IntSet.mem pageno set)
1289 then (
1290 wcmd "freepage %s" (~> opaque);
1291 key :: accu
1293 else accu
1294 ) state.pagemap []
1296 List.iter (Hashtbl.remove state.pagemap) evictedpages;
1298 evict ();
1299 state.currently <- Idle;
1300 if gen = state.gen
1301 then (
1302 tilepage l.pageno pageopaque state.layout;
1303 load state.layout;
1304 load preloadedpages;
1305 let visible = pagevisible state.layout l.pageno in
1306 if visible
1307 then (
1308 match state.mode with
1309 | LinkNav (Ltnotready (pageno, dir)) ->
1310 if pageno = l.pageno
1311 then (
1312 let link =
1313 let ld =
1314 if dir = 0
1315 then LDfirstvisible (l.pagex, l.pagey, dir)
1316 else (
1317 if dir > 0 then LDfirst else LDlast
1320 findlink pageopaque ld
1322 match link with
1323 | Lnotfound -> ()
1324 | Lfound n ->
1325 showlinktype (getlink pageopaque n);
1326 state.mode <- LinkNav (Ltexact (l.pageno, n))
1328 | LinkNav (Ltgendir _)
1329 | LinkNav (Ltexact _)
1330 | View
1331 | Birdseye _
1332 | Textentry _ -> ()
1335 if visible && layoutready state.layout
1336 then (
1337 postRedisplay "page";
1341 | Idle | Tiling _ | Outlining _ ->
1342 dolog "Inconsistent loading state";
1343 logcurrently state.currently;
1344 exit 1
1347 | "tile" , args ->
1348 let (x, y, opaques, size, t) =
1349 scan args "%u %u %s %u %f"
1350 (fun x y p size t -> (x, y, p, size, t))
1352 let opaque = ~< opaques in
1353 begin match state.currently with
1354 | Tiling (l, pageopaque, cs, angle, gen, col, row, tilew, tileh) ->
1355 vlog "tile %d [%d,%d] took %f sec" l.pageno col row t;
1357 unmappbo opaque;
1358 if tilew != conf.tilew || tileh != conf.tileh
1359 then (
1360 wcmd "freetile %s" (~> opaque);
1361 state.currently <- Idle;
1362 load state.layout;
1364 else (
1365 puttileopaque l col row gen cs angle opaque size t;
1366 state.memused <- state.memused + size;
1367 state.uioh#infochanged Memused;
1368 gctiles ();
1369 Queue.push ((l.pageno, gen, cs, angle, l.pagew, l.pageh, col, row),
1370 opaque, size) state.tilelru;
1372 state.currently <- Idle;
1373 if gen = state.gen
1374 && conf.colorspace = cs
1375 && conf.angle = angle
1376 && tilevisible state.layout l.pageno x y
1377 then conttiling l.pageno pageopaque;
1379 preload state.layout;
1380 if gen = state.gen
1381 && conf.colorspace = cs
1382 && conf.angle = angle
1383 && tilevisible state.layout l.pageno x y
1384 && layoutready state.layout
1385 then postRedisplay "tile nothrottle";
1388 | Idle | Loading _ | Outlining _ ->
1389 dolog "Inconsistent tiling state";
1390 logcurrently state.currently;
1391 exit 1
1394 | "pdim", args ->
1395 let (n, w, h, _) as pdim =
1396 scan args "%u %u %u %u" (fun n w h x -> n, w, h, x)
1398 let pdim =
1399 match conf.fitmodel with
1400 | FitWidth -> pdim
1401 | FitPage | FitProportional ->
1402 match conf.columns with
1403 | Csplit _ -> (n, w, h, 0)
1404 | Csingle _ | Cmulti _ -> pdim
1406 state.pdims <- pdim :: state.pdims;
1407 state.uioh#infochanged Pdim
1409 | "o", args ->
1410 let (l, n, t, h, pos) =
1411 scan args "%u %u %d %u %n" (fun l n t h pos -> l, n, t, h, pos)
1413 let s = String.sub args pos (String.length args - pos) in
1414 addoutline (s, l, Oanchor (n, float t /. float h, 0.0))
1416 | "ou", args ->
1417 let (l, len, pos) = scan args "%u %u %n" (fun l len pos -> l, len, pos) in
1418 let s = String.sub args pos len in
1419 let pos2 = pos + len + 1 in
1420 let uri = String.sub args pos2 (String.length args - pos2) in
1421 addoutline (s, l, Ouri uri)
1423 | "on", args ->
1424 let (l, pos) = scan args "%u %n" (fun l pos -> l, pos) in
1425 let s = String.sub args pos (String.length args - pos) in
1426 addoutline (s, l, Onone)
1428 | "a", args ->
1429 let (n, l, t) = scan args "%u %d %d" (fun n l t -> n, l, t) in
1430 state.reprf <- (fun () -> gotopagexy n (float l) (float t))
1432 | "info", args ->
1433 let c, v = splitatchar args '\t' in
1434 let s =
1435 if nonemptystr v
1436 then
1437 if c = "Title"
1438 then (
1439 conf.title <- v;
1440 if not !ignoredoctitlte
1441 then Wsi.settitle v;
1442 args
1444 else
1445 if let len = String.length c in
1446 len > 6 && ((String.sub c (len-4) 4) = "date")
1447 then (
1448 if String.length v >= 7 && v.[0] = 'D' && v.[1] = ':'
1449 then
1450 let b = Buffer.create 10 in
1451 Printf.bprintf b "%s\t" c;
1452 let sub p l c =
1454 Buffer.add_substring b v p l;
1455 Buffer.add_char b c;
1456 with exn -> Buffer.add_string b @@ exntos exn
1458 sub 2 4 '/';
1459 sub 6 2 '/';
1460 sub 8 2 ' ';
1461 sub 10 2 ':';
1462 sub 12 2 ':';
1463 sub 14 2 ' ';
1464 Buffer.add_char b '[';
1465 Buffer.add_string b v;
1466 Buffer.add_char b ']';
1467 Buffer.contents b
1468 else args
1470 else args
1471 else args
1473 state.docinfo <- (1, s) :: state.docinfo
1475 | "infoend", "" ->
1476 state.docinfo <- List.rev state.docinfo;
1477 state.uioh#infochanged Docinfo
1479 | "pass", args ->
1480 if args = "fail"
1481 then Wsi.settitle "Wrong password";
1482 let password = getpassword () in
1483 if emptystr password
1484 then error "document is password protected"
1485 else opendoc state.path password
1487 | _ -> error "unknown cmd `%S'" cmds
1490 let onhist cb =
1491 let rc = cb.rc in
1492 let action = function
1493 | HCprev -> cbget cb ~-1
1494 | HCnext -> cbget cb 1
1495 | HCfirst -> cbget cb ~-(cb.rc)
1496 | HClast -> cbget cb (cb.len - 1 - cb.rc)
1497 and cancel () = cb.rc <- rc
1498 in (action, cancel)
1501 let search pattern forward =
1502 match conf.columns with
1503 | Csplit _ -> impmsg "searching does not work properly in split columns mode"
1504 | Csingle _ | Cmulti _ ->
1505 if nonemptystr pattern
1506 then
1507 let pn, py =
1508 match state.layout with
1509 | [] -> 0, 0
1510 | l :: _ -> l.pageno, (l.pagey + if forward then 0 else 0*l.pagevh)
1512 wcmd "search %d %d %d %d,%s\000"
1513 (btod conf.icase) pn py (btod forward) pattern;
1516 let intentry text key =
1517 let text =
1518 if emptystr text && key = Keys.Ascii '-'
1519 then addchar text '-'
1520 else
1521 match [@warning "-4"] key with
1522 | Keys.Ascii ('0'..'9' as c) -> addchar text c
1523 | _ ->
1524 state.text <- "invalid key";
1525 text
1527 TEcont text
1530 let linknact f s =
1531 if nonemptystr s
1532 then (
1533 let n =
1534 let l = String.length s in
1535 let rec loop pos n =
1536 if pos = l
1537 then n
1538 else
1539 let m = Char.code s.[pos] - (if pos = 0 && l > 1 then 96 else 97) in
1540 loop (pos+1) (n*26 + m)
1541 in loop 0 0
1543 let rec loop n = function
1544 | [] -> ()
1545 | l :: rest ->
1546 match getopaque l.pageno with
1547 | None -> loop n rest
1548 | Some opaque ->
1549 let m = getlinkcount opaque in
1550 if n < m
1551 then (
1552 let under = getlink opaque n in
1553 f under
1555 else loop (n-m) rest
1557 loop n state.layout;
1561 let linknentry text key = match [@warning "-4"] key with
1562 | Keys.Ascii c ->
1563 let text = addchar text c in
1564 linknact (fun under -> state.text <- undertext under) text;
1565 TEcont text
1566 | _ ->
1567 state.text <- Printf.sprintf "invalid key";
1568 TEcont text
1571 let textentry text key = match [@warning "-4"] key with
1572 | Keys.Ascii c -> TEcont (addchar text c)
1573 | Keys.Code c -> TEcont (text ^ toutf8 c)
1574 | _ -> TEcont text
1577 let reqlayout angle fitmodel =
1578 if nogeomcmds state.geomcmds
1579 then state.anchor <- getanchor ();
1580 conf.angle <- angle mod 360;
1581 if conf.angle != 0
1582 then (
1583 match state.mode with
1584 | LinkNav _ -> state.mode <- View
1585 | Birdseye _ | Textentry _ | View -> ()
1587 conf.fitmodel <- fitmodel;
1588 invalidate "reqlayout"
1589 (fun () ->
1590 wcmd "reqlayout %d %d %d"
1591 conf.angle (FMTE.to_int conf.fitmodel) (stateh state.winh)
1595 let settrim trimmargins trimfuzz =
1596 if nogeomcmds state.geomcmds
1597 then state.anchor <- getanchor ();
1598 conf.trimmargins <- trimmargins;
1599 conf.trimfuzz <- trimfuzz;
1600 let x0, y0, x1, y1 = trimfuzz in
1601 invalidate "settrim"
1602 (fun () -> wcmd "settrim %d %d %d %d %d"
1603 (btod conf.trimmargins) x0 y0 x1 y1);
1604 flushpages ();
1607 let setzoom zoom =
1608 let zoom = max 0.0001 zoom in
1609 if zoom <> conf.zoom
1610 then (
1611 state.prevzoom <- (conf.zoom, state.x);
1612 conf.zoom <- zoom;
1613 reshape state.winw state.winh;
1614 state.text <- Printf.sprintf "zoom is now %-5.2f" (zoom *. 100.0);
1618 let pivotzoom ?(vw=min state.w state.winw)
1619 ?(vh=min (state.maxy-state.y) state.winh)
1620 ?(x=vw/2) ?(y=vh/2) zoom =
1621 let w = float state.w /. zoom in
1622 let hw = w /. 2.0 in
1623 let ratio = float vh /. float vw in
1624 let hh = hw *. ratio in
1625 let x0 = float x -. hw
1626 and y0 = float y -. hh in
1627 gotoxy (state.x - truncate x0) (state.y + truncate y0);
1628 setzoom zoom;
1631 let pivotzoom ?vw ?vh ?x ?y zoom =
1632 if nogeomcmds state.geomcmds
1633 then
1634 if zoom > 1.0
1635 then pivotzoom ?vw ?vh ?x ?y zoom
1636 else setzoom zoom
1639 let setcolumns mode columns coverA coverB =
1640 state.prevcolumns <- Some (conf.columns, conf.zoom);
1641 if columns < 0
1642 then (
1643 if isbirdseye mode
1644 then impmsg "split mode doesn't work in bird's eye"
1645 else (
1646 conf.columns <- Csplit (-columns, E.a);
1647 state.x <- 0;
1648 conf.zoom <- 1.0;
1651 else (
1652 if columns < 2
1653 then (
1654 conf.columns <- Csingle E.a;
1655 state.x <- 0;
1656 setzoom 1.0;
1658 else (
1659 conf.columns <- Cmulti ((columns, coverA, coverB), E.a);
1660 conf.zoom <- 1.0;
1663 reshape state.winw state.winh;
1666 let resetmstate () =
1667 state.mstate <- Mnone;
1668 Wsi.setcursor Wsi.CURSOR_INHERIT;
1671 let enterbirdseye () =
1672 let zoom = float conf.thumbw /. float state.winw in
1673 let birdseyepageno =
1674 let cy = state.winh / 2 in
1675 let fold = function
1676 | [] -> 0
1677 | l :: rest ->
1678 let rec fold best = function
1679 | [] -> best.pageno
1680 | l :: rest ->
1681 let d = cy - (l.pagedispy + l.pagevh/2)
1682 and dbest = cy - (best.pagedispy + best.pagevh/2) in
1683 if abs d < abs dbest
1684 then fold l rest
1685 else best.pageno
1686 in fold l rest
1688 fold state.layout
1690 state.mode <-
1691 Birdseye (
1692 { conf with zoom = conf.zoom },
1693 state.x, birdseyepageno, -1, getanchor ()
1695 resetmstate ();
1696 conf.zoom <- zoom;
1697 conf.presentation <- false;
1698 conf.interpagespace <- 10;
1699 conf.hlinks <- false;
1700 conf.fitmodel <- FitPage;
1701 state.x <- 0;
1702 conf.columns <- (
1703 match conf.beyecolumns with
1704 | Some c ->
1705 conf.zoom <- 1.0;
1706 Cmulti ((c, 0, 0), E.a)
1707 | None -> Csingle E.a
1709 if conf.verbose
1710 then
1711 state.text <- Printf.sprintf "birds eye mode on (zoom %3.1f%%)"
1712 (100.0*.zoom)
1713 else state.text <- E.s;
1714 reshape state.winw state.winh;
1717 let leavebirdseye (c, leftx, pageno, _, anchor) goback =
1718 state.mode <- View;
1719 conf.zoom <- c.zoom;
1720 conf.presentation <- c.presentation;
1721 conf.interpagespace <- c.interpagespace;
1722 conf.hlinks <- c.hlinks;
1723 conf.fitmodel <- c.fitmodel;
1724 conf.beyecolumns <- (
1725 match conf.columns with
1726 | Cmulti ((c, _, _), _) -> Some c
1727 | Csingle _ -> None
1728 | Csplit _ -> error "leaving bird's eye split mode"
1730 conf.columns <- (
1731 match c.columns with
1732 | Cmulti (c, _) -> Cmulti (c, E.a)
1733 | Csingle _ -> Csingle E.a
1734 | Csplit (c, _) -> Csplit (c, E.a)
1736 if conf.verbose
1737 then
1738 state.text <- Printf.sprintf "birds eye mode off (zoom %3.1f%%)"
1739 (100.0*.conf.zoom);
1740 reshape state.winw state.winh;
1741 state.anchor <- if goback then anchor else (pageno, 0.0, 1.0);
1742 state.x <- leftx;
1745 let togglebirdseye () =
1746 match state.mode with
1747 | Birdseye vals -> leavebirdseye vals true
1748 | View -> enterbirdseye ()
1749 | Textentry _ | LinkNav _ -> ()
1752 let upbirdseye incr (conf, leftx, pageno, hooverpageno, anchor) =
1753 let pageno = max 0 (pageno - incr) in
1754 let rec loop = function
1755 | [] -> gotopage1 pageno 0
1756 | l :: _ when l.pageno = pageno ->
1757 if l.pagedispy >= 0 && l.pagey = 0
1758 then postRedisplay "upbirdseye"
1759 else gotopage1 pageno 0
1760 | _ :: rest -> loop rest
1762 loop state.layout;
1763 state.text <- E.s;
1764 state.mode <- Birdseye (conf, leftx, pageno, hooverpageno, anchor)
1767 let downbirdseye incr (conf, leftx, pageno, hooverpageno, anchor) =
1768 let pageno = min (state.pagecount - 1) (pageno + incr) in
1769 state.mode <- Birdseye (conf, leftx, pageno, hooverpageno, anchor);
1770 let rec loop = function
1771 | [] ->
1772 let y, h = getpageyh pageno in
1773 let dy = (y - state.y) - (state.winh - h - conf.interpagespace) in
1774 gotoxy state.x (clamp dy)
1775 | l :: _ when l.pageno = pageno ->
1776 if l.pagevh != l.pageh
1777 then gotoxy state.x (clamp (l.pageh - l.pagevh + conf.interpagespace))
1778 else postRedisplay "downbirdseye"
1779 | _ :: rest -> loop rest
1781 loop state.layout;
1782 state.text <- E.s;
1785 let optentry mode _ key =
1786 let btos b = if b then "on" else "off" in
1787 match [@warning "-4"] key with
1788 | Keys.Ascii 'C' ->
1789 let ondone s =
1791 let n, a, b = multicolumns_of_string s in
1792 setcolumns mode n a b;
1793 with exn ->
1794 state.text <- Printf.sprintf "bad columns `%s': %s" s @@ exntos exn
1796 TEswitch ("columns: ", E.s, None, textentry, ondone, true)
1798 | Keys.Ascii 'Z' ->
1799 let ondone s =
1801 let zoom = float (int_of_string s) /. 100.0 in
1802 pivotzoom zoom
1803 with exn ->
1804 state.text <- Printf.sprintf "bad integer `%s': %s" s @@ exntos exn
1806 TEswitch ("zoom: ", E.s, None, intentry, ondone, true)
1808 | Keys.Ascii 'i' ->
1809 conf.icase <- not conf.icase;
1810 TEdone ("case insensitive search " ^ (btos conf.icase))
1812 | Keys.Ascii 'v' ->
1813 conf.verbose <- not conf.verbose;
1814 TEdone ("verbose " ^ (btos conf.verbose))
1816 | Keys.Ascii 'd' ->
1817 conf.debug <- not conf.debug;
1818 TEdone ("debug " ^ (btos conf.debug))
1820 | Keys.Ascii 'f' ->
1821 conf.underinfo <- not conf.underinfo;
1822 TEdone ("underinfo " ^ btos conf.underinfo)
1824 | Keys.Ascii 'T' ->
1825 settrim (not conf.trimmargins) conf.trimfuzz;
1826 TEdone ("trim margins " ^ btos conf.trimmargins)
1828 | Keys.Ascii 'I' ->
1829 conf.invert <- not conf.invert;
1830 TEdone ("invert colors " ^ btos conf.invert)
1832 | Keys.Ascii 'x' ->
1833 let ondone s =
1834 cbput state.hists.sel s;
1835 conf.selcmd <- s;
1837 TEswitch ("selection command: ", E.s, Some (onhist state.hists.sel),
1838 textentry, ondone, true)
1840 | Keys.Ascii 'M' ->
1841 if conf.pax == None
1842 then conf.pax <- Some 0.0
1843 else conf.pax <- None;
1844 TEdone ("PAX " ^ btos (conf.pax != None))
1846 | (Keys.Ascii c) ->
1847 state.text <- Printf.sprintf "bad option %d `%c'" (Char.code c) c;
1848 TEstop
1850 | _ -> TEcont state.text
1853 let adderrmsg src msg =
1854 Buffer.add_string state.errmsgs msg;
1855 state.newerrmsgs <- true;
1856 postRedisplay src
1859 let adderrfmt src fmt = Format.ksprintf (fun s -> adderrmsg src s) fmt;;
1861 class outlinelistview ~zebra ~source =
1862 let settext autonarrow s =
1863 if autonarrow
1864 then
1865 let ss = source#statestr in
1866 state.text <-
1867 if emptystr ss
1868 then "[" ^ s ^ "]"
1869 else "{" ^ ss ^ "} [" ^ s ^ "]"
1870 else state.text <- s
1872 object (self)
1873 inherit listview
1874 ~zebra
1875 ~helpmode:false
1876 ~source:(source :> lvsource)
1877 ~trusted:false
1878 ~modehash:(findkeyhash conf "outline")
1879 as super
1881 val m_autonarrow = false
1883 method! key key mask =
1884 let maxrows =
1885 if emptystr state.text
1886 then fstate.maxrows
1887 else fstate.maxrows - 2
1889 let calcfirst first active =
1890 if active > first
1891 then
1892 let rows = active - first in
1893 if rows > maxrows then active - maxrows else first
1894 else active
1896 let navigate incr =
1897 let active = m_active + incr in
1898 let active = bound active 0 (source#getitemcount - 1) in
1899 let first = calcfirst m_first active in
1900 postRedisplay "outline navigate";
1901 coe {< m_active = active; m_first = first >}
1903 let navscroll first =
1904 let active =
1905 let dist = m_active - first in
1906 if dist < 0
1907 then first
1908 else (
1909 if dist < maxrows
1910 then m_active
1911 else first + maxrows
1914 postRedisplay "outline navscroll";
1915 coe {< m_first = first; m_active = active >}
1917 let ctrl = Wsi.withctrl mask in
1918 let open Keys in
1919 match Wsi.kc2kt key with
1920 | Ascii 'a' when ctrl ->
1921 let text =
1922 if m_autonarrow
1923 then (
1924 source#denarrow;
1927 else (
1928 let pattern = source#renarrow in
1929 if nonemptystr m_qsearch
1930 then (source#narrow m_qsearch; m_qsearch)
1931 else pattern
1934 settext (not m_autonarrow) text;
1935 postRedisplay "toggle auto narrowing";
1936 coe {< m_first = 0; m_active = 0; m_autonarrow = not m_autonarrow >}
1938 | Ascii '/' when emptystr m_qsearch && not m_autonarrow ->
1939 settext true E.s;
1940 postRedisplay "toggle auto narrowing";
1941 coe {< m_first = 0; m_active = 0; m_autonarrow = true >}
1943 | Ascii 'n' when ctrl ->
1944 source#narrow m_qsearch;
1945 if not m_autonarrow
1946 then source#add_narrow_pattern m_qsearch;
1947 postRedisplay "outline ctrl-n";
1948 coe {< m_first = 0; m_active = 0 >}
1950 | Ascii 'S' when ctrl ->
1951 let active = source#calcactive (getanchor ()) in
1952 let first = firstof m_first active in
1953 postRedisplay "outline ctrl-s";
1954 coe {< m_first = first; m_active = active >}
1956 | Ascii 'u' when ctrl ->
1957 postRedisplay "outline ctrl-u";
1958 if m_autonarrow && nonemptystr m_qsearch
1959 then (
1960 ignore (source#renarrow);
1961 settext m_autonarrow E.s;
1962 coe {< m_first = 0; m_active = 0; m_qsearch = E.s >}
1964 else (
1965 source#del_narrow_pattern;
1966 let pattern = source#renarrow in
1967 let text =
1968 if emptystr pattern then E.s else "Narrowed to " ^ pattern
1970 settext m_autonarrow text;
1971 coe {< m_first = 0; m_active = 0; m_qsearch = E.s >}
1974 | Ascii 'l' when ctrl ->
1975 let first = max 0 (m_active - (fstate.maxrows / 2)) in
1976 postRedisplay "outline ctrl-l";
1977 coe {< m_first = first >}
1979 | Ascii '\t' when m_autonarrow ->
1980 if nonemptystr m_qsearch
1981 then (
1982 postRedisplay "outline list view tab";
1983 source#add_narrow_pattern m_qsearch;
1984 settext true E.s;
1985 coe {< m_qsearch = E.s >}
1987 else coe self
1989 | Escape when m_autonarrow ->
1990 if nonemptystr m_qsearch
1991 then source#add_narrow_pattern m_qsearch;
1992 super#key key mask
1994 | Enter when m_autonarrow ->
1995 if nonemptystr m_qsearch
1996 then source#add_narrow_pattern m_qsearch;
1997 super#key key mask
1999 | (Ascii _ | Code _) when m_autonarrow ->
2000 let pattern = m_qsearch ^ toutf8 key in
2001 postRedisplay "outlinelistview autonarrow add";
2002 source#narrow pattern;
2003 settext true pattern;
2004 coe {< m_first = 0; m_active = 0; m_qsearch = pattern >}
2006 | Backspace when m_autonarrow ->
2007 if emptystr m_qsearch
2008 then coe self
2009 else
2010 let pattern = withoutlastutf8 m_qsearch in
2011 postRedisplay "outlinelistview autonarrow backspace";
2012 ignore (source#renarrow);
2013 source#narrow pattern;
2014 settext true pattern;
2015 coe {< m_first = 0; m_active = 0; m_qsearch = pattern >}
2017 | Up when ctrl -> navscroll (max 0 (m_first - 1))
2019 | Down when ctrl ->
2020 navscroll (min (source#getitemcount - 1) (m_first + 1))
2022 | Up -> navigate ~-1
2023 | Down -> navigate 1
2024 | Prior -> navigate ~-(fstate.maxrows)
2025 | Next -> navigate fstate.maxrows
2027 | Right ->
2028 let o =
2029 if ctrl
2030 then (
2031 postRedisplay "outline ctrl right";
2032 {< m_pan = m_pan + 1 >}
2034 else self#updownlevel 1
2036 coe o
2038 | Left ->
2039 let o =
2040 if ctrl
2041 then (
2042 postRedisplay "outline ctrl left";
2043 {< m_pan = m_pan - 1 >}
2045 else self#updownlevel ~-1
2047 coe o
2049 | Home ->
2050 postRedisplay "outline home";
2051 coe {< m_first = 0; m_active = 0 >}
2053 | End ->
2054 let active = source#getitemcount - 1 in
2055 let first = max 0 (active - fstate.maxrows) in
2056 postRedisplay "outline end";
2057 coe {< m_active = active; m_first = first >}
2059 | Delete|Escape|Insert|Enter|Ascii _|Code _|Ctrl _|Backspace|Fn _ ->
2060 super#key key mask
2061 end;;
2063 let genhistoutlines () =
2064 Config.gethist ()
2065 |> List.sort (fun (_, c1, _, _, _, _) (_, c2, _, _, _, _) ->
2066 compare c2.lastvisit c1.lastvisit)
2067 |> List.map (fun ((path, c, _, _, _, origin) as hist) ->
2068 let path = if nonemptystr origin then origin else path in
2069 let base = mbtoutf8 @@ Filename.basename path in
2070 (base ^ "\000" ^ c.title, 1, Ohistory hist)
2074 let gotohist (path, c, bookmarks, x, anchor, origin) =
2075 Config.save leavebirdseye;
2076 state.anchor <- anchor;
2077 state.bookmarks <- bookmarks;
2078 state.origin <- origin;
2079 state.x <- x;
2080 setconf conf c;
2081 let x0, y0, x1, y1 = conf.trimfuzz in
2082 wcmd "trimset %d %d %d %d %d" (btod conf.trimmargins) x0 y0 x1 y1;
2083 reshape ~firsttime:true state.winw state.winh;
2084 opendoc path origin;
2085 setzoom c.zoom;
2088 let setcheckers enabled =
2089 match !checkerstexid with
2090 | None -> if enabled then checkerstexid := Some (makecheckers ())
2091 | Some id ->
2092 if not enabled
2093 then (
2094 GlTex.delete_texture id;
2095 checkerstexid := None;
2099 let describe_layout layout =
2100 let d =
2101 match layout with
2102 | [] -> "Page 0"
2103 | l :: [] -> Printf.sprintf "Page %d" (l.pageno+1)
2104 | l :: rest ->
2105 let rangestr a b =
2106 if a.pageno = b.pageno then Printf.sprintf "%d" (a.pageno+1)
2107 else Printf.sprintf "%d%s%d" (a.pageno+1)
2108 (if a.pageno+1 = b.pageno then ", " else Utf8syms.ellipsis)
2109 (b.pageno+1)
2111 let rec fold s la lb = function
2112 | [] -> Printf.sprintf "%s %s" s (rangestr la lb)
2113 | l :: rest when l.pageno = succ lb.pageno -> fold s la l rest
2114 | l :: rest -> fold (s ^ " " ^ rangestr la lb ^ ",") l l rest
2116 fold "Pages" l l rest
2118 let percent =
2119 let maxy = maxy () in
2120 if maxy <= 0
2121 then 100.
2122 else 100. *. (float state.y /. float maxy)
2124 Printf.sprintf "%s of %d [%.2f%%]" d state.pagecount percent
2127 let setpresentationmode v =
2128 let n = page_of_y state.y in
2129 state.anchor <- (n, 0.0, 1.0);
2130 conf.presentation <- v;
2131 if conf.fitmodel = FitPage
2132 then reqlayout conf.angle conf.fitmodel;
2133 represent ();
2136 let enterinfomode =
2137 let btos b = if b then Utf8syms.radical else E.s in
2138 let showextended = ref false in
2139 let showcolors = ref false in
2140 let leave mode _ = state.mode <- mode in
2141 let src =
2142 (object
2143 val mutable m_l = []
2144 val mutable m_a = E.a
2145 val mutable m_prev_uioh = nouioh
2146 val mutable m_prev_mode = View
2148 inherit lvsourcebase
2150 method reset prev_mode prev_uioh =
2151 m_a <- Array.of_list (List.rev m_l);
2152 m_l <- [];
2153 m_prev_mode <- prev_mode;
2154 m_prev_uioh <- prev_uioh;
2156 method int name get set =
2157 m_l <-
2158 (name, `int get, 1,
2159 Action (
2160 fun u ->
2161 let ondone s =
2162 try set (int_of_string s)
2163 with exn ->
2164 state.text <- Printf.sprintf "bad integer `%s': %s"
2165 s @@ exntos exn
2167 state.text <- E.s;
2168 let te = name ^ ": ", E.s, None, intentry, ondone, true in
2169 state.mode <- Textentry (te, leave m_prev_mode);
2171 )) :: m_l
2173 method int_with_suffix name get set =
2174 m_l <-
2175 (name, `intws get, 1,
2176 Action (
2177 fun u ->
2178 let ondone s =
2179 try set (int_of_string_with_suffix s)
2180 with exn ->
2181 state.text <- Printf.sprintf "bad integer `%s': %s"
2182 s @@ exntos exn
2184 state.text <- E.s;
2185 let te =
2186 name ^ ": ", E.s, None, intentry_with_suffix, ondone, true
2188 state.mode <- Textentry (te, leave m_prev_mode);
2190 )) :: m_l
2192 method bool ?(offset=1) ?(btos=btos) name get set =
2193 m_l <-
2194 (name, `bool (btos, get), offset, Action (
2195 fun u ->
2196 let v = get () in
2197 set (not v);
2199 )) :: m_l
2201 method color name get set =
2202 m_l <-
2203 (name, `color get, 1,
2204 Action (
2205 fun u ->
2206 let invalid = (nan, nan, nan) in
2207 let ondone s =
2208 let c =
2209 try color_of_string s
2210 with exn ->
2211 state.text <- Printf.sprintf "bad color `%s': %s"
2212 s @@ exntos exn;
2213 invalid
2215 if c <> invalid
2216 then set c;
2218 let te = name ^ ": ", E.s, None, textentry, ondone, true in
2219 state.text <- color_to_string (get ());
2220 state.mode <- Textentry (te, leave m_prev_mode);
2222 )) :: m_l
2224 method string name get set =
2225 m_l <-
2226 (name, `string get, 1,
2227 Action (
2228 fun u ->
2229 let ondone s = set s in
2230 let te = name ^ ": ", E.s, None, textentry, ondone, true in
2231 state.mode <- Textentry (te, leave m_prev_mode);
2233 )) :: m_l
2235 method colorspace name get set =
2236 m_l <-
2237 (name, `string get, 1,
2238 Action (
2239 fun _ ->
2240 let source =
2241 (object
2242 inherit lvsourcebase
2244 initializer
2245 m_active <- CSTE.to_int conf.colorspace;
2246 m_first <- 0;
2248 method getitemcount =
2249 Array.length CSTE.names
2250 method getitem n =
2251 (CSTE.names.(n), 0)
2252 method exit ~uioh ~cancel ~active ~first ~pan =
2253 ignore (uioh, first, pan);
2254 if not cancel then set active;
2255 None
2256 method hasaction _ = true
2257 end)
2259 state.text <- E.s;
2260 let modehash = findkeyhash conf "info" in
2261 coe (new listview ~zebra:false ~helpmode:false
2262 ~source ~trusted:true ~modehash)
2263 )) :: m_l
2265 method paxmark name get set =
2266 m_l <-
2267 (name, `string get, 1,
2268 Action (
2269 fun _ ->
2270 let source =
2271 (object
2272 inherit lvsourcebase
2274 initializer
2275 m_active <- MTE.to_int conf.paxmark;
2276 m_first <- 0;
2278 method getitemcount = Array.length MTE.names
2279 method getitem n = (MTE.names.(n), 0)
2280 method exit ~uioh ~cancel ~active ~first ~pan =
2281 ignore (uioh, first, pan);
2282 if not cancel then set active;
2283 None
2284 method hasaction _ = true
2285 end)
2287 state.text <- E.s;
2288 let modehash = findkeyhash conf "info" in
2289 coe (new listview ~zebra:false ~helpmode:false
2290 ~source ~trusted:true ~modehash)
2291 )) :: m_l
2293 method fitmodel name get set =
2294 m_l <-
2295 (name, `string get, 1,
2296 Action (
2297 fun _ ->
2298 let source =
2299 (object
2300 inherit lvsourcebase
2302 initializer
2303 m_active <- FMTE.to_int conf.fitmodel;
2304 m_first <- 0;
2306 method getitemcount = Array.length FMTE.names
2307 method getitem n = (FMTE.names.(n), 0)
2308 method exit ~uioh ~cancel ~active ~first ~pan =
2309 ignore (uioh, first, pan);
2310 if not cancel then set active;
2311 None
2312 method hasaction _ = true
2313 end)
2315 state.text <- E.s;
2316 let modehash = findkeyhash conf "info" in
2317 coe (new listview ~zebra:false ~helpmode:false
2318 ~source ~trusted:true ~modehash)
2319 )) :: m_l
2321 method caption s offset =
2322 m_l <- (s, `empty, offset, Noaction) :: m_l
2324 method caption2 s f offset =
2325 m_l <- (s, `string f, offset, Noaction) :: m_l
2327 method getitemcount = Array.length m_a
2329 method getitem n =
2330 let tostr = function
2331 | `int f -> string_of_int (f ())
2332 | `intws f -> string_with_suffix_of_int (f ())
2333 | `string f -> f ()
2334 | `color f -> color_to_string (f ())
2335 | `bool (btos, f) -> btos (f ())
2336 | `empty -> E.s
2338 let name, t, offset, _ = m_a.(n) in
2339 ((let s = tostr t in
2340 if nonemptystr s
2341 then Printf.sprintf "%s\t%s" name s
2342 else name),
2343 offset)
2345 method exit ~uioh ~cancel ~active ~first ~pan =
2346 let uiohopt =
2347 if not cancel
2348 then (
2349 let uioh =
2350 match m_a.(active) with
2351 | _, _, _, Action f -> f uioh
2352 | _, _, _, Noaction -> uioh
2354 Some uioh
2356 else None
2358 m_active <- active;
2359 m_first <- first;
2360 m_pan <- pan;
2361 uiohopt
2363 method hasaction n =
2364 match m_a.(n) with
2365 | _, _, _, Action _ -> true
2366 | _, _, _, Noaction -> false
2368 initializer m_active <- 1
2369 end)
2371 let rec fillsrc prevmode prevuioh =
2372 let sep () = src#caption E.s 0 in
2373 let colorp name get set =
2374 src#string name
2375 (fun () -> color_to_string (get ()))
2376 (fun v ->
2377 try set @@ color_of_string v
2378 with exn ->
2379 state.text <-
2380 Printf.sprintf "bad color `%s': %s" v @@ exntos exn
2383 let rgba name get set =
2384 src#string name
2385 (fun () -> get () |> rgba_to_string)
2386 (fun v ->
2387 try set @@ rgba_of_string v
2388 with exn ->
2389 state.text <-
2390 Printf.sprintf "bad color `%s': %s" v @@ exntos exn
2393 let oldmode = state.mode in
2394 let birdseye = isbirdseye state.mode in
2396 src#caption (if birdseye then "Setup (Bird's eye)" else "Setup") 0;
2398 src#bool "presentation mode"
2399 (fun () -> conf.presentation)
2400 (fun v -> setpresentationmode v);
2402 src#bool "ignore case in searches"
2403 (fun () -> conf.icase)
2404 (fun v -> conf.icase <- v);
2406 src#bool "preload"
2407 (fun () -> conf.preload)
2408 (fun v -> conf.preload <- v);
2410 src#bool "highlight links"
2411 (fun () -> conf.hlinks)
2412 (fun v -> conf.hlinks <- v);
2414 src#bool "under info"
2415 (fun () -> conf.underinfo)
2416 (fun v -> conf.underinfo <- v);
2418 src#fitmodel "fit model"
2419 (fun () -> FMTE.to_string conf.fitmodel)
2420 (fun v -> reqlayout conf.angle (FMTE.of_int v));
2422 src#bool "trim margins"
2423 (fun () -> conf.trimmargins)
2424 (fun v -> settrim v conf.trimfuzz; fillsrc prevmode prevuioh);
2426 sep ();
2427 src#int "inter-page space"
2428 (fun () -> conf.interpagespace)
2429 (fun n ->
2430 conf.interpagespace <- n;
2431 docolumns conf.columns;
2432 let pageno, py =
2433 match state.layout with
2434 | [] -> 0, 0
2435 | l :: _ -> l.pageno, l.pagey
2437 state.maxy <- calcheight ();
2438 let y = getpagey pageno in
2439 gotoxy state.x (y + py)
2442 src#int "page bias"
2443 (fun () -> conf.pagebias)
2444 (fun v -> conf.pagebias <- v);
2446 src#int "scroll step"
2447 (fun () -> conf.scrollstep)
2448 (fun n -> conf.scrollstep <- n);
2450 src#int "horizontal scroll step"
2451 (fun () -> conf.hscrollstep)
2452 (fun v -> conf.hscrollstep <- v);
2454 src#int "auto scroll step"
2455 (fun () ->
2456 match state.autoscroll with
2457 | Some step -> step
2458 | _ -> conf.autoscrollstep)
2459 (fun n ->
2460 let n = boundastep state.winh n in
2461 if state.autoscroll <> None
2462 then state.autoscroll <- Some n;
2463 conf.autoscrollstep <- n);
2465 src#int "zoom"
2466 (fun () -> truncate (conf.zoom *. 100.))
2467 (fun v -> pivotzoom ((float v) /. 100.));
2469 src#int "rotation"
2470 (fun () -> conf.angle)
2471 (fun v -> reqlayout v conf.fitmodel);
2473 src#int "scroll bar width"
2474 (fun () -> conf.scrollbw)
2475 (fun v ->
2476 conf.scrollbw <- v;
2477 reshape state.winw state.winh;
2480 src#int "scroll handle height"
2481 (fun () -> conf.scrollh)
2482 (fun v -> conf.scrollh <- v;);
2484 src#int "thumbnail width"
2485 (fun () -> conf.thumbw)
2486 (fun v ->
2487 conf.thumbw <- min 4096 v;
2488 match oldmode with
2489 | Birdseye beye ->
2490 leavebirdseye beye false;
2491 enterbirdseye ()
2492 | Textentry _
2493 | View
2494 | LinkNav _ -> ()
2497 let mode = state.mode in
2498 src#string "columns"
2499 (fun () ->
2500 match conf.columns with
2501 | Csingle _ -> "1"
2502 | Cmulti (multi, _) -> multicolumns_to_string multi
2503 | Csplit (count, _) -> "-" ^ string_of_int count
2505 (fun v ->
2506 let n, a, b = multicolumns_of_string v in
2507 setcolumns mode n a b);
2509 sep ();
2510 src#caption "Pixmap cache" 0;
2511 src#int_with_suffix "size (advisory)"
2512 (fun () -> conf.memlimit)
2513 (fun v -> conf.memlimit <- v);
2515 src#caption2 "used"
2516 (fun () ->
2517 Printf.sprintf "%s bytes, %d tiles"
2518 (string_with_suffix_of_int state.memused)
2519 (Hashtbl.length state.tilemap)) 1;
2521 sep ();
2522 src#caption "Layout" 0;
2523 src#caption2 "Dimension"
2524 (fun () -> Printf.sprintf "%dx%d (virtual %dx%d)"
2525 state.winw state.winh
2526 state.w state.maxy)
2528 if conf.debug
2529 then src#caption2 "Position" (fun () ->
2530 Printf.sprintf "%dx%d" state.x state.y
2532 else src#caption2 "Position" (fun () -> describe_layout state.layout) 1;
2534 sep ();
2535 src#bool ~offset:0 ~btos:(fun v -> if v then "(on)" else "(off)")
2536 "Save these parameters as global defaults at exit"
2537 (fun () -> conf.bedefault)
2538 (fun v -> conf.bedefault <- v);
2540 sep ();
2541 let btos b = Utf8syms.(if b then lguillemet else rguillemet) in
2542 src#bool ~offset:0 ~btos "Extended parameters"
2543 (fun () -> !showextended)
2544 (fun v -> showextended := v; fillsrc prevmode prevuioh);
2545 if !showextended
2546 then (
2547 src#bool "checkers"
2548 (fun () -> conf.checkers)
2549 (fun v -> conf.checkers <- v; setcheckers v);
2550 src#bool "update cursor"
2551 (fun () -> conf.updatecurs)
2552 (fun v -> conf.updatecurs <- v);
2553 src#bool "scroll-bar on the left"
2554 (fun () -> conf.leftscroll)
2555 (fun v -> conf.leftscroll <- v);
2556 src#bool "verbose"
2557 (fun () -> conf.verbose)
2558 (fun v -> conf.verbose <- v);
2559 src#bool "invert colors"
2560 (fun () -> conf.invert)
2561 (fun v -> conf.invert <- v);
2562 src#bool "max fit"
2563 (fun () -> conf.maxhfit)
2564 (fun v -> conf.maxhfit <- v);
2565 src#bool "pax mode"
2566 (fun () -> conf.pax != None)
2567 (fun v ->
2568 if v
2569 then conf.pax <- Some (now ())
2570 else conf.pax <- None);
2571 src#string "uri launcher"
2572 (fun () -> conf.urilauncher)
2573 (fun v -> conf.urilauncher <- v);
2574 src#string "path launcher"
2575 (fun () -> conf.pathlauncher)
2576 (fun v -> conf.pathlauncher <- v);
2577 src#string "tile size"
2578 (fun () -> Printf.sprintf "%dx%d" conf.tilew conf.tileh)
2579 (fun v ->
2581 let w, h = Scanf.sscanf v "%dx%d" (fun w h -> w, h) in
2582 conf.tilew <- max 64 w;
2583 conf.tileh <- max 64 h;
2584 flushtiles ();
2585 with exn ->
2586 state.text <- Printf.sprintf "bad tile size `%s': %s"
2587 v @@ exntos exn
2589 src#int "texture count"
2590 (fun () -> conf.texcount)
2591 (fun v ->
2592 if realloctexts v
2593 then conf.texcount <- v
2594 else impmsg "failed to set texture count please retry later"
2596 src#int "slice height"
2597 (fun () -> conf.sliceheight)
2598 (fun v ->
2599 conf.sliceheight <- v;
2600 wcmd "sliceh %d" conf.sliceheight;
2602 src#int "anti-aliasing level"
2603 (fun () -> conf.aalevel)
2604 (fun v ->
2605 conf.aalevel <- bound v 0 8;
2606 state.anchor <- getanchor ();
2607 opendoc state.path state.password;
2609 src#string "page scroll scaling factor"
2610 (fun () -> string_of_float conf.pgscale)
2611 (fun v ->
2612 try conf.pgscale <- float_of_string v
2613 with exn ->
2614 state.text <-
2615 Printf.sprintf "bad page scroll scaling factor `%s': %s" v
2616 @@ exntos exn
2618 src#int "ui font size"
2619 (fun () -> fstate.fontsize)
2620 (fun v -> setfontsize (bound v 5 100));
2621 src#int "hint font size"
2622 (fun () -> conf.hfsize)
2623 (fun v -> conf.hfsize <- bound v 5 100);
2624 src#string "trim fuzz"
2625 (fun () -> irect_to_string conf.trimfuzz)
2626 (fun v ->
2628 conf.trimfuzz <- irect_of_string v;
2629 if conf.trimmargins
2630 then settrim true conf.trimfuzz;
2631 with exn ->
2632 state.text <- Printf.sprintf "bad irect `%s': %s" v
2633 @@ exntos exn
2635 src#string "selection command"
2636 (fun () -> conf.selcmd)
2637 (fun v -> conf.selcmd <- v);
2638 src#string "synctex command"
2639 (fun () -> conf.stcmd)
2640 (fun v -> conf.stcmd <- v);
2641 src#string "pax command"
2642 (fun () -> conf.paxcmd)
2643 (fun v -> conf.paxcmd <- v);
2644 src#string "ask password command"
2645 (fun () -> conf.passcmd)
2646 (fun v -> conf.passcmd <- v);
2647 src#string "save path command"
2648 (fun () -> conf.savecmd)
2649 (fun v -> conf.savecmd <- v);
2650 src#colorspace "color space"
2651 (fun () -> CSTE.to_string conf.colorspace)
2652 (fun v ->
2653 conf.colorspace <- CSTE.of_int v;
2654 wcmd "cs %d" v;
2655 load state.layout;
2657 src#paxmark "pax mark method"
2658 (fun () -> MTE.to_string conf.paxmark)
2659 (fun v -> conf.paxmark <- MTE.of_int v);
2660 if bousable () && !opengl_has_pbo
2661 then
2662 src#bool "use PBO"
2663 (fun () -> conf.usepbo)
2664 (fun v -> conf.usepbo <- v);
2665 src#bool "mouse wheel scrolls pages"
2666 (fun () -> conf.wheelbypage)
2667 (fun v -> conf.wheelbypage <- v);
2668 src#bool "open remote links in a new instance"
2669 (fun () -> conf.riani)
2670 (fun v -> conf.riani <- v);
2671 src#bool "edit annotations inline"
2672 (fun () -> conf.annotinline)
2673 (fun v -> conf.annotinline <- v);
2674 src#bool "coarse positioning in presentation mode"
2675 (fun () -> conf.coarseprespos)
2676 (fun v -> conf.coarseprespos <- v);
2677 src#bool "use document CSS"
2678 (fun () -> conf.usedoccss)
2679 (fun v ->
2680 conf.usedoccss <- v;
2681 state.anchor <- getanchor ();
2682 opendoc state.path state.password;
2684 src#bool ~btos "colors"
2685 (fun () -> !showcolors)
2686 (fun v -> showcolors := v; fillsrc prevmode prevuioh);
2687 if !showcolors
2688 then (
2689 colorp " background"
2690 (fun () -> conf.bgcolor)
2691 (fun v -> conf.bgcolor <- v);
2692 rgba " scrollbar"
2693 (fun () -> conf.sbarcolor)
2694 (fun v -> conf.sbarcolor <- v);
2695 rgba " scrollbar handle"
2696 (fun () -> conf.sbarhndlcolor)
2697 (fun v -> conf.sbarhndlcolor <- v);
2701 sep ();
2702 src#caption "Document" 0;
2703 List.iter (fun (_, s) -> src#caption s 1) state.docinfo;
2704 src#caption2 "Pages"
2705 (fun () -> string_of_int state.pagecount) 1;
2706 src#caption2 "Dimensions"
2707 (fun () -> string_of_int (List.length state.pdims)) 1;
2708 if nonemptystr conf.css
2709 then src#caption2 "CSS" (fun () -> conf.css) 1;
2710 if conf.trimmargins
2711 then (
2712 sep ();
2713 src#caption "Trimmed margins" 0;
2714 src#caption2 "Dimensions"
2715 (fun () -> string_of_int (List.length state.pdims)) 1;
2718 sep ();
2719 src#caption "OpenGL" 0;
2720 src#caption (Printf.sprintf "Vendor\t%s" (GlMisc.get_string `vendor)) 1;
2721 src#caption (Printf.sprintf "Renderer\t%s" (GlMisc.get_string `renderer)) 1;
2723 sep ();
2724 src#caption "Location" 0;
2725 if nonemptystr state.origin
2726 then src#caption ("Orign\t" ^ mbtoutf8 state.origin) 1;
2727 src#caption ("Path\t" ^ mbtoutf8 state.path) 1;
2729 src#reset prevmode prevuioh;
2731 fun () ->
2732 state.text <- E.s;
2733 resetmstate ();
2734 let prevmode = state.mode
2735 and prevuioh = state.uioh in
2736 fillsrc prevmode prevuioh;
2737 let source = (src :> lvsource) in
2738 let modehash = findkeyhash conf "info" in
2739 state.uioh <-
2740 coe (object (self)
2741 inherit listview ~zebra:false ~helpmode:false
2742 ~source ~trusted:true ~modehash as super
2743 val mutable m_prevmemused = 0
2744 method! infochanged = function
2745 | Memused ->
2746 if m_prevmemused != state.memused
2747 then (
2748 m_prevmemused <- state.memused;
2749 postRedisplay "memusedchanged";
2751 | Pdim -> postRedisplay "pdimchanged"
2752 | Docinfo -> fillsrc prevmode prevuioh
2754 method! key key mask =
2755 if not (Wsi.withctrl mask)
2756 then
2757 match [@warning "-4"] Wsi.kc2kt key with
2758 | Keys.Left -> coe (self#updownlevel ~-1)
2759 | Keys.Right -> coe (self#updownlevel 1)
2760 | _ -> super#key key mask
2761 else super#key key mask
2762 end);
2763 postRedisplay "info";
2766 let enterhelpmode =
2767 let source =
2768 (object
2769 inherit lvsourcebase
2770 method getitemcount = Array.length state.help
2771 method getitem n =
2772 let s, l, _ = state.help.(n) in
2773 (s, l)
2775 method exit ~uioh ~cancel ~active ~first ~pan =
2776 let optuioh =
2777 if not cancel
2778 then (
2779 match state.help.(active) with
2780 | _, _, Action f -> Some (f uioh)
2781 | _, _, Noaction -> Some uioh
2783 else None
2785 m_active <- active;
2786 m_first <- first;
2787 m_pan <- pan;
2788 optuioh
2790 method hasaction n =
2791 match state.help.(n) with
2792 | _, _, Action _ -> true
2793 | _, _, Noaction -> false
2795 initializer
2796 m_active <- -1
2797 end)
2798 in fun () ->
2799 let modehash = findkeyhash conf "help" in
2800 resetmstate ();
2801 state.uioh <- coe (new listview
2802 ~zebra:false ~helpmode:true
2803 ~source ~trusted:true ~modehash);
2804 postRedisplay "help";
2807 let entermsgsmode =
2808 let msgsource =
2809 (object
2810 inherit lvsourcebase
2811 val mutable m_items = E.a
2813 method getitemcount = 1 + Array.length m_items
2815 method getitem n =
2816 if n = 0
2817 then "[Clear]", 0
2818 else m_items.(n-1), 0
2820 method exit ~uioh ~cancel ~active ~first ~pan =
2821 ignore uioh;
2822 if not cancel
2823 then (
2824 if active = 0
2825 then Buffer.clear state.errmsgs;
2827 m_active <- active;
2828 m_first <- first;
2829 m_pan <- pan;
2830 None
2832 method hasaction n =
2833 n = 0
2835 method reset =
2836 state.newerrmsgs <- false;
2837 let l = Str.split Utils.Re.crlf (Buffer.contents state.errmsgs) in
2838 m_items <- Array.of_list l
2840 initializer
2841 m_active <- 0
2842 end)
2843 in fun () ->
2844 state.text <- E.s;
2845 resetmstate ();
2846 msgsource#reset;
2847 let source = (msgsource :> lvsource) in
2848 let modehash = findkeyhash conf "listview" in
2849 state.uioh <-
2850 coe (object
2851 inherit listview ~zebra:false ~helpmode:false
2852 ~source ~trusted:false ~modehash as super
2853 method! display =
2854 if state.newerrmsgs
2855 then msgsource#reset;
2856 super#display
2857 end);
2858 postRedisplay "msgs";
2861 let getusertext s =
2862 let editor = getenvwithdef "EDITOR" E.s in
2863 if emptystr editor
2864 then E.s
2865 else
2866 let tmppath = Filename.temp_file "llpp" "note" in
2867 if nonemptystr s
2868 then (
2869 let oc = open_out tmppath in
2870 output_string oc s;
2871 close_out oc;
2873 let execstr = editor ^ " " ^ tmppath in
2874 let s =
2875 match spawn execstr [] with
2876 | exception exn ->
2877 impmsg "spawn(%S) failed: %s" execstr @@ exntos exn;
2879 | pid ->
2880 match Unix.waitpid [] pid with
2881 | exception exn ->
2882 impmsg "waitpid(%d) failed: %s" pid @@ exntos exn;
2884 | (_pid, status) ->
2885 match status with
2886 | Unix.WEXITED 0 -> filecontents tmppath
2887 | Unix.WEXITED n ->
2888 impmsg "editor process(%s) exited abnormally: %d" execstr n;
2890 | Unix.WSIGNALED n ->
2891 impmsg "editor process(%s) was killed by signal %d" execstr n;
2893 | Unix.WSTOPPED n ->
2894 impmsg "editor(%s) process was stopped by signal %d" execstr n;
2897 match Unix.unlink tmppath with
2898 | exception exn ->
2899 impmsg "failed to ulink %S: %s" tmppath @@ exntos exn;
2901 | () -> s
2904 let enterannotmode opaque slinkindex =
2905 let msgsource =
2906 (object
2907 inherit lvsourcebase
2908 val mutable m_text = E.s
2909 val mutable m_items = E.a
2911 method getitemcount = Array.length m_items
2913 method getitem n =
2914 let label, _func = m_items.(n) in
2915 label, 0
2917 method exit ~uioh ~cancel ~active ~first ~pan =
2918 ignore (uioh, first, pan);
2919 if not cancel
2920 then (
2921 let _label, func = m_items.(active) in
2922 func ()
2924 None
2926 method hasaction n = nonemptystr @@ fst m_items.(n)
2928 method reset s =
2929 let rec split accu b i =
2930 let p = b+i in
2931 if p = String.length s
2932 then (String.sub s b (p-b), unit) :: accu
2933 else
2934 if (i > 70 && s.[p] = ' ') || s.[p] = '\r' || s.[p] = '\n'
2935 then
2936 let ss = if i = 0 then E.s else String.sub s b i in
2937 split ((ss, unit)::accu) (p+1) 0
2938 else split accu b (i+1)
2940 let cleanup () =
2941 wcmd "freepage %s" (~> opaque);
2942 let keys =
2943 Hashtbl.fold (fun key opaque' accu ->
2944 if opaque' = opaque'
2945 then key :: accu else accu) state.pagemap []
2947 List.iter (Hashtbl.remove state.pagemap) keys;
2948 flushtiles ();
2949 gotoxy state.x state.y
2951 let dele () =
2952 delannot opaque slinkindex;
2953 cleanup ();
2955 let edit inline () =
2956 let update s =
2957 if emptystr s
2958 then dele ()
2959 else (
2960 modannot opaque slinkindex s;
2961 cleanup ();
2964 if inline
2965 then
2966 let mode = state.mode in
2967 state.mode <-
2968 Textentry (
2969 ("annotation: ", m_text, None, textentry, update, true),
2970 fun _ -> state.mode <- mode
2972 state.text <- E.s;
2973 enttext ();
2974 else
2975 let s = getusertext m_text in
2976 update s
2978 m_text <- s;
2979 m_items <-
2980 ( "[Copy]", fun () -> selstring conf.selcmd m_text)
2981 :: ("[Delete]", dele)
2982 :: ("[Edit]", edit conf.annotinline)
2983 :: (E.s, unit)
2984 :: split [] 0 0 |> List.rev |> Array.of_list
2986 initializer
2987 m_active <- 0
2988 end)
2990 state.text <- E.s;
2991 let s = getannotcontents opaque slinkindex in
2992 resetmstate ();
2993 msgsource#reset s;
2994 let source = (msgsource :> lvsource) in
2995 let modehash = findkeyhash conf "listview" in
2996 state.uioh <- coe (object
2997 inherit listview ~zebra:false ~helpmode:false
2998 ~source ~trusted:false ~modehash
2999 end);
3000 postRedisplay "enterannotmode";
3003 let gotoremote spec =
3004 let filename, dest = splitatchar spec '#' in
3005 let getpath filename =
3006 let path =
3007 if nonemptystr filename
3008 then
3009 if Filename.is_relative filename
3010 then
3011 let dir = Filename.dirname state.path in
3012 let dir =
3013 if Filename.is_implicit dir
3014 then Filename.concat (Sys.getcwd ()) dir
3015 else dir
3017 Filename.concat dir filename
3018 else filename
3019 else E.s
3021 if Sys.file_exists path
3022 then path
3023 else E.s
3025 let path = getpath filename in
3026 let dospawn lcmd =
3027 if conf.riani
3028 then
3029 let cmd = Lazy.force_val lcmd in
3030 match spawn cmd with
3031 | _pid -> ()
3032 | exception exn -> dolog "failed to execute `%s': %s" cmd @@ exntos exn
3033 else
3034 let anchor = getanchor () in
3035 let ranchor = state.path, state.password, anchor, state.origin in
3036 state.origin <- E.s;
3037 state.ranchors <- ranchor :: state.ranchors;
3038 opendoc path E.s;
3040 if substratis spec 0 "page="
3041 then
3042 match Scanf.sscanf spec "page=%d" (fun n -> n) with
3043 | pageno ->
3044 state.anchor <- (pageno, 0.0, 0.0);
3045 dospawn @@ lazy (Printf.sprintf "%s -page %d %S" !selfexec pageno path);
3046 | exception exn ->
3047 adderrfmt "error parsing remote destination" "page: %s" @@ exntos exn
3048 else (
3049 state.nameddest <- dest;
3050 dospawn @@ lazy (!selfexec ^ " " ^ path ^ " -dest " ^ dest)
3054 let gotounder = function
3055 | Ulinkuri s when isexternallink s ->
3056 if substratis s 0 "file://"
3057 then gotoremote @@ String.sub s 7 (String.length s - 7)
3058 else Help.gotouri conf.urilauncher s
3059 | Ulinkuri s ->
3060 let pageno, x, y = uritolocation s in
3061 addnav ();
3062 gotopagexy pageno x y
3063 | Utext _ | Unone -> ()
3064 | Uannotation (opaque, slinkindex) -> enterannotmode opaque slinkindex
3067 let gotooutline (_, _, kind) =
3068 match kind with
3069 | Onone -> ()
3070 | Oanchor anchor ->
3071 let (pageno, y, _) = anchor in
3072 let y = getanchory
3073 (if conf.presentation then (pageno, y, 1.0) else anchor)
3075 addnav ();
3076 gotoxy state.x y
3077 | Ouri uri -> gotounder (Ulinkuri uri)
3078 | Olaunch cmd -> error "gotounder (Ulaunch %S)" cmd
3079 | Oremote (remote, pageno) ->
3080 error "gotounder (Uremote (%S,%d) )" remote pageno
3081 | Ohistory hist -> gotohist hist
3082 | Oremotedest (path, dest) ->
3083 error "gotounder (Uremotedest (%S, %S))" path dest
3086 class outlinesoucebase fetchoutlines = object (self)
3087 inherit lvsourcebase
3088 val mutable m_items = E.a
3089 val mutable m_minfo = E.a
3090 val mutable m_orig_items = E.a
3091 val mutable m_orig_minfo = E.a
3092 val mutable m_narrow_patterns = []
3093 val mutable m_gen = -1
3095 method getitemcount = Array.length m_items
3097 method getitem n =
3098 let s, n, _ = m_items.(n) in
3099 (s, n+0)
3101 method exit ~(uioh:uioh) ~cancel ~active ~(first:int) ~pan : uioh option =
3102 ignore (uioh, first);
3103 let items, minfo =
3104 if m_narrow_patterns = []
3105 then m_orig_items, m_orig_minfo
3106 else m_items, m_minfo
3108 m_pan <- pan;
3109 if not cancel
3110 then (
3111 m_items <- items;
3112 m_minfo <- minfo;
3113 gotooutline m_items.(active);
3115 else (
3116 m_items <- items;
3117 m_minfo <- minfo;
3119 None
3121 method hasaction (_:int) = true
3123 method greetmsg =
3124 if Array.length m_items != Array.length m_orig_items
3125 then
3126 let s =
3127 match m_narrow_patterns with
3128 | one :: [] -> one
3129 | many -> String.concat Utf8syms.ellipsis (List.rev many)
3131 "Narrowed to " ^ s ^ " (ctrl-u to restore)"
3132 else E.s
3134 method statestr =
3135 match m_narrow_patterns with
3136 | [] -> E.s
3137 | one :: [] -> one
3138 | head :: _ -> Utf8syms.ellipsis ^ head
3140 method narrow pattern =
3141 match Str.regexp_case_fold pattern with
3142 | exception _ -> ()
3143 | re ->
3144 let rec loop accu minfo n =
3145 if n = -1
3146 then (
3147 m_items <- Array.of_list accu;
3148 m_minfo <- Array.of_list minfo;
3150 else
3151 let (s, _, _) as o = m_items.(n) in
3152 let accu, minfo =
3153 match Str.search_forward re s 0 with
3154 | exception Not_found -> accu, minfo
3155 | first -> o :: accu, (first, Str.match_end ()) :: minfo
3157 loop accu minfo (n-1)
3159 loop [] [] (Array.length m_items - 1)
3161 method! getminfo = m_minfo
3163 method denarrow =
3164 m_orig_items <- fetchoutlines ();
3165 m_minfo <- m_orig_minfo;
3166 m_items <- m_orig_items
3168 method add_narrow_pattern pattern =
3169 m_narrow_patterns <- pattern :: m_narrow_patterns
3171 method del_narrow_pattern =
3172 match m_narrow_patterns with
3173 | _ :: rest -> m_narrow_patterns <- rest
3174 | [] -> ()
3176 method renarrow =
3177 self#denarrow;
3178 match m_narrow_patterns with
3179 | pattern :: [] -> self#narrow pattern; pattern
3180 | list ->
3181 List.fold_left (fun accu pattern ->
3182 self#narrow pattern;
3183 pattern ^ Utf8syms.ellipsis ^ accu) E.s list
3185 method calcactive (_:anchor) = 0
3187 method reset anchor items =
3188 if state.gen != m_gen
3189 then (
3190 m_orig_items <- items;
3191 m_items <- items;
3192 m_narrow_patterns <- [];
3193 m_minfo <- E.a;
3194 m_orig_minfo <- E.a;
3195 m_gen <- state.gen;
3197 else (
3198 if items != m_orig_items
3199 then (
3200 m_orig_items <- items;
3201 if m_narrow_patterns == []
3202 then m_items <- items;
3205 let active = self#calcactive anchor in
3206 m_active <- active;
3207 m_first <- firstof m_first active
3211 let outlinesource fetchoutlines =
3212 (object
3213 inherit outlinesoucebase fetchoutlines
3214 method! calcactive anchor =
3215 let rely = getanchory anchor in
3216 let rec loop n best bestd =
3217 if n = Array.length m_items
3218 then best
3219 else
3220 let _, _, kind = m_items.(n) in
3221 match kind with
3222 | Oanchor anchor ->
3223 let orely = getanchory anchor in
3224 let d = abs (orely - rely) in
3225 if d < bestd
3226 then loop (n+1) n d
3227 else loop (n+1) best bestd
3228 | Onone | Oremote _ | Olaunch _
3229 | Oremotedest _ | Ouri _ | Ohistory _ ->
3230 loop (n+1) best bestd
3232 loop 0 ~-1 max_int
3233 end)
3236 let enteroutlinemode, enterbookmarkmode, enterhistmode =
3237 let mkselector sourcetype =
3238 let fetchoutlines () =
3239 match sourcetype with
3240 | `bookmarks -> Array.of_list state.bookmarks
3241 | `outlines -> state.outlines
3242 | `history -> genhistoutlines () |> Array.of_list
3244 let source =
3245 if sourcetype = `history
3246 then new outlinesoucebase fetchoutlines
3247 else outlinesource fetchoutlines
3249 (fun errmsg ->
3250 let outlines = fetchoutlines () in
3251 if Array.length outlines = 0
3252 then showtext ' ' errmsg
3253 else (
3254 resetmstate ();
3255 Wsi.setcursor Wsi.CURSOR_INHERIT;
3256 let anchor = getanchor () in
3257 source#reset anchor outlines;
3258 state.text <- source#greetmsg;
3259 state.uioh <-
3260 coe (new outlinelistview ~zebra:(sourcetype=`history) ~source);
3261 postRedisplay "enter selector";
3265 let mkenter sourcetype errmsg = fun () -> mkselector sourcetype errmsg in
3266 ( mkenter `outlines "document has no outline"
3267 , mkenter `bookmarks "document has no bookmarks (yet)"
3268 , mkenter `history "history is empty" )
3271 let quickbookmark ?title () =
3272 match state.layout with
3273 | [] -> ()
3274 | l :: _ ->
3275 let title =
3276 match title with
3277 | None ->
3278 Unix.(
3279 let tm = localtime (now ()) in
3280 Printf.sprintf
3281 "Quick (page %d) (bookmarked on %02d/%02d/%d at %02d:%02d)"
3282 (l.pageno+1)
3283 tm.tm_mday (tm.tm_mon+1) (tm.tm_year+1900) tm.tm_hour tm.tm_min
3285 | Some title -> title
3287 state.bookmarks <- (title, 0, Oanchor (getanchor1 l)) :: state.bookmarks
3290 let setautoscrollspeed step goingdown =
3291 let incr = max 1 ((abs step) / 2) in
3292 let incr = if goingdown then incr else -incr in
3293 let astep = boundastep state.winh (step + incr) in
3294 state.autoscroll <- Some astep;
3297 let canpan () =
3298 match conf.columns with
3299 | Csplit _ -> true
3300 | Csingle _ | Cmulti _ -> state.x != 0 || conf.zoom > 1.0
3303 let panbound x = bound x (-state.w) state.winw;;
3305 let existsinrow pageno (columns, coverA, coverB) p =
3306 let last = ((pageno - coverA) mod columns) + columns in
3307 let rec any = function
3308 | [] -> false
3309 | l :: rest ->
3310 if l.pageno = coverA - 1 || l.pageno = state.pagecount - coverB
3311 then p l
3312 else (
3313 if not (p l)
3314 then (if l.pageno = last then false else any rest)
3315 else true
3318 any state.layout
3321 let nextpage () =
3322 match state.layout with
3323 | [] ->
3324 let pageno = page_of_y state.y in
3325 gotoxy state.x (getpagey (pageno+1))
3326 | l :: rest ->
3327 match conf.columns with
3328 | Csingle _ ->
3329 if conf.presentation && rest == [] && l.pageh > l.pagey + l.pagevh
3330 then
3331 let y = clamp (pgscale state.winh) in
3332 gotoxy state.x y
3333 else
3334 let pageno = min (l.pageno+1) (state.pagecount-1) in
3335 gotoxy state.x (getpagey pageno)
3336 | Cmulti ((c, _, _) as cl, _) ->
3337 if conf.presentation
3338 && (existsinrow l.pageno cl
3339 (fun l -> l.pageh > l.pagey + l.pagevh))
3340 then
3341 let y = clamp (pgscale state.winh) in
3342 gotoxy state.x y
3343 else
3344 let pageno = min (l.pageno+c) (state.pagecount-1) in
3345 gotoxy state.x (getpagey pageno)
3346 | Csplit (n, _) ->
3347 if l.pageno < state.pagecount - 1 || l.pagecol < n - 1
3348 then
3349 let pagey, pageh = getpageyh l.pageno in
3350 let pagey = pagey + pageh * l.pagecol in
3351 let ips = if l.pagecol = 0 then 0 else conf.interpagespace in
3352 gotoxy state.x (pagey + pageh + ips)
3355 let prevpage () =
3356 match state.layout with
3357 | [] ->
3358 let pageno = page_of_y state.y in
3359 gotoxy state.x (getpagey (pageno-1))
3360 | l :: _ ->
3361 match conf.columns with
3362 | Csingle _ ->
3363 if conf.presentation && l.pagey != 0
3364 then
3365 gotoxy state.x (clamp (pgscale ~-(state.winh)))
3366 else
3367 let pageno = max 0 (l.pageno-1) in
3368 gotoxy state.x (getpagey pageno)
3369 | Cmulti ((c, _, coverB) as cl, _) ->
3370 if conf.presentation &&
3371 (existsinrow l.pageno cl (fun l -> l.pagey != 0))
3372 then
3373 gotoxy state.x (clamp (pgscale ~-(state.winh)))
3374 else
3375 let decr =
3376 if l.pageno = state.pagecount - coverB
3377 then 1
3378 else c
3380 let pageno = max 0 (l.pageno-decr) in
3381 gotoxy state.x (getpagey pageno)
3382 | Csplit (n, _) ->
3383 let y =
3384 if l.pagecol = 0
3385 then
3386 if l.pageno = 0
3387 then l.pagey
3388 else
3389 let pageno = max 0 (l.pageno-1) in
3390 let pagey, pageh = getpageyh pageno in
3391 pagey + (n-1)*pageh
3392 else
3393 let pagey, pageh = getpageyh l.pageno in
3394 pagey + pageh * (l.pagecol-1) - conf.interpagespace
3396 gotoxy state.x y
3399 let save () =
3400 if emptystr conf.savecmd
3401 then adderrmsg "savepath-command is empty"
3402 "don't know where to save modified document"
3403 else
3404 let savecmd = Str.global_replace Utils.Re.percent state.path conf.savecmd in
3405 let path =
3406 getcmdoutput
3407 (fun exn ->
3408 adderrfmt savecmd "failed to produce path to the saved copy: %s" exn)
3409 savecmd
3411 if nonemptystr path
3412 then
3413 let tmp = path ^ ".tmp" in
3414 savedoc tmp;
3415 Unix.rename tmp path;
3418 let viewkeyboard key mask =
3419 let enttext te =
3420 let mode = state.mode in
3421 state.mode <- Textentry (te, fun _ -> state.mode <- mode);
3422 state.text <- E.s;
3423 enttext ();
3424 postRedisplay "view:enttext"
3426 let ctrl = Wsi.withctrl mask in
3427 let open Keys in
3428 match Wsi.kc2kt key with
3429 | Ascii 'S' -> state.slideshow <- state.slideshow lxor 1
3431 | Ascii 'Q' -> exit 0
3433 | Ascii 'W' ->
3434 if hasunsavedchanges ()
3435 then save ()
3437 | Insert ->
3438 if conf.angle mod 360 = 0 && not (isbirdseye state.mode)
3439 then (
3440 state.mode <- (
3441 match state.lnava with
3442 | None -> LinkNav (Ltgendir 0)
3443 | Some pn -> LinkNav (Ltexact pn)
3445 gotoxy state.x state.y;
3447 else impmsg "keyboard link navigation does not work under rotation"
3449 | Escape | Ascii 'q' ->
3450 begin match state.mstate with
3451 | Mzoomrect _ ->
3452 resetmstate ();
3453 postRedisplay "kill rect";
3454 | Msel _
3455 | Mpan _
3456 | Mscrolly | Mscrollx
3457 | Mzoom _
3458 | Mnone ->
3459 begin match state.mode with
3460 | LinkNav ln ->
3461 begin match ln with
3462 | Ltexact pl -> state.lnava <- Some pl
3463 | Ltgendir _ | Ltnotready _ -> state.lnava <- None
3464 end;
3465 state.mode <- View;
3466 postRedisplay "esc leave linknav"
3467 | Birdseye _ | Textentry _ | View ->
3468 match state.ranchors with
3469 | [] -> raise Quit
3470 | (path, password, anchor, origin) :: rest ->
3471 state.ranchors <- rest;
3472 state.anchor <- anchor;
3473 state.origin <- origin;
3474 state.nameddest <- E.s;
3475 opendoc path password
3476 end;
3477 end;
3479 | Backspace ->
3480 addnavnorc ();
3481 gotoxy state.x (getnav ~-1)
3483 | Ascii 'o' ->
3484 enteroutlinemode ()
3486 | Ascii 'H' ->
3487 enterhistmode ()
3489 | Ascii 'u' ->
3490 state.rects <- [];
3491 state.text <- E.s;
3492 Hashtbl.iter (fun _ opaque ->
3493 clearmark opaque;
3494 Hashtbl.clear state.prects) state.pagemap;
3495 postRedisplay "dehighlight";
3497 | Ascii (('/' | '?') as c) ->
3498 let ondone isforw s =
3499 cbput state.hists.pat s;
3500 state.searchpattern <- s;
3501 search s isforw
3503 let s = String.make 1 c in
3504 enttext (s, E.s, Some (onhist state.hists.pat),
3505 textentry, ondone (c = '/'), true)
3507 | Ascii '+' | Ascii '=' when ctrl ->
3508 let incr = if conf.zoom +. 0.01 > 0.1 then 0.1 else 0.01 in
3509 pivotzoom (conf.zoom +. incr)
3511 | Ascii '+' ->
3512 let ondone s =
3513 let n =
3514 try int_of_string s with exn ->
3515 state.text <-
3516 Printf.sprintf "bad integer `%s': %s" s @@ exntos exn;
3517 max_int
3519 if n != max_int
3520 then (
3521 conf.pagebias <- n;
3522 state.text <- "page bias is now " ^ string_of_int n;
3525 enttext ("page bias: ", E.s, None, intentry, ondone, true)
3527 | Ascii '-' when ctrl ->
3528 let decr = if conf.zoom -. 0.1 < 0.1 then 0.01 else 0.1 in
3529 pivotzoom (max 0.01 (conf.zoom -. decr))
3531 | Ascii '-' ->
3532 let ondone msg = state.text <- msg in
3533 enttext ("option: ", E.s, None,
3534 optentry state.mode, ondone, true)
3536 | Ascii '0' when ctrl ->
3537 if conf.zoom = 1.0
3538 then gotoxy 0 state.y
3539 else setzoom 1.0
3541 | Ascii ('1'|'2' as c) when ctrl && conf.fitmodel != FitPage ->
3542 let cols =
3543 match conf.columns with
3544 | Csingle _ | Cmulti _ -> 1
3545 | Csplit (n, _) -> n
3547 let h = state.winh -
3548 conf.interpagespace lsl (if conf.presentation then 1 else 0)
3550 let zoom = zoomforh state.winw h 0 cols in
3551 if zoom > 0.0 && (c = '2' || zoom < 1.0)
3552 then setzoom zoom
3554 | Ascii '3' when ctrl ->
3555 let fm =
3556 match conf.fitmodel with
3557 | FitWidth -> FitProportional
3558 | FitProportional -> FitPage
3559 | FitPage -> FitWidth
3561 state.text <- "fit model: " ^ FMTE.to_string fm;
3562 reqlayout conf.angle fm
3564 | Ascii '4' when ctrl ->
3565 let zoom = getmaxw () /. float state.winw in
3566 if zoom > 0.0 then setzoom zoom
3568 | Fn 9 | Ascii '9' when ctrl -> togglebirdseye ()
3570 | Ascii ('0'..'9' as c) when not ctrl ->
3571 let ondone s =
3572 let n =
3573 try int_of_string s with exn ->
3574 state.text <- Printf.sprintf "bad integer `%s': %s" s @@ exntos exn;
3577 if n >= 0
3578 then (
3579 addnav ();
3580 cbput state.hists.pag (string_of_int n);
3581 gotopage1 (n + conf.pagebias - 1) 0;
3584 let pageentry text = function [@warning "-4"]
3585 | Keys.Ascii 'g' -> TEdone text
3586 | key -> intentry text key
3588 let text = String.make 1 c in
3589 enttext (":", text, Some (onhist state.hists.pag),
3590 pageentry, ondone, true)
3592 | Ascii 'b' ->
3593 conf.scrollb <- if conf.scrollb = 0 then (scrollbvv lor scrollbhv) else 0;
3594 postRedisplay "toggle scrollbar";
3596 | Ascii 'B' ->
3597 state.bzoom <- not state.bzoom;
3598 state.rects <- [];
3599 showtext ' ' ("block zoom " ^ if state.bzoom then "on" else "off")
3601 | Ascii 'l' ->
3602 conf.hlinks <- not conf.hlinks;
3603 state.text <- "highlightlinks " ^ if conf.hlinks then "on" else "off";
3604 postRedisplay "toggle highlightlinks";
3606 | Ascii 'F' ->
3607 if conf.angle mod 360 = 0
3608 then (
3609 state.glinks <- true;
3610 let mode = state.mode in
3611 state.mode <-
3612 Textentry (
3613 (":", E.s, None, linknentry, linknact gotounder, false),
3614 (fun _ ->
3615 state.glinks <- false;
3616 state.mode <- mode)
3618 state.text <- E.s;
3619 postRedisplay "view:linkent(F)"
3621 else impmsg "hint mode does not work under rotation"
3623 | Ascii 'y' ->
3624 state.glinks <- true;
3625 let mode = state.mode in
3626 state.mode <-
3627 Textentry (
3628 (":", E.s, None, linknentry,
3629 linknact (fun under ->
3630 selstring conf.selcmd (undertext under)), false),
3631 (fun _ ->
3632 state.glinks <- false;
3633 state.mode <- mode)
3635 state.text <- E.s;
3636 postRedisplay "view:linkent"
3638 | Ascii 'a' ->
3639 begin match state.autoscroll with
3640 | Some step ->
3641 conf.autoscrollstep <- step;
3642 state.autoscroll <- None
3643 | None ->
3644 state.autoscroll <- Some conf.autoscrollstep;
3645 state.slideshow <- state.slideshow land lnot 2
3648 | Ascii 'p' when ctrl ->
3649 launchpath () (* XXX where do error messages go? *)
3651 | Ascii 'P' ->
3652 setpresentationmode (not conf.presentation);
3653 showtext ' ' ("presentation mode " ^
3654 if conf.presentation then "on" else "off");
3656 | Ascii 'f' ->
3657 if List.mem Wsi.Fullscreen state.winstate
3658 then Wsi.reshape conf.cwinw conf.cwinh
3659 else Wsi.fullscreen ()
3661 | Ascii ('p'|'N') ->
3662 search state.searchpattern false
3664 | Ascii 'n' | Fn 3 ->
3665 search state.searchpattern true
3667 | Ascii 't' ->
3668 begin match state.layout with
3669 | [] -> ()
3670 | l :: _ -> gotoxy state.x (getpagey l.pageno)
3673 | Ascii ' ' -> nextpage ()
3674 | Delete -> prevpage ()
3675 | Ascii '=' -> showtext ' ' (describe_layout state.layout);
3677 | Ascii 'w' ->
3678 begin match state.layout with
3679 | [] -> ()
3680 | l :: _ ->
3681 Wsi.reshape l.pagew l.pageh;
3682 postRedisplay "w"
3685 | Ascii '\'' -> enterbookmarkmode ()
3686 | Ascii 'h' | Fn 1 -> enterhelpmode ()
3687 | Ascii 'i' -> enterinfomode ()
3688 | Ascii 'e' when Buffer.length state.errmsgs > 0 -> entermsgsmode ()
3690 | Ascii 'm' ->
3691 let ondone s =
3692 match state.layout with
3693 | l :: _ when nonemptystr s ->
3694 state.bookmarks <- (s, 0, Oanchor (getanchor1 l)) :: state.bookmarks
3695 | _ -> ()
3697 enttext ("bookmark: ", E.s, None, textentry, ondone, true)
3699 | Ascii '~' ->
3700 quickbookmark ();
3701 showtext ' ' "Quick bookmark added";
3703 | Ascii 'x' -> state.roam ()
3705 | Ascii ('<'|'>' as c) ->
3706 reqlayout (conf.angle + (if c = '>' then 30 else -30)) conf.fitmodel
3708 | Ascii ('['|']' as c) ->
3709 conf.colorscale <-
3710 bound (conf.colorscale +. (if c = ']' then 0.1 else -0.1)) 0.0 1.0;
3711 postRedisplay "brightness";
3713 | Ascii 'c' when state.mode = View ->
3714 if Wsi.withalt mask
3715 then (
3716 if conf.zoom > 1.0
3717 then
3718 let m = (state.winw - state.w) / 2 in
3719 gotoxy m state.y
3721 else
3722 let (c, a, b), z =
3723 match state.prevcolumns with
3724 | None -> (1, 0, 0), 1.0
3725 | Some (columns, z) ->
3726 let cab =
3727 match columns with
3728 | Csplit (c, _) -> -c, 0, 0
3729 | Cmulti ((c, a, b), _) -> c, a, b
3730 | Csingle _ -> 1, 0, 0
3732 cab, z
3734 setcolumns View c a b;
3735 setzoom z
3737 | Down | Up when ctrl && Wsi.withshift mask ->
3738 let zoom, x = state.prevzoom in
3739 setzoom zoom;
3740 state.x <- x;
3742 | Ascii 'k' | Up ->
3743 begin match state.autoscroll with
3744 | None ->
3745 begin match state.mode with
3746 | Birdseye beye -> upbirdseye 1 beye
3747 | Textentry _ | View | LinkNav _ ->
3748 if ctrl
3749 then gotoxy state.x (clamp ~-(state.winh/2))
3750 else (
3751 if not (Wsi.withshift mask) && conf.presentation
3752 then prevpage ()
3753 else gotoxy state.x (clamp (-conf.scrollstep))
3756 | Some n -> setautoscrollspeed n false
3759 | Ascii 'j' | Down ->
3760 begin match state.autoscroll with
3761 | None ->
3762 begin match state.mode with
3763 | Birdseye beye -> downbirdseye 1 beye
3764 | Textentry _ | View | LinkNav _ ->
3765 if ctrl
3766 then gotoxy state.x (clamp (state.winh/2))
3767 else (
3768 if not (Wsi.withshift mask) && conf.presentation
3769 then nextpage ()
3770 else gotoxy state.x (clamp (conf.scrollstep))
3773 | Some n -> setautoscrollspeed n true
3776 | Left | Right when not (Wsi.withalt mask) ->
3777 if canpan ()
3778 then
3779 let dx =
3780 if ctrl
3781 then state.winw / 2
3782 else conf.hscrollstep
3784 let dx =
3785 let pv = Wsi.kc2kt key in
3786 if pv = Keys.Left then dx else -dx
3788 gotoxy (panbound (state.x + dx)) state.y
3789 else (
3790 state.text <- E.s;
3791 postRedisplay "left/right"
3794 | Prior ->
3795 let y =
3796 if ctrl
3797 then
3798 match state.layout with
3799 | [] -> state.y
3800 | l :: _ -> state.y - l.pagey
3801 else clamp (pgscale (-state.winh))
3803 gotoxy state.x y
3805 | Next ->
3806 let y =
3807 if ctrl
3808 then
3809 match List.rev state.layout with
3810 | [] -> state.y
3811 | l :: _ -> getpagey l.pageno
3812 else clamp (pgscale state.winh)
3814 gotoxy state.x y
3816 | Ascii 'g' | Home ->
3817 addnav ();
3818 gotoxy 0 0
3819 | Ascii 'G' | End ->
3820 addnav ();
3821 gotoxy 0 (clamp state.maxy)
3823 | Right when Wsi.withalt mask ->
3824 addnavnorc ();
3825 gotoxy state.x (getnav 1)
3826 | Left when Wsi.withalt mask ->
3827 addnavnorc ();
3828 gotoxy state.x (getnav ~-1)
3830 | Ascii 'r' ->
3831 reload ()
3833 | Ascii 'v' when conf.debug ->
3834 state.rects <- [];
3835 List.iter (fun l ->
3836 match getopaque l.pageno with
3837 | None -> ()
3838 | Some opaque ->
3839 let x0, y0, x1, y1 = pagebbox opaque in
3840 let rect = (float x0, float y0,
3841 float x1, float y0,
3842 float x1, float y1,
3843 float x0, float y1) in
3844 debugrect rect;
3845 let color = (0.0, 0.0, 1.0 /. (l.pageno mod 3 |> float), 0.5) in
3846 state.rects <- (l.pageno, color, rect) :: state.rects;
3847 ) state.layout;
3848 postRedisplay "v";
3850 | Ascii '|' ->
3851 let mode = state.mode in
3852 let cmd = ref E.s in
3853 let onleave = function
3854 | Cancel -> state.mode <- mode
3855 | Confirm ->
3856 List.iter (fun l ->
3857 match getopaque l.pageno with
3858 | Some opaque -> pipesel opaque !cmd
3859 | None -> ()) state.layout;
3860 state.mode <- mode
3862 let ondone s =
3863 cbput state.hists.sel s;
3864 cmd := s
3866 let te =
3867 "| ", !cmd, Some (onhist state.hists.sel), textentry, ondone, true
3869 postRedisplay "|";
3870 state.mode <- Textentry (te, onleave);
3872 | (Ascii _|Fn _|Enter|Left|Right|Code _|Ctrl _) ->
3873 vlog "huh? %s" (Wsi.keyname key)
3876 let linknavkeyboard key mask linknav =
3877 let pv = Wsi.kc2kt key in
3878 let getpage pageno =
3879 let rec loop = function
3880 | [] -> None
3881 | l :: _ when l.pageno = pageno -> Some l
3882 | _ :: rest -> loop rest
3883 in loop state.layout
3885 let doexact (pageno, n) =
3886 match getopaque pageno, getpage pageno with
3887 | Some opaque, Some l ->
3888 if pv = Keys.Enter
3889 then
3890 let under = getlink opaque n in
3891 postRedisplay "link gotounder";
3892 gotounder under;
3893 state.mode <- View;
3894 else
3895 let opt, dir =
3896 let open Keys in
3897 match pv with
3898 | Home -> Some (findlink opaque LDfirst), -1
3899 | End -> Some (findlink opaque LDlast), 1
3900 | Left -> Some (findlink opaque (LDleft n)), -1
3901 | Right -> Some (findlink opaque (LDright n)), 1
3902 | Up -> Some (findlink opaque (LDup n)), -1
3903 | Down -> Some (findlink opaque (LDdown n)), 1
3904 | Delete|Escape|Insert|Enter|Next|Prior|Ascii _
3905 | Code _|Fn _|Ctrl _|Backspace -> None, 0
3907 let pwl l dir =
3908 begin match findpwl l.pageno dir with
3909 | Pwlnotfound -> ()
3910 | Pwl pageno ->
3911 let notfound dir =
3912 state.mode <- LinkNav (Ltgendir dir);
3913 let y, h = getpageyh pageno in
3914 let y =
3915 if dir < 0
3916 then y + h - state.winh
3917 else y
3919 gotoxy state.x y
3921 begin match getopaque pageno, getpage pageno with
3922 | Some opaque, Some _ ->
3923 let link =
3924 let ld = if dir > 0 then LDfirst else LDlast in
3925 findlink opaque ld
3927 begin match link with
3928 | Lfound m ->
3929 showlinktype (getlink opaque m);
3930 state.mode <- LinkNav (Ltexact (pageno, m));
3931 postRedisplay "linknav jpage";
3932 | Lnotfound -> notfound dir
3933 end;
3934 | _ -> notfound dir
3935 end;
3936 end;
3938 begin match opt with
3939 | Some Lnotfound -> pwl l dir;
3940 | Some (Lfound m) ->
3941 if m = n
3942 then pwl l dir
3943 else (
3944 let _, y0, _, y1 = getlinkrect opaque m in
3945 if y0 < l.pagey
3946 then gotopage1 l.pageno y0
3947 else (
3948 let d = fstate.fontsize + 1 in
3949 if y1 - l.pagey > l.pagevh - d
3950 then gotopage1 l.pageno (y1 - state.winh + d)
3951 else postRedisplay "linknav";
3953 showlinktype (getlink opaque m);
3954 state.mode <- LinkNav (Ltexact (l.pageno, m));
3957 | None -> viewkeyboard key mask
3958 end;
3959 | _ -> viewkeyboard key mask
3961 if pv = Keys.Insert
3962 then (
3963 begin match linknav with
3964 | Ltexact pa -> state.lnava <- Some pa
3965 | Ltgendir _ | Ltnotready _ -> ()
3966 end;
3967 state.mode <- View;
3968 postRedisplay "leave linknav"
3970 else
3971 match linknav with
3972 | Ltgendir _ | Ltnotready _ -> viewkeyboard key mask
3973 | Ltexact exact -> doexact exact
3976 let keyboard key mask =
3977 if (key = Char.code 'g' && Wsi.withctrl mask) && not (istextentry state.mode)
3978 then wcmd "interrupt"
3979 else state.uioh <- state.uioh#key key mask
3982 let birdseyekeyboard key mask
3983 ((oconf, leftx, pageno, hooverpageno, anchor) as beye) =
3984 let incr =
3985 match conf.columns with
3986 | Csingle _ -> 1
3987 | Cmulti ((c, _, _), _) -> c
3988 | Csplit _ -> error "bird's eye split mode"
3990 let pgh layout = List.fold_left
3991 (fun m l -> max l.pageh m) state.winh layout in
3992 let open Keys in
3993 match Wsi.kc2kt key with
3994 | Ascii 'l' when Wsi.withctrl mask ->
3995 let y, h = getpageyh pageno in
3996 let top = (state.winh - h) / 2 in
3997 gotoxy state.x (max 0 (y - top))
3998 | Enter -> leavebirdseye beye false
3999 | Escape -> leavebirdseye beye true
4000 | Up -> upbirdseye incr beye
4001 | Down -> downbirdseye incr beye
4002 | Left -> upbirdseye 1 beye
4003 | Right -> downbirdseye 1 beye
4005 | Prior ->
4006 begin match state.layout with
4007 | l :: _ ->
4008 if l.pagey != 0
4009 then (
4010 state.mode <- Birdseye (
4011 oconf, leftx, l.pageno, hooverpageno, anchor
4013 gotopage1 l.pageno 0;
4015 else (
4016 let layout = layout state.x (state.y-state.winh)
4017 state.winw
4018 (pgh state.layout) in
4019 match layout with
4020 | [] -> gotoxy state.x (clamp (-state.winh))
4021 | l :: _ ->
4022 state.mode <- Birdseye (
4023 oconf, leftx, l.pageno, hooverpageno, anchor
4025 gotopage1 l.pageno 0
4028 | [] -> gotoxy state.x (clamp (-state.winh))
4029 end;
4031 | Next ->
4032 begin match List.rev state.layout with
4033 | l :: _ ->
4034 let layout = layout state.x
4035 (state.y + (pgh state.layout))
4036 state.winw state.winh in
4037 begin match layout with
4038 | [] ->
4039 let incr = l.pageh - l.pagevh in
4040 if incr = 0
4041 then (
4042 state.mode <-
4043 Birdseye (
4044 oconf, leftx, state.pagecount - 1, hooverpageno, anchor
4046 postRedisplay "birdseye pagedown";
4048 else gotoxy state.x (clamp (incr + conf.interpagespace*2));
4050 | l :: _ ->
4051 state.mode <-
4052 Birdseye (oconf, leftx, l.pageno, hooverpageno, anchor);
4053 gotopage1 l.pageno 0;
4056 | [] -> gotoxy state.x (clamp state.winh)
4057 end;
4059 | Home ->
4060 state.mode <- Birdseye (oconf, leftx, 0, hooverpageno, anchor);
4061 gotopage1 0 0
4063 | End ->
4064 let pageno = state.pagecount - 1 in
4065 state.mode <- Birdseye (oconf, leftx, pageno, hooverpageno, anchor);
4066 if not (pagevisible state.layout pageno)
4067 then
4068 let h =
4069 match List.rev state.pdims with
4070 | [] -> state.winh
4071 | (_, _, h, _) :: _ -> h
4073 gotoxy
4074 state.x
4075 (max 0 (getpagey pageno - (state.winh - h - conf.interpagespace)))
4076 else postRedisplay "birdseye end";
4078 | Delete|Insert|Ascii _|Code _|Ctrl _|Fn _|Backspace -> viewkeyboard key mask
4081 let drawpage l =
4082 let color =
4083 match state.mode with
4084 | Textentry _ -> scalecolor 0.4
4085 | LinkNav _ | View -> scalecolor 1.0
4086 | Birdseye (_, _, pageno, hooverpageno, _) ->
4087 if l.pageno = hooverpageno
4088 then scalecolor 0.9
4089 else (
4090 if l.pageno = pageno
4091 then (
4092 let c = scalecolor 1.0 in
4093 GlDraw.color c;
4094 GlDraw.line_width 3.0;
4095 let dispx = l.pagedispx in
4096 linerect
4097 (float (dispx-1)) (float (l.pagedispy-1))
4098 (float (dispx+l.pagevw+1))
4099 (float (l.pagedispy+l.pagevh+1));
4100 GlDraw.line_width 1.0;
4103 else scalecolor 0.8
4106 drawtiles l color;
4109 let postdrawpage l linkindexbase =
4110 match getopaque l.pageno with
4111 | Some opaque ->
4112 if tileready l l.pagex l.pagey
4113 then
4114 let x = l.pagedispx - l.pagex
4115 and y = l.pagedispy - l.pagey in
4116 let hlmask =
4117 match conf.columns with
4118 | Csingle _ | Cmulti _ ->
4119 (if conf.hlinks then 1 else 0)
4120 + (if state.glinks
4121 && not (isbirdseye state.mode) then 2 else 0)
4122 | Csplit _ -> 0
4124 let s =
4125 match state.mode with
4126 | Textentry ((_, s, _, _, _, _), _) when state.glinks -> s
4127 | Textentry _
4128 | Birdseye _
4129 | View
4130 | LinkNav _ -> E.s
4132 Hashtbl.find_all state.prects l.pageno |>
4133 List.iter (fun vals -> drawprect opaque x y vals);
4134 let n = postprocess opaque hlmask x y (linkindexbase, s, conf.hfsize) in
4135 if n < 0
4136 then (Glutils.redisplay := true; 0)
4137 else n
4138 else 0
4139 | _ -> 0
4142 let scrollindicator () =
4143 let sbw, ph, sh = state.uioh#scrollph in
4144 let sbh, pw, sw = state.uioh#scrollpw in
4146 let x0,x1,hx0 =
4147 if conf.leftscroll
4148 then (0, sbw, sbw)
4149 else ((state.winw - sbw), state.winw, 0)
4152 Gl.enable `blend;
4153 GlFunc.blend_func ~src:`src_alpha ~dst:`one_minus_src_alpha;
4154 let (r, g, b, alpha) = conf.sbarcolor in
4155 GlDraw.color (r, g, b) ~alpha;
4156 filledrect (float x0) 0. (float x1) (float state.winh);
4157 filledrect
4158 (float hx0) (float (state.winh - sbh))
4159 (float (hx0 + state.winw)) (float state.winh);
4160 let (r, g, b, alpha) = conf.sbarhndlcolor in
4161 GlDraw.color (r, g, b) ~alpha;
4163 filledrect (float x0) ph (float x1) (ph +. sh);
4164 let pw = pw +. float hx0 in
4165 filledrect pw (float (state.winh - sbh)) (pw +. sw) (float state.winh);
4166 Gl.disable `blend;
4169 let showsel () =
4170 match state.mstate with
4171 | Mnone | Mscrolly | Mscrollx | Mpan _ | Mzoom _ | Mzoomrect _ -> ()
4172 | Msel ((x0, y0), (x1, y1)) ->
4173 let identify opaque l px py = Some (opaque, l.pageno, px, py) in
4174 let o0,n0,px0,py0 = onppundermouse identify x0 y0 (~< E.s, -1, 0, 0) in
4175 let _o1,n1,px1,py1 = onppundermouse identify x1 y1 (~< E.s, -1, 0, 0) in
4176 if n0 != -1 && n0 = n1 then seltext o0 (px0, py0, px1, py1);
4179 let showrects = function
4180 | [] -> ()
4181 | rects ->
4182 Gl.enable `blend;
4183 GlDraw.color (0.0, 0.0, 1.0) ~alpha:0.5;
4184 GlFunc.blend_func ~src:`src_alpha ~dst:`one_minus_src_alpha;
4185 List.iter
4186 (fun (pageno, c, (x0, y0, x1, y1, x2, y2, x3, y3)) ->
4187 List.iter (fun l ->
4188 if l.pageno = pageno
4189 then (
4190 let dx = float (l.pagedispx - l.pagex) in
4191 let dy = float (l.pagedispy - l.pagey) in
4192 let r, g, b, alpha = c in
4193 GlDraw.color (r, g, b) ~alpha;
4194 filledrect2
4195 (x0+.dx) (y0+.dy)
4196 (x1+.dx) (y1+.dy)
4197 (x3+.dx) (y3+.dy)
4198 (x2+.dx) (y2+.dy);
4200 ) state.layout
4201 ) rects;
4202 Gl.disable `blend;
4205 let display () =
4206 GlDraw.color (scalecolor2 conf.bgcolor);
4207 GlClear.color (scalecolor2 conf.bgcolor);
4208 GlClear.clear [`color];
4209 List.iter drawpage state.layout;
4210 let rects =
4211 match state.mode with
4212 | LinkNav (Ltexact (pageno, linkno)) ->
4213 begin match getopaque pageno with
4214 | Some opaque ->
4215 let x0, y0, x1, y1 = getlinkrect opaque linkno in
4216 let color = (0.0, 0.0, 0.5, 0.5) in
4217 (pageno, color,
4218 (float x0, float y0,
4219 float x1, float y0,
4220 float x1, float y1,
4221 float x0, float y1)
4222 ) :: state.rects
4223 | None -> state.rects
4225 | LinkNav (Ltgendir _) | LinkNav (Ltnotready _)
4226 | Birdseye _
4227 | Textentry _
4228 | View -> state.rects
4230 showrects rects;
4231 let rec postloop linkindexbase = function
4232 | l :: rest ->
4233 let linkindexbase = linkindexbase + postdrawpage l linkindexbase in
4234 postloop linkindexbase rest
4235 | [] -> ()
4237 showsel ();
4238 postloop 0 state.layout;
4239 state.uioh#display;
4240 begin match state.mstate with
4241 | Mzoomrect ((x0, y0), (x1, y1)) ->
4242 Gl.enable `blend;
4243 GlDraw.color (0.3, 0.3, 0.3) ~alpha:0.5;
4244 GlFunc.blend_func ~src:`src_alpha ~dst:`one_minus_src_alpha;
4245 filledrect (float x0) (float y0) (float x1) (float y1);
4246 Gl.disable `blend;
4247 | Msel _
4248 | Mpan _
4249 | Mscrolly | Mscrollx
4250 | Mzoom _
4251 | Mnone -> ()
4252 end;
4253 enttext ();
4254 scrollindicator ();
4255 Wsi.swapb ();
4258 let zoomrect x y x1 y1 =
4259 let x0 = min x x1
4260 and x1 = max x x1
4261 and y0 = min y y1 in
4262 let zoom = (float state.w) /. float (x1 - x0) in
4263 let margin =
4264 let simple () =
4265 if state.w < state.winw
4266 then (state.winw - state.w) / 2
4267 else 0
4269 match conf.fitmodel with
4270 | FitWidth | FitProportional -> simple ()
4271 | FitPage ->
4272 match conf.columns with
4273 | Csplit _ ->
4274 onppundermouse (fun _ l _ _ -> Some l.pagedispx) x0 y0 x0
4275 | Cmulti _ | Csingle _ -> simple ()
4277 gotoxy ((state.x + margin) - x0) (state.y + y0);
4278 state.anchor <- getanchor ();
4279 setzoom zoom;
4280 resetmstate ();
4283 let annot inline x y =
4284 match unproject x y with
4285 | Some (opaque, n, ux, uy) ->
4286 let add text =
4287 addannot opaque ux uy text;
4288 wcmd "freepage %s" (~> opaque);
4289 Hashtbl.remove state.pagemap (n, state.gen);
4290 flushtiles ();
4291 gotoxy state.x state.y
4293 if inline
4294 then
4295 let ondone s = add s in
4296 let mode = state.mode in
4297 state.mode <- Textentry (
4298 ("annotation: ", E.s, None, textentry, ondone, true),
4299 fun _ -> state.mode <- mode);
4300 state.text <- E.s;
4301 enttext ();
4302 postRedisplay "annot"
4303 else add @@ getusertext E.s
4304 | _ -> ()
4307 let zoomblock x y =
4308 let g opaque l px py =
4309 match rectofblock opaque px py with
4310 | Some a ->
4311 let x0 = a.(0) -. 20. in
4312 let x1 = a.(1) +. 20. in
4313 let y0 = a.(2) -. 20. in
4314 let zoom = (float state.w) /. (x1 -. x0) in
4315 let pagey = getpagey l.pageno in
4316 let margin = (state.w - l.pagew)/2 in
4317 let nx = -truncate x0 - margin in
4318 gotoxy nx (pagey + truncate y0);
4319 state.anchor <- getanchor ();
4320 setzoom zoom;
4321 None
4322 | None -> None
4324 match conf.columns with
4325 | Csplit _ ->
4326 impmsg "block zooming does not work properly in split columns mode"
4327 | Cmulti _ | Csingle _ -> onppundermouse g x y ()
4330 let scrollx x =
4331 let winw = state.winw - 1 in
4332 let s = float x /. float winw in
4333 let destx = truncate (float (state.w + winw) *. s) in
4334 gotoxy (winw - destx) state.y;
4335 state.mstate <- Mscrollx;
4338 let scrolly y =
4339 let s = float y /. float state.winh in
4340 let desty = truncate (s *. float (maxy ())) in
4341 gotoxy state.x desty;
4342 state.mstate <- Mscrolly;
4345 let viewmulticlick clicks x y mask =
4346 let g opaque l px py =
4347 let mark =
4348 match clicks with
4349 | 2 -> Mark_word
4350 | 3 -> Mark_line
4351 | 4 -> Mark_block
4352 | _ -> Mark_page
4354 if markunder opaque px py mark
4355 then (
4356 Some (fun () ->
4357 let dopipe cmd =
4358 match getopaque l.pageno with
4359 | None -> ()
4360 | Some opaque -> pipesel opaque cmd
4362 state.roam <- (fun () -> dopipe conf.paxcmd);
4363 if not (Wsi.withctrl mask) then dopipe conf.selcmd;
4366 else None
4368 postRedisplay "viewmulticlick";
4369 onppundermouse g x y (fun () -> impmsg "nothing to select") ();
4372 let canselect () =
4373 match conf.columns with
4374 | Csplit _ -> false
4375 | Csingle _ | Cmulti _ -> conf.angle mod 360 = 0
4378 let viewmouse button down x y mask =
4379 match button with
4380 | n when (n == 4 || n == 5) && not down ->
4381 if Wsi.withctrl mask
4382 then (
4383 let incr =
4384 if n = 5
4385 then if conf.zoom +. 0.01 > 0.1 then 0.1 else 0.01
4386 else if conf.zoom -. 0.1 < 0.1 then -0.01 else -0.1
4388 let fx, fy =
4389 match state.mstate with
4390 | Mzoom (oldn, _, pos) when n = oldn -> pos
4391 | Mzoomrect _ | Mnone | Mpan _
4392 | Msel _ | Mscrollx | Mscrolly | Mzoom _ -> (x, y)
4394 let zoom = conf.zoom -. incr in
4395 state.mstate <- Mzoom (n, 0, (x, y));
4396 if false && abs (fx - x) > 5 || abs (fy - y) > 5
4397 then pivotzoom ~x ~y zoom
4398 else pivotzoom zoom
4400 else (
4401 match state.autoscroll with
4402 | Some step -> setautoscrollspeed step (n=4)
4403 | None ->
4404 if conf.wheelbypage || conf.presentation
4405 then (
4406 if n = 4
4407 then prevpage ()
4408 else nextpage ()
4410 else
4411 let incr = if n = 4 then -conf.scrollstep else conf.scrollstep in
4412 let incr = incr * 2 in
4413 let y = clamp incr in
4414 gotoxy state.x y
4417 | n when (n = 6 || n = 7) && not down && canpan () ->
4418 let x =
4419 panbound (state.x + (if n = 7 then -2 else 2) * conf.hscrollstep) in
4420 gotoxy x state.y
4422 | 1 when Wsi.withshift mask ->
4423 state.mstate <- Mnone;
4424 if not down
4425 then (
4426 match unproject x y with
4427 | None -> ()
4428 | Some (_, pageno, ux, uy) ->
4429 let cmd = Printf.sprintf
4430 "%s %s %d %d %d"
4431 conf.stcmd state.path pageno ux uy
4433 match spawn cmd [] with
4434 | exception exn ->
4435 impmsg "execution of synctex command(%S) failed: %S"
4436 conf.stcmd @@ exntos exn
4437 | _pid -> ()
4440 | 1 when Wsi.withctrl mask ->
4441 if down
4442 then (
4443 Wsi.setcursor Wsi.CURSOR_FLEUR;
4444 state.mstate <- Mpan (x, y)
4446 else state.mstate <- Mnone
4448 | 3 ->
4449 if down
4450 then (
4451 if Wsi.withshift mask
4452 then (
4453 annot conf.annotinline x y;
4454 postRedisplay "addannot"
4456 else
4457 let p = (x, y) in
4458 Wsi.setcursor Wsi.CURSOR_CYCLE;
4459 state.mstate <- Mzoomrect (p, p)
4461 else (
4462 match state.mstate with
4463 | Mzoomrect ((x0, y0), _) ->
4464 if abs (x-x0) > 10 && abs (y - y0) > 10
4465 then zoomrect x0 y0 x y
4466 else (
4467 resetmstate ();
4468 postRedisplay "kill accidental zoom rect";
4470 | Msel _
4471 | Mpan _
4472 | Mscrolly | Mscrollx
4473 | Mzoom _
4474 | Mnone -> resetmstate ()
4477 | 1 when vscrollhit x ->
4478 if down
4479 then
4480 let _, position, sh = state.uioh#scrollph in
4481 if y > truncate position && y < truncate (position +. sh)
4482 then state.mstate <- Mscrolly
4483 else scrolly y
4484 else state.mstate <- Mnone
4486 | 1 when y > state.winh - hscrollh () ->
4487 if down
4488 then
4489 let _, position, sw = state.uioh#scrollpw in
4490 if x > truncate position && x < truncate (position +. sw)
4491 then state.mstate <- Mscrollx
4492 else scrollx x
4493 else state.mstate <- Mnone
4495 | 1 when state.bzoom -> if not down then zoomblock x y
4497 | 1 ->
4498 let dest = if down then getunder x y else Unone in
4499 begin match dest with
4500 | Ulinkuri _ -> gotounder dest
4501 | Unone when down ->
4502 Wsi.setcursor Wsi.CURSOR_FLEUR;
4503 state.mstate <- Mpan (x, y);
4504 | Uannotation (opaque, slinkindex) -> enterannotmode opaque slinkindex
4505 | Unone | Utext _ ->
4506 if down
4507 then (
4508 if canselect ()
4509 then (
4510 state.mstate <- Msel ((x, y), (x, y));
4511 postRedisplay "mouse select";
4514 else (
4515 match state.mstate with
4516 | Mnone -> ()
4517 | Mzoom _ | Mscrollx | Mscrolly -> state.mstate <- Mnone
4518 | Mzoomrect ((x0, y0), _) -> zoomrect x0 y0 x y
4519 | Mpan _ ->
4520 Wsi.setcursor Wsi.CURSOR_INHERIT;
4521 state.mstate <- Mnone
4522 | Msel ((x0, y0), (x1, y1)) ->
4523 let rec loop = function
4524 | [] -> ()
4525 | l :: rest ->
4526 let inside =
4527 let a0 = l.pagedispy in
4528 let a1 = a0 + l.pagevh in
4529 let b0 = l.pagedispx in
4530 let b1 = b0 + l.pagevw in
4531 ((y0 >= a0 && y0 <= a1) || (y1 >= a0 && y1 <= a1))
4532 && ((x0 >= b0 && x0 <= b1) || (x1 >= b0 && x1 <= b1))
4534 if inside
4535 then
4536 match getopaque l.pageno with
4537 | Some opaque ->
4538 let dosel cmd () =
4539 pipef ~closew:false "Msel"
4540 (fun w ->
4541 copysel w opaque;
4542 postRedisplay "Msel") cmd
4544 dosel conf.selcmd ();
4545 state.roam <- dosel conf.paxcmd;
4546 | None -> ()
4547 else loop rest
4549 loop state.layout;
4550 resetmstate ();
4553 | _ -> ()
4556 let birdseyemouse button down x y mask
4557 (conf, leftx, _, hooverpageno, anchor) =
4558 match button with
4559 | 1 when down ->
4560 let rec loop = function
4561 | [] -> ()
4562 | l :: rest ->
4563 if y > l.pagedispy && y < l.pagedispy + l.pagevh
4564 && x > l.pagedispx && x < l.pagedispx + l.pagevw
4565 then (
4566 leavebirdseye (conf, leftx, l.pageno, hooverpageno, anchor) false;
4568 else loop rest
4570 loop state.layout
4571 | 3 -> ()
4572 | _ -> viewmouse button down x y mask
4575 let uioh = object
4576 method display = ()
4578 method key key mask =
4579 begin match state.mode with
4580 | Textentry textentry -> textentrykeyboard key mask textentry
4581 | Birdseye birdseye -> birdseyekeyboard key mask birdseye
4582 | View -> viewkeyboard key mask
4583 | LinkNav linknav -> linknavkeyboard key mask linknav
4584 end;
4585 state.uioh
4587 method button button bstate x y mask =
4588 begin match state.mode with
4589 | LinkNav _ | View -> viewmouse button bstate x y mask
4590 | Birdseye beye -> birdseyemouse button bstate x y mask beye
4591 | Textentry _ -> ()
4592 end;
4593 state.uioh
4595 method multiclick clicks x y mask =
4596 begin match state.mode with
4597 | LinkNav _ | View -> viewmulticlick clicks x y mask
4598 | Birdseye _ | Textentry _ -> ()
4599 end;
4600 state.uioh
4602 method motion x y =
4603 begin match state.mode with
4604 | Textentry _ -> ()
4605 | View | Birdseye _ | LinkNav _ ->
4606 match state.mstate with
4607 | Mzoom _ | Mnone -> ()
4608 | Mpan (x0, y0) ->
4609 let dx = x - x0
4610 and dy = y0 - y in
4611 state.mstate <- Mpan (x, y);
4612 let x = if canpan () then panbound (state.x + dx) else state.x in
4613 let y = clamp dy in
4614 gotoxy x y
4616 | Msel (a, _) ->
4617 state.mstate <- Msel (a, (x, y));
4618 postRedisplay "motion select";
4620 | Mscrolly ->
4621 let y = min state.winh (max 0 y) in
4622 scrolly y
4624 | Mscrollx ->
4625 let x = min state.winw (max 0 x) in
4626 scrollx x
4628 | Mzoomrect (p0, _) ->
4629 state.mstate <- Mzoomrect (p0, (x, y));
4630 postRedisplay "motion zoomrect";
4631 end;
4632 state.uioh
4634 method pmotion x y =
4635 begin match state.mode with
4636 | Birdseye (conf, leftx, pageno, hooverpageno, anchor) ->
4637 let rec loop = function
4638 | [] ->
4639 if hooverpageno != -1
4640 then (
4641 state.mode <- Birdseye (conf, leftx, pageno, -1, anchor);
4642 postRedisplay "pmotion birdseye no hoover";
4644 | l :: rest ->
4645 if y > l.pagedispy && y < l.pagedispy + l.pagevh
4646 && x > l.pagedispx && x < l.pagedispx + l.pagevw
4647 then (
4648 state.mode <- Birdseye (conf, leftx, pageno, l.pageno, anchor);
4649 postRedisplay "pmotion birdseye hoover";
4651 else loop rest
4653 loop state.layout
4655 | Textentry _ -> ()
4657 | LinkNav _ | View ->
4658 match state.mstate with
4659 | Mpan _ | Msel _ | Mzoom _ | Mscrolly | Mscrollx | Mzoomrect _ -> ()
4660 | Mnone ->
4661 updateunder x y;
4662 if canselect ()
4663 then
4664 match conf.pax with
4665 | None -> ()
4666 | Some past ->
4667 let now = now () in
4668 let delta = now -. past in
4669 if delta > 0.01
4670 then paxunder x y
4671 else conf.pax <- Some now
4672 end;
4673 state.uioh
4675 method infochanged _ = ()
4677 method scrollph =
4678 let maxy = maxy () in
4679 let p, h =
4680 if maxy = 0
4681 then 0.0, float state.winh
4682 else scrollph state.y maxy
4684 vscrollw (), p, h
4686 method scrollpw =
4687 let fwinw = float (state.winw - vscrollw ()) in
4688 let sw =
4689 let sw = fwinw /. float state.w in
4690 let sw = fwinw *. sw in
4691 max sw (float conf.scrollh)
4693 let position =
4694 let maxx = state.w + state.winw in
4695 let x = state.winw - state.x in
4696 let percent = float x /. float maxx in
4697 (fwinw -. sw) *. percent
4699 hscrollh (), position, sw
4701 method modehash =
4702 let modename =
4703 match state.mode with
4704 | LinkNav _ -> "links"
4705 | Textentry _ -> "textentry"
4706 | Birdseye _ -> "birdseye"
4707 | View -> "view"
4709 findkeyhash conf modename
4711 method eformsgs = true
4712 method alwaysscrolly = false
4713 method scroll dx dy =
4714 let x = if canpan () then panbound (state.x + dx) else state.x in
4715 gotoxy x (clamp (2 * dy));
4716 state.uioh
4717 method zoom z x y =
4718 pivotzoom ~x ~y (conf.zoom *. exp z);
4719 end;;
4721 let addrect pageno r g b a x0 y0 x1 y1 =
4722 Hashtbl.add state.prects pageno [|r; g; b; a; x0; y0; x1; y1|];
4725 let ract cmds =
4726 let cl = splitatchar cmds ' ' in
4727 let scan s fmt f =
4728 try Scanf.sscanf s fmt f
4729 with exn -> adderrfmt "remote exec" "error processing '%S': %s\n"
4730 cmds @@ exntos exn
4732 let rectx s pageno (r, g, b, a) x0 y0 x1 y1 =
4733 vlog "%s page %d color (%f %f %f %f) x0,y0,x1,y1 = %f %f %f %f"
4734 s pageno r g b a x0 y0 x1 y1;
4735 onpagerect
4736 pageno
4737 (fun w h ->
4738 let _,w1,h1,_ = getpagedim pageno in
4739 let sw = float w1 /. float w
4740 and sh = float h1 /. float h in
4741 let x0s = x0 *. sw
4742 and x1s = x1 *. sw
4743 and y0s = y0 *. sh
4744 and y1s = y1 *. sh in
4745 let rect = (x0s,y0s,x1s,y0s,x1s,y1s,x0s,y1s) in
4746 let color = (r, g, b, a) in
4747 if conf.verbose then debugrect rect;
4748 state.rects <- (pageno, color, rect) :: state.rects;
4749 postRedisplay s;
4752 match cl with
4753 | "reload", "" -> reload ()
4754 | "goto", args ->
4755 scan args "%u %f %f"
4756 (fun pageno x y ->
4757 let cmd, _ = state.geomcmds in
4758 if emptystr cmd
4759 then gotopagexy pageno x y
4760 else
4761 let f prevf () =
4762 gotopagexy pageno x y;
4763 prevf ()
4765 state.reprf <- f state.reprf
4767 | "goto1", args -> scan args "%u %f" gotopage
4768 | "gotor", args -> scan args "%S" gotoremote
4769 | "rect", args ->
4770 scan args "%u %u %f %f %f %f"
4771 (fun pageno c x0 y0 x1 y1 ->
4772 let color = (0.0, 0.0, 1.0 /. float c, 0.5) in
4773 rectx "rect" pageno color x0 y0 x1 y1;
4775 | "prect", args ->
4776 scan args "%u %f %f %f %f %f %f %f %f"
4777 (fun pageno r g b alpha x0 y0 x1 y1 ->
4778 addrect pageno r g b alpha x0 y0 x1 y1;
4779 postRedisplay "prect"
4781 | "pgoto", args ->
4782 scan args "%u %f %f"
4783 (fun pageno x y ->
4784 let optopaque =
4785 match getopaque pageno with
4786 | Some opaque -> opaque
4787 | None -> ~< E.s
4789 pgoto optopaque pageno x y;
4790 let rec fixx = function
4791 | [] -> ()
4792 | l :: rest ->
4793 if l.pageno = pageno
4794 then gotoxy (state.x - l.pagedispx) state.y
4795 else fixx rest
4797 let layout =
4798 let mult =
4799 match conf.columns with
4800 | Csingle _ | Csplit _ -> 1
4801 | Cmulti ((n, _, _), _) -> n
4803 layout 0 state.y (state.winw * mult) state.winh
4805 fixx layout
4807 | "activatewin", "" -> Wsi.activatewin ()
4808 | "quit", "" -> raise Quit
4809 | "keys", keys ->
4810 begin try
4811 let l = Config.keys_of_string keys in
4812 List.iter (fun (k, m) -> keyboard k m) l
4813 with exn -> adderrfmt "error processing keys" "`%S': %s\n"
4814 cmds @@ exntos exn
4816 | "clearrects", "" ->
4817 Hashtbl.clear state.prects;
4818 postRedisplay "clearrects"
4819 | _ ->
4820 adderrfmt "remote command"
4821 "error processing remote command: %S\n" cmds;
4824 let remote =
4825 let scratch = Bytes.create 80 in
4826 let buf = Buffer.create 80 in
4827 fun fd ->
4828 match tempfailureretry (Unix.read fd scratch 0) 80 with
4829 | exception Unix.Unix_error (Unix.EAGAIN, _, _) -> None
4830 | 0 ->
4831 Unix.close fd;
4832 if Buffer.length buf > 0
4833 then (
4834 let s = Buffer.contents buf in
4835 Buffer.clear buf;
4836 ract s;
4838 None
4839 | n ->
4840 let rec eat ppos =
4841 let nlpos =
4842 match Bytes.index_from scratch ppos '\n' with
4843 | pos -> if pos >= n then -1 else pos
4844 | exception Not_found -> -1
4846 if nlpos >= 0
4847 then (
4848 Buffer.add_subbytes buf scratch ppos (nlpos-ppos);
4849 let s = Buffer.contents buf in
4850 Buffer.clear buf;
4851 ract s;
4852 eat (nlpos+1);
4854 else (
4855 Buffer.add_subbytes buf scratch ppos (n-ppos);
4856 Some fd
4858 in eat 0
4861 let remoteopen path =
4862 try Some (Unix.openfile path [Unix.O_NONBLOCK; Unix.O_RDONLY] 0o0)
4863 with exn ->
4864 adderrfmt "remoteopen" "error opening %S: %s" path @@ exntos exn;
4865 None
4868 let () =
4869 let gcconfig = ref false in
4870 let trimcachepath = ref E.s in
4871 let rcmdpath = ref E.s in
4872 let pageno = ref None in
4873 let openlast = ref false in
4874 let doreap = ref false in
4875 let csspath = ref None in
4876 selfexec := Sys.executable_name;
4877 Arg.parse
4878 (Arg.align
4879 [("-p", Arg.String (fun s -> state.password <- s),
4880 "<password> Set password");
4882 ("-f", Arg.String
4883 (fun s ->
4884 Config.fontpath := s;
4885 selfexec := !selfexec ^ " -f " ^ Filename.quote s;
4887 "<path> Set path to the user interface font");
4889 ("-c", Arg.String
4890 (fun s ->
4891 selfexec := !selfexec ^ " -c " ^ Filename.quote s;
4892 Config.confpath := s),
4893 "<path> Set path to the configuration file");
4895 ("-last", Arg.Set openlast, " Open last document");
4897 ("-page", Arg.Int (fun pageno1 -> pageno := Some (pageno1-1)),
4898 "<page-number> Jump to page");
4900 ("-tcf", Arg.String (fun s -> trimcachepath := s),
4901 "<path> Set path to the trim cache file");
4903 ("-dest", Arg.String (fun s -> state.nameddest <- s),
4904 "<named-destination> Set named destination");
4906 ("-remote", Arg.String (fun s -> rcmdpath := s),
4907 "<path> Set path to the source of remote commands");
4909 ("-gc", Arg.Set gcconfig, " Collect config garbage");
4911 ("-v", Arg.Unit (fun () ->
4912 Printf.printf
4913 "%s\nconfiguration file: %s\n"
4914 (Help.version ())
4915 Config.defconfpath;
4916 exit 0), " Print version and exit");
4918 ("-css", Arg.String (fun s -> csspath := Some s),
4919 "<path> Set path to the style sheet to use with EPUB/HTML");
4921 ("-origin", Arg.String (fun s -> state.origin <- s),
4922 "<origin> <undocumented>");
4924 ("-no-title", Arg.Set ignoredoctitlte, " ignore document title");
4925 ("-layout-height", Arg.Set_int layouth,
4926 "<height> layout height html/epub/etc (-1, 0, N)");
4929 (fun s -> state.path <- s)
4930 ("Usage: " ^ Sys.argv.(0) ^ " [options] some.pdf\nOptions:");
4932 let histmode = emptystr state.path && not !openlast in
4934 if not (Config.load !openlast)
4935 then dolog "failed to load configuration";
4937 begin match !pageno with
4938 | Some pageno -> state.anchor <- (pageno, 0.0, 0.0)
4939 | None -> ()
4940 end;
4942 fillhelp ();
4943 if !gcconfig
4944 then (
4945 Config.gc ();
4946 exit 0
4949 let mu =
4950 object (self)
4951 val mutable m_clicks = 0
4952 val mutable m_click_x = 0
4953 val mutable m_click_y = 0
4954 val mutable m_lastclicktime = infinity
4956 method private cleanup =
4957 state.roam <- noroam;
4958 Hashtbl.iter (fun _ opaque -> clearmark opaque) state.pagemap
4959 method expose = postRedisplay "expose"
4960 method visible v =
4961 let name =
4962 match v with
4963 | Wsi.Unobscured -> "unobscured"
4964 | Wsi.PartiallyObscured -> "partiallyobscured"
4965 | Wsi.FullyObscured -> "fullyobscured"
4967 vlog "visibility change %s" name
4968 method display = display ()
4969 method map mapped = vlog "mapped %b" mapped
4970 method reshape w h =
4971 self#cleanup;
4972 reshape w h
4973 method mouse b d x y m =
4974 if d && canselect ()
4975 then (
4977 * http://blogs.msdn.com/b/oldnewthing/archive/2004/10/18/243925.aspx
4979 m_click_x <- x;
4980 m_click_y <- y;
4981 if b = 1
4982 then (
4983 let t = now () in
4984 if abs x - m_click_x > 10
4985 || abs y - m_click_y > 10
4986 || abs_float (t -. m_lastclicktime) > 0.3
4987 then m_clicks <- 0;
4988 m_clicks <- m_clicks + 1;
4989 m_lastclicktime <- t;
4990 if m_clicks = 1
4991 then (
4992 self#cleanup;
4993 postRedisplay "cleanup";
4994 state.uioh <- state.uioh#button b d x y m;
4996 else state.uioh <- state.uioh#multiclick m_clicks x y m
4998 else (
4999 self#cleanup;
5000 m_clicks <- 0;
5001 m_lastclicktime <- infinity;
5002 state.uioh <- state.uioh#button b d x y m
5005 else state.uioh <- state.uioh#button b d x y m
5006 method motion x y =
5007 state.mpos <- (x, y);
5008 state.uioh <- state.uioh#motion x y
5009 method pmotion x y =
5010 state.mpos <- (x, y);
5011 state.uioh <- state.uioh#pmotion x y
5012 method key k m =
5013 vlog "k=%#x m=%#x" k m;
5014 let mascm = m land (
5015 Wsi.altmask + Wsi.shiftmask + Wsi.ctrlmask + Wsi.metamask
5016 ) in
5017 let keyboard k m =
5018 let x = state.x and y = state.y in
5019 keyboard k m;
5020 if x != state.x || y != state.y then self#cleanup
5022 match state.keystate with
5023 | KSnone ->
5024 let km = k, mascm in
5025 begin
5026 match
5027 let modehash = state.uioh#modehash in
5028 try Hashtbl.find modehash km
5029 with Not_found ->
5030 try Hashtbl.find (findkeyhash conf "global") km
5031 with Not_found -> KMinsrt (k, m)
5032 with
5033 | KMinsrt (k, m) -> keyboard k m
5034 | KMinsrl l -> List.iter (fun (k, m) -> keyboard k m) l
5035 | KMmulti (l, r) -> state.keystate <- KSinto (l, r)
5037 | KSinto ((k', m') :: [], insrt) when k'=k && m' land mascm = m' ->
5038 List.iter (fun (k, m) -> keyboard k m) insrt;
5039 state.keystate <- KSnone
5040 | KSinto ((k', m') :: keys, insrt) when k'=k && m' land mascm = m' ->
5041 state.keystate <- KSinto (keys, insrt)
5042 | KSinto _ -> state.keystate <- KSnone
5044 method enter x y =
5045 state.mpos <- (x, y);
5046 state.uioh <- state.uioh#pmotion x y
5047 method leave = state.mpos <- (-1, -1)
5048 method winstate wsl = state.winstate <- wsl
5049 method quit : 'a. 'a = raise Quit
5050 method scroll dx dy = state.uioh <- state.uioh#scroll dx dy
5051 method zoom z x y = state.uioh#zoom z x y
5052 method opendoc path =
5053 state.mode <- View;
5054 state.uioh <- uioh;
5055 postRedisplay "opendoc";
5056 opendoc path state.password
5059 let wsfd, winw, winh = Wsi.init mu conf.cwinw conf.cwinh platform in
5060 state.wsfd <- wsfd;
5062 if not @@ List.exists GlMisc.check_extension
5063 [ "GL_ARB_texture_rectangle"
5064 ; "GL_EXT_texture_recangle"
5065 ; "GL_NV_texture_rectangle" ]
5066 then (dolog "OpenGL does not suppport rectangular textures"; exit 1);
5068 if substratis (GlMisc.get_string `renderer) 0 "Mesa DRI Intel("
5069 then (
5070 defconf.sliceheight <- 1024;
5071 defconf.texcount <- 32;
5072 defconf.usepbo <- true;
5075 let cs, ss =
5076 match Unix.socketpair Unix.PF_UNIX Unix.SOCK_STREAM 0 with
5077 | exception exn ->
5078 dolog "socketpair failed: %s" @@ exntos exn;
5079 exit 1
5080 | (r, w) ->
5081 cloexec r;
5082 cloexec w;
5083 r, w
5086 setcheckers conf.checkers;
5088 opengl_has_pbo := GlMisc.check_extension "GL_ARB_pixel_buffer_object";
5090 begin match !csspath with
5091 | None -> ()
5092 | Some "" -> conf.css <- E.s
5093 | Some path ->
5094 let css = filecontents path in
5095 let l = String.length css in
5096 conf.css <-
5097 if substratis css (l-2) "\r\n"
5098 then String.sub css 0 (l-2)
5099 else (if css.[l-1] = '\n' then String.sub css 0 (l-1) else css)
5100 end;
5101 init cs (
5102 conf.angle, conf.fitmodel, (conf.trimmargins, conf.trimfuzz),
5103 conf.texcount, conf.sliceheight, conf.mustoresize, conf.colorspace,
5104 !Config.fontpath, !trimcachepath, !opengl_has_pbo
5106 List.iter GlArray.enable [`texture_coord; `vertex];
5107 state.ss <- ss;
5108 reshape ~firsttime:true winw winh;
5109 state.uioh <- uioh;
5110 if histmode
5111 then (
5112 Wsi.settitle "llpp (history)";
5113 enterhistmode ();
5115 else (
5116 state.text <- "Opening " ^ (mbtoutf8 state.path);
5117 opendoc state.path state.password;
5119 display ();
5120 Wsi.mapwin ();
5121 Wsi.setcursor Wsi.CURSOR_INHERIT;
5122 Sys.set_signal Sys.sighup (Sys.Signal_handle (fun _ -> reload ()));
5124 let rec reap () =
5125 match Unix.waitpid [Unix.WNOHANG] ~-1 with
5126 | exception (Unix.Unix_error (Unix.ECHILD, _, _)) -> ()
5127 | exception exn -> dolog "Unix.waitpid: %s" @@ exntos exn
5128 | 0, _ -> ()
5129 | _pid, _status -> reap ()
5131 Sys.set_signal Sys.sigchld (Sys.Signal_handle (fun _ -> doreap := true));
5133 let optrfd =
5134 ref (if nonemptystr !rcmdpath then remoteopen !rcmdpath else None)
5137 let rec loop deadline =
5138 if !doreap
5139 then (
5140 doreap := false;
5141 reap ()
5143 let r = [state.ss; state.wsfd] in
5144 let r =
5145 match !optrfd with
5146 | None -> r
5147 | Some fd -> fd :: r
5149 if !redisplay
5150 then (
5151 Glutils.redisplay := false;
5152 display ();
5154 let timeout =
5155 let now = now () in
5156 if deadline > now
5157 then (
5158 if deadline = infinity
5159 then ~-.1.0
5160 else max 0.0 (deadline -. now)
5162 else 0.0
5164 let r, _, _ =
5165 try Unix.select r [] [] timeout
5166 with Unix.Unix_error (Unix.EINTR, _, _) -> [], [], []
5168 begin match r with
5169 | [] ->
5170 let newdeadline =
5171 match state.autoscroll with
5172 | Some step when step != 0 ->
5173 if state.slideshow land 1 = 1
5174 then (
5175 if state.slideshow land 2 = 0
5176 then state.slideshow <- state.slideshow lor 2
5177 else if step < 0 then prevpage () else nextpage ();
5178 deadline +. (float (abs step))
5180 else
5181 let y = state.y + step in
5182 let fy = if conf.maxhfit then state.winh else 0 in
5183 let y =
5184 if y < 0
5185 then state.maxy - fy
5186 else if y >= state.maxy - fy then 0 else y
5188 gotoxy state.x y;
5189 deadline +. 0.01
5190 | _ -> infinity
5192 loop newdeadline
5194 | l ->
5195 let rec checkfds = function
5196 | [] -> ()
5197 | fd :: rest when fd = state.ss ->
5198 let cmd = rcmd state.ss in
5199 act cmd;
5200 checkfds rest
5202 | fd :: rest when fd = state.wsfd ->
5203 Wsi.readresp fd;
5204 checkfds rest
5206 | fd :: rest when Some fd = !optrfd ->
5207 begin match remote fd with
5208 | None -> optrfd := remoteopen !rcmdpath;
5209 | opt -> optrfd := opt
5210 end;
5211 checkfds rest
5213 | _ :: rest ->
5214 dolog "select returned unknown descriptor";
5215 checkfds rest
5217 checkfds l;
5218 let newdeadline =
5219 let deadline1 =
5220 if deadline = infinity
5221 then now () +. 0.01
5222 else deadline
5224 match state.autoscroll with
5225 | Some step when step != 0 -> deadline1
5226 | _ -> infinity
5228 loop newdeadline
5229 end;
5231 match loop infinity with
5232 | exception Quit ->
5233 Config.save leavebirdseye;
5234 if hasunsavedchanges ()
5235 then save ()
5236 | _ -> error "umpossible - infinity reached"