Consistency
[llpp.git] / main.ml
blobe643b11a78efcf567847cc8b52e5dc0ee02584dc
1 open Utils;;
2 open Config;;
3 open Glutils;;
4 open Listview;;
5 open Link;;
7 let selfexec = ref E.s;;
8 let ignoredoctitlte = ref false;;
9 let layouth = ref ~-1;;
10 let checkerstexid = ref None;;
12 let debugrect (x0, y0, x1, y1, x2, y2, x3, y3) =
13 dolog {|rect {
14 x0,y0=(% f, % f)
15 x1,y1=(% f, % f)
16 x2,y2=(% f, % f)
17 x3,y3=(% f, % f)
18 }|} x0 y0 x1 y1 x2 y2 x3 y3;
21 let pgscale h = truncate (float h *. conf.pgscale);;
23 let hscrollh () =
24 if state.uioh#alwaysscrolly || ((conf.scrollb land scrollbhv != 0)
25 && (state.w > state.winw))
26 then conf.scrollbw
27 else 0
30 let setfontsize n =
31 fstate.fontsize <- n;
32 fstate.wwidth <- measurestr fstate.fontsize "w";
33 fstate.maxrows <- (state.winh - fstate.fontsize - 1) / (fstate.fontsize + 1);
36 let vlog fmt =
37 if conf.verbose
38 then dolog fmt
39 else Printf.kprintf ignore fmt
42 let launchpath () =
43 if emptystr conf.pathlauncher
44 then dolog "%s" state.path
45 else (
46 let command =
47 Str.global_replace Utils.Re.percent state.path conf.pathlauncher in
48 match spawn command [] with
49 | _pid -> ()
50 | exception exn -> dolog "failed to execute `%s': %s" command @@ exntos exn
54 let getopaque pageno =
55 try Some (Hashtbl.find state.pagemap (pageno, state.gen))
56 with Not_found -> None
59 let pagetranslatepoint l x y =
60 let dy = y - l.pagedispy in
61 let y = dy + l.pagey in
62 let dx = x - l.pagedispx in
63 let x = dx + l.pagex in
64 (x, y);
67 let onppundermouse g x y d =
68 let rec f = function
69 | l :: rest ->
70 begin match getopaque l.pageno with
71 | Some opaque ->
72 let x0 = l.pagedispx in
73 let x1 = x0 + l.pagevw in
74 let y0 = l.pagedispy in
75 let y1 = y0 + l.pagevh in
76 if y >= y0 && y <= y1 && x >= x0 && x <= x1
77 then
78 let px, py = pagetranslatepoint l x y in
79 match g opaque l px py with
80 | Some res -> res
81 | None -> f rest
82 else f rest
83 | _ -> f rest
84 end
85 | [] -> d
87 f state.layout
90 let getunder x y =
91 let g opaque l px py =
92 if state.bzoom
93 then (
94 match rectofblock opaque px py with
95 | Some [|x0;x1;y0;y1|] ->
96 let rect = (x0, y0, x1, y0, x1, y1, x0, y1) in
97 let color = (0.0, 0.0, 1.0 /. (l.pageno mod 3 |> float), 0.5) in
98 state.rects <- [l.pageno, color, rect];
99 postRedisplay "getunder";
100 | _ -> ()
102 let under = whatsunder opaque px py in
103 if under = Unone then None else Some under
105 onppundermouse g x y Unone
108 let unproject x y =
109 let g opaque l x y =
110 match unproject opaque x y with
111 | Some (x, y) -> Some (Some (opaque, l.pageno, x, y))
112 | None -> None
114 onppundermouse g x y None;
117 let showtext c s =
118 state.text <- Printf.sprintf "%c%s" c s;
119 postRedisplay "showtext";
122 let impmsg fmt = Format.ksprintf (fun s -> showtext '!' s) fmt;;
124 let pipesel opaque cmd =
125 if hassel opaque
126 then pipef ~closew:false "pipesel"
127 (fun w ->
128 copysel w opaque;
129 postRedisplay "pipesel"
130 ) cmd
133 let paxunder x y =
134 let g opaque l px py =
135 if markunder opaque px py conf.paxmark
136 then
137 Some (fun () ->
138 match getopaque l.pageno with
139 | None -> ()
140 | Some opaque -> pipesel opaque conf.paxcmd
142 else None
144 postRedisplay "paxunder";
145 if conf.paxmark = Mark_page
146 then
147 List.iter (fun l ->
148 match getopaque l.pageno with
149 | None -> ()
150 | Some opaque -> clearmark opaque) state.layout;
151 state.roam <- onppundermouse g x y (fun () -> impmsg "whoopsie daisy");
154 let undertext = function
155 | Unone -> "none"
156 | Ulinkuri s -> s
157 | Utext s -> "font: " ^ s
158 | Uannotation (opaque, slinkindex) ->
159 "annotation: " ^ getannotcontents opaque slinkindex
162 let updateunder x y =
163 match getunder x y with
164 | Unone -> Wsi.setcursor Wsi.CURSOR_INHERIT
165 | Ulinkuri uri ->
166 if conf.underinfo then showtext 'u' ("ri: " ^ uri);
167 Wsi.setcursor Wsi.CURSOR_INFO
168 | Utext s ->
169 if conf.underinfo then showtext 'f' ("ont: " ^ s);
170 Wsi.setcursor Wsi.CURSOR_TEXT
171 | Uannotation _ ->
172 if conf.underinfo then showtext 'a' "nnotation";
173 Wsi.setcursor Wsi.CURSOR_INFO
176 let showlinktype under =
177 if conf.underinfo && under != Unone
178 then showtext ' ' @@ undertext under
181 let intentry_with_suffix text key =
182 let text =
183 match [@warning "-4"] key with
184 | Keys.Ascii ('0'..'9' as c) -> addchar text c
185 | Keys.Ascii ('k' | 'm' | 'g' | 'K' | 'M' | 'G' as c) ->
186 addchar text @@ asciilower c
187 | _ ->
188 state.text <- "invalid key";
189 text
191 TEcont text
194 let wcmd fmt =
195 let b = Buffer.create 16 in
196 Printf.kbprintf
197 (fun b ->
198 let b = Buffer.to_bytes b in
199 wcmd state.ss b @@ Bytes.length b
200 ) b fmt
203 let nogeomcmds cmds =
204 match cmds with
205 | s, [] -> emptystr s
206 | _ -> false
209 let layoutN ((columns, coverA, coverB), b) x y sw sh =
210 let rec fold accu n =
211 if n = Array.length b
212 then accu
213 else
214 let pdimno, dx, vy, (_, w, h, xoff) = b.(n) in
215 if (vy - y) > sh &&
216 (n = coverA - 1
217 || n = state.pagecount - coverB
218 || (n - coverA) mod columns = columns - 1)
219 then accu
220 else
221 let accu =
222 if vy + h > y
223 then
224 let pagey = max 0 (y - vy) in
225 let pagedispy = if pagey > 0 then 0 else vy - y in
226 let pagedispx, pagex =
227 let pdx =
228 if n = coverA - 1 || n = state.pagecount - coverB
229 then x + (sw - w) / 2
230 else dx + xoff + x
232 if pdx < 0
233 then 0, -pdx
234 else pdx, 0
236 let pagevw =
237 let vw = sw - pagedispx in
238 let pw = w - pagex in
239 min vw pw
241 let pagevh = min (h - pagey) (sh - pagedispy) in
242 if pagevw > 0 && pagevh > 0
243 then
244 let e =
245 { pageno = n
246 ; pagedimno = pdimno
247 ; pagew = w
248 ; pageh = h
249 ; pagex = pagex
250 ; pagey = pagey
251 ; pagevw = pagevw
252 ; pagevh = pagevh
253 ; pagedispx = pagedispx
254 ; pagedispy = pagedispy
255 ; pagecol = 0
258 e :: accu
259 else accu
260 else accu
262 fold accu (n+1)
264 if Array.length b = 0
265 then []
266 else List.rev (fold [] (page_of_y y))
269 let layoutS (columns, b) x y sw sh =
270 let rec fold accu n =
271 if n = Array.length b
272 then accu
273 else
274 let pdimno, px, vy, (_, pagew, pageh, xoff) = b.(n) in
275 if (vy - y) > sh
276 then accu
277 else
278 let accu =
279 if vy + pageh > y
280 then
281 let x = xoff + x in
282 let pagey = max 0 (y - vy) in
283 let pagedispy = if pagey > 0 then 0 else vy - y in
284 let pagedispx, pagex =
285 if px = 0
286 then (
287 if x < 0
288 then 0, -x
289 else x, 0
291 else (
292 let px = px - x in
293 if px < 0
294 then -px, 0
295 else 0, px
298 let pagecolw = pagew/columns in
299 let pagedispx =
300 if pagecolw < sw
301 then pagedispx + ((sw - pagecolw) / 2)
302 else pagedispx
304 let pagevw =
305 let vw = sw - pagedispx in
306 let pw = pagew - pagex in
307 min vw pw
309 let pagevw = min pagevw pagecolw in
310 let pagevh = min (pageh - pagey) (sh - pagedispy) in
311 if pagevw > 0 && pagevh > 0
312 then
313 let e =
314 { pageno = n/columns
315 ; pagedimno = pdimno
316 ; pagew = pagew
317 ; pageh = pageh
318 ; pagex = pagex
319 ; pagey = pagey
320 ; pagevw = pagevw
321 ; pagevh = pagevh
322 ; pagedispx = pagedispx
323 ; pagedispy = pagedispy
324 ; pagecol = n mod columns
327 e :: accu
328 else accu
329 else accu
331 fold accu (n+1)
333 List.rev (fold [] 0)
336 let layout x y sw sh =
337 if nogeomcmds state.geomcmds
338 then
339 match conf.columns with
340 | Csingle b -> layoutN ((1, 0, 0), b) x y sw sh
341 | Cmulti c -> layoutN c x y sw sh
342 | Csplit s -> layoutS s x y sw sh
343 else []
346 let maxy () = state.maxy - if conf.maxhfit then state.winh else 0;;
347 let clamp incr = bound (state.y + incr) 0 @@ maxy ();;
349 let itertiles l f =
350 let tilex = l.pagex mod conf.tilew in
351 let tiley = l.pagey mod conf.tileh in
353 let col = l.pagex / conf.tilew in
354 let row = l.pagey / conf.tileh in
356 let rec rowloop row y0 dispy h =
357 if h != 0
358 then
359 let dh = conf.tileh - y0 in
360 let dh = min h dh in
361 let rec colloop col x0 dispx w =
362 if w != 0
363 then
364 let dw = conf.tilew - x0 in
365 let dw = min w dw in
366 f col row dispx dispy x0 y0 dw dh;
367 colloop (col+1) 0 (dispx+dw) (w-dw)
369 colloop col tilex l.pagedispx l.pagevw;
370 rowloop (row+1) 0 (dispy+dh) (h-dh)
372 if l.pagevw > 0 && l.pagevh > 0
373 then rowloop row tiley l.pagedispy l.pagevh;
376 let gettileopaque l col row =
377 let key = l.pageno, state.gen, conf.colorspace,
378 conf.angle, l.pagew, l.pageh, col, row in
379 try Some (Hashtbl.find state.tilemap key)
380 with Not_found -> None
383 let puttileopaque l col row gen colorspace angle opaque size elapsed =
384 let key = l.pageno, gen, colorspace, angle, l.pagew, l.pageh, col, row in
385 Hashtbl.add state.tilemap key (opaque, size, elapsed)
388 let drawtiles l color =
389 GlDraw.color color;
390 begintiles ();
391 let f col row x y tilex tiley w h =
392 match gettileopaque l col row with
393 | Some (opaque, _, t) ->
394 let params = x, y, w, h, tilex, tiley in
395 if conf.invert
396 then GlTex.env (`mode `blend);
397 drawtile params opaque;
398 if conf.invert
399 then GlTex.env (`mode `modulate);
400 if conf.debug
401 then (
402 endtiles ();
403 let s = Printf.sprintf "%d[%d,%d] %f sec" l.pageno col row t in
404 let w = measurestr fstate.fontsize s in
405 GlDraw.color (0.0, 0.0, 0.0);
406 filledrect
407 (float (x-2))
408 (float (y-2))
409 (float (x+2) +. w)
410 (float (y + fstate.fontsize + 2));
411 GlDraw.color color;
412 drawstring fstate.fontsize x (y + fstate.fontsize - 1) s;
413 begintiles ();
416 | None ->
417 endtiles ();
418 let w = let lw = state.winw - x in min lw w
419 and h = let lh = state.winh - y in min lh h
421 if conf.invert
422 then GlTex.env (`mode `blend);
423 begin match !checkerstexid with
424 | Some id ->
425 Gl.enable `texture_2d;
426 GlTex.bind_texture ~target:`texture_2d id;
427 let x0 = float x
428 and y0 = float y
429 and x1 = float (x+w)
430 and y1 = float (y+h) in
432 let tw = float w /. 16.0
433 and th = float h /. 16.0 in
434 let tx0 = float tilex /. 16.0
435 and ty0 = float tiley /. 16.0 in
436 let tx1 = tx0 +. tw
437 and ty1 = ty0 +. th in
438 Raw.sets_float Glutils.vraw ~pos:0
439 [| x0; y0; x0; y1; x1; y0; x1; y1 |];
440 Raw.sets_float Glutils.traw ~pos:0
441 [| tx0; ty0; tx0; ty1; tx1; ty0; tx1; ty1 |];
442 GlArray.vertex `two Glutils.vraw;
443 GlArray.tex_coord `two Glutils.traw;
444 GlArray.draw_arrays `triangle_strip ~first:0 ~count:4;
445 Gl.disable `texture_2d;
447 | None ->
448 GlDraw.color (1.0, 1.0, 1.0);
449 filledrect (float x) (float y) (float (x+w)) (float (y+h));
450 end;
451 if conf.invert
452 then GlTex.env (`mode `modulate);
453 if w > 128 && h > fstate.fontsize + 10
454 then (
455 let c = if conf.invert then 1.0 else 0.0 in
456 GlDraw.color (c, c, c);
457 let c, r =
458 if conf.verbose
459 then (col*conf.tilew, row*conf.tileh)
460 else col, row
462 drawstring2 fstate.fontsize x y "Loading %d [%d,%d]" l.pageno c r;
464 GlDraw.color color;
465 begintiles ();
467 itertiles l f;
468 endtiles ();
471 let pagevisible layout n = List.exists (fun l -> l.pageno = n) layout;;
473 let tilevisible1 l x y =
474 let ax0 = l.pagex
475 and ax1 = l.pagex + l.pagevw
476 and ay0 = l.pagey
477 and ay1 = l.pagey + l.pagevh in
479 let bx0 = x
480 and by0 = y in
481 let bx1 = min (bx0 + conf.tilew) l.pagew
482 and by1 = min (by0 + conf.tileh) l.pageh in
484 let rx0 = max ax0 bx0
485 and ry0 = max ay0 by0
486 and rx1 = min ax1 bx1
487 and ry1 = min ay1 by1 in
489 let nonemptyintersection = rx1 > rx0 && ry1 > ry0 in
490 nonemptyintersection
493 let tilevisible layout n x y =
494 let rec findpageinlayout m = function
495 | l :: rest when l.pageno = n ->
496 tilevisible1 l x y || (
497 match conf.columns with
498 | Csplit (c, _) when c > m -> findpageinlayout (m+1) rest
499 | Csplit _ | Csingle _ | Cmulti _ -> false
501 | _ :: rest -> findpageinlayout 0 rest
502 | [] -> false
504 findpageinlayout 0 layout;
507 let tileready l x y =
508 tilevisible1 l x y &&
509 gettileopaque l (x/conf.tilew) (y/conf.tileh) != None
512 let tilepage n p layout =
513 let rec loop = function
514 | l :: rest ->
515 if l.pageno = n
516 then
517 let f col row _ _ _ _ _ _ =
518 if state.currently = Idle
519 then
520 match gettileopaque l col row with
521 | Some _ -> ()
522 | None ->
523 let x = col*conf.tilew
524 and y = row*conf.tileh in
525 let w =
526 let w = l.pagew - x in
527 min w conf.tilew
529 let h =
530 let h = l.pageh - y in
531 min h conf.tileh
533 let pbo =
534 if conf.usepbo
535 then getpbo w h conf.colorspace
536 else ~< "0"
538 wcmd "tile %s %d %d %d %d %s" (~> p) x y w h (~> pbo);
539 state.currently <-
540 Tiling (
541 l, p, conf.colorspace, conf.angle,
542 state.gen, col, row, conf.tilew, conf.tileh
545 itertiles l f;
546 else
547 loop rest
549 | [] -> ()
551 if nogeomcmds state.geomcmds
552 then loop layout;
555 let preloadlayout x y sw sh =
556 let y = if y < sh then 0 else y - sh in
557 let x = min 0 (x + sw) in
558 let h = sh*3 in
559 let w = sw*3 in
560 layout x y w h;
563 let load pages =
564 let rec loop pages =
565 if state.currently = Idle
566 then
567 match pages with
568 | l :: rest ->
569 begin match getopaque l.pageno with
570 | None ->
571 wcmd "page %d %d" l.pageno l.pagedimno;
572 state.currently <- Loading (l, state.gen);
573 | Some opaque ->
574 tilepage l.pageno opaque pages;
575 loop rest
576 end;
577 | _ -> ()
579 if nogeomcmds state.geomcmds
580 then loop pages
583 let preload pages =
584 load pages;
585 if conf.preload && state.currently = Idle
586 then load (preloadlayout state.x state.y state.winw state.winh);
589 let layoutready layout =
590 let rec fold all ls =
591 all && match ls with
592 | l :: rest ->
593 let seen = ref false in
594 let allvisible = ref true in
595 let foo col row _ _ _ _ _ _ =
596 seen := true;
597 allvisible := !allvisible &&
598 begin match gettileopaque l col row with
599 | Some _ -> true
600 | None -> false
603 itertiles l foo;
604 fold (!seen && !allvisible) rest
605 | [] -> true
607 let alltilesvisible = fold true layout in
608 alltilesvisible;
611 let gotoxy x y =
612 let y = bound y 0 state.maxy in
613 let y, layout =
614 let layout = layout x y state.winw state.winh in
615 postRedisplay "gotoxy ready";
616 y, layout
618 state.x <- x;
619 state.y <- y;
620 state.layout <- layout;
621 begin match state.mode with
622 | LinkNav ln ->
623 begin match ln with
624 | Ltexact (pageno, linkno) ->
625 let rec loop = function
626 | [] ->
627 state.lnava <- Some (pageno, linkno);
628 state.mode <- LinkNav (Ltgendir 0)
629 | l :: _ when l.pageno = pageno ->
630 begin match getopaque pageno with
631 | None -> state.mode <- LinkNav (Ltnotready (pageno, 0))
632 | Some opaque ->
633 let x0, y0, x1, y1 = getlinkrect opaque linkno in
634 if not (x0 >= l.pagex && x1 <= l.pagex + l.pagevw
635 && y0 >= l.pagey && y1 <= l.pagey + l.pagevh)
636 then state.mode <- LinkNav (Ltgendir 0)
638 | _ :: rest -> loop rest
640 loop layout
641 | Ltnotready _ | Ltgendir _ -> ()
643 | Birdseye _ | Textentry _ | View -> ()
644 end;
645 begin match state.mode with
646 | Birdseye (conf, leftx, pageno, hooverpageno, anchor) ->
647 if not (pagevisible layout pageno)
648 then (
649 match state.layout with
650 | [] -> ()
651 | l :: _ ->
652 state.mode <- Birdseye (conf, leftx, l.pageno, hooverpageno, anchor)
654 | LinkNav lt ->
655 begin match lt with
656 | Ltnotready (_, dir)
657 | Ltgendir dir ->
658 let linknav =
659 let rec loop = function
660 | [] -> lt
661 | l :: rest ->
662 match getopaque l.pageno with
663 | None -> Ltnotready (l.pageno, dir)
664 | Some opaque ->
665 let link =
666 let ld =
667 if dir = 0
668 then LDfirstvisible (l.pagex, l.pagey, dir)
669 else (
670 if dir > 0 then LDfirst else LDlast
673 findlink opaque ld
675 match link with
676 | Lnotfound -> loop rest
677 | Lfound n ->
678 showlinktype (getlink opaque n);
679 Ltexact (l.pageno, n)
681 loop state.layout
683 state.mode <- LinkNav linknav
684 | Ltexact _ -> ()
686 | Textentry _ | View -> ()
687 end;
688 preload layout;
689 if conf.updatecurs
690 then (
691 let mx, my = state.mpos in
692 updateunder mx my;
696 let conttiling pageno opaque =
697 tilepage pageno opaque
698 (if conf.preload
699 then preloadlayout state.x state.y state.winw state.winh
700 else state.layout)
703 let gotoxy x y =
704 if not conf.verbose then state.text <- E.s;
705 gotoxy x y;
708 let getanchory (n, top, dtop) =
709 let y, h = getpageyh n in
710 if conf.presentation
711 then
712 let ips = calcips h in
713 y + truncate (top*.float h -. dtop*.float ips) + ips;
714 else y + truncate (top*.float h -. dtop*.float conf.interpagespace)
717 let gotoanchor anchor = gotoxy state.x (getanchory anchor);;
718 let addnav () = getanchor () |> cbput state.hists.nav;;
719 let addnavnorc () = getanchor () |> cbput_dont_update_rc state.hists.nav;;
721 let getnav dir =
722 let anchor = cbgetc state.hists.nav dir in
723 getanchory anchor;
726 let gotopage n top =
727 let y, h = getpageyh n in
728 let y = y + (truncate (top *. float h)) in
729 gotoxy state.x y
732 let gotopage1 n top =
733 let y = getpagey n in
734 let y = y + top in
735 gotoxy state.x y
738 let invalidate s f =
739 Glutils.redisplay := false;
740 state.layout <- [];
741 state.pdims <- [];
742 state.rects <- [];
743 state.rects1 <- [];
744 match state.geomcmds with
745 | ps, [] when emptystr ps ->
746 f ();
747 state.geomcmds <- s, [];
748 | ps, [] -> state.geomcmds <- ps, [s, f];
749 | ps, (s', _) :: rest when s' = s -> state.geomcmds <- ps, ((s, f) :: rest);
750 | ps, cmds -> state.geomcmds <- ps, ((s, f) :: cmds);
753 let flushpages () =
754 Hashtbl.iter (fun _ opaque -> wcmd "freepage %s" (~> opaque)) state.pagemap;
755 Hashtbl.clear state.pagemap;
758 let flushtiles () =
759 if not (Queue.is_empty state.tilelru)
760 then (
761 Queue.iter (fun (k, p, s) ->
762 wcmd "freetile %s" (~> p);
763 state.memused <- state.memused - s;
764 Hashtbl.remove state.tilemap k;
765 ) state.tilelru;
766 state.uioh#infochanged Memused;
767 Queue.clear state.tilelru;
769 load state.layout;
772 let stateh h =
773 let h = truncate (float h*.conf.zoom) in
774 let d = conf.interpagespace lsl (if conf.presentation then 1 else 0) in
775 h - d
778 let fillhelp () =
779 state.help <-
780 let sl = keystostrlist conf in
781 let rec loop accu =
782 function | [] -> accu
783 | s :: rest -> loop ((s, 0, Noaction) :: accu) rest
784 in Help.makehelp conf.urilauncher
785 @ (("", 0, Noaction) :: loop [] sl) |> Array.of_list
788 let opendoc path password =
789 state.path <- path;
790 state.password <- password;
791 state.gen <- state.gen + 1;
792 state.docinfo <- [];
793 state.outlines <- [||];
795 flushpages ();
796 setaalevel conf.aalevel;
797 let titlepath =
798 if emptystr state.origin
799 then path
800 else state.origin
802 Wsi.settitle ("llpp " ^ mbtoutf8 (Filename.basename titlepath));
803 wcmd "open %d %d %s\000%s\000%s\000"
804 (btod conf.usedoccss) !layouth
805 path password conf.css;
806 invalidate "reqlayout"
807 (fun () ->
808 wcmd "reqlayout %d %d %d %s\000"
809 conf.angle (FMTE.to_int conf.fitmodel)
810 (stateh state.winh) state.nameddest
812 fillhelp ();
815 let reload () =
816 state.anchor <- getanchor ();
817 opendoc state.path state.password;
820 let scalecolor c =
821 let c = c *. conf.colorscale in
822 (c, c, c);
825 let scalecolor2 (r, g, b) =
826 (r *. conf.colorscale, g *. conf.colorscale, b *. conf.colorscale);
829 let docolumns columns =
830 match columns with
831 | Csingle _ ->
832 let a = Array.make state.pagecount (-1, -1, -1, (-1, -1, -1, -1)) in
833 let rec loop pageno pdimno pdim y ph pdims =
834 if pageno != state.pagecount
835 then
836 let pdimno, ((_, w, h, xoff) as pdim), pdims =
837 match pdims with
838 | ((pageno', _, _, _) as pdim) :: rest when pageno' = pageno ->
839 pdimno+1, pdim, rest
840 | _ ->
841 pdimno, pdim, pdims
843 let x = max 0 (((state.winw - w) / 2) - xoff) in
844 let y =
845 y + (if conf.presentation
846 then (if pageno = 0 then calcips h else calcips ph + calcips h)
847 else (if pageno = 0 then 0 else conf.interpagespace))
849 a.(pageno) <- (pdimno, x, y, pdim);
850 loop (pageno+1) pdimno pdim (y + h) h pdims
852 loop 0 ~-1 (-1,-1,-1,-1) 0 0 state.pdims;
853 conf.columns <- Csingle a;
855 | Cmulti ((columns, coverA, coverB), _) ->
856 let a = Array.make state.pagecount (-1, -1, -1, (-1, -1, -1, -1)) in
857 let rec loop pageno pdimno pdim x y rowh pdims =
858 let rec fixrow m =
859 if m = pageno then () else
860 let (pdimno, x, y, ((_, _, h, _) as pdim)) = a.(m) in
861 if h < rowh
862 then (
863 let y = y + (rowh - h) / 2 in
864 a.(m) <- (pdimno, x, y, pdim);
866 fixrow (m+1)
868 if pageno = state.pagecount
869 then fixrow (((pageno - 1) / columns) * columns)
870 else
871 let pdimno, ((_, w, h, xoff) as pdim), pdims =
872 match pdims with
873 | ((pageno', _, _, _) as pdim) :: rest when pageno' = pageno ->
874 pdimno+1, pdim, rest
875 | _ -> pdimno, pdim, pdims
877 let x, y, rowh' =
878 if pageno = coverA - 1 || pageno = state.pagecount - coverB
879 then (
880 let x = (state.winw - w) / 2 in
881 let ips =
882 if conf.presentation then calcips h else conf.interpagespace in
883 x, y + ips + rowh, h
885 else (
886 if (pageno - coverA) mod columns = 0
887 then (
888 let x = max 0 (state.winw - state.w) / 2 in
889 let y =
890 if conf.presentation
891 then
892 let ips = calcips h in
893 y + (if pageno = 0 then 0 else calcips rowh + ips)
894 else
895 y + (if pageno = 0 then 0 else conf.interpagespace)
897 x, y + rowh, h
899 else x, y, max rowh h
902 let y =
903 if pageno > 1 && (pageno - coverA) mod columns = 0
904 then (
905 let y =
906 if pageno = columns && conf.presentation
907 then (
908 let ips = calcips rowh in
909 for i = 0 to pred columns
911 let (pdimno, x, y, pdim) = a.(i) in
912 a.(i) <- (pdimno, x, y+ips, pdim)
913 done;
914 y+ips;
916 else y
918 fixrow (pageno - columns);
921 else y
923 a.(pageno) <- (pdimno, x, y, pdim);
924 let x = x + w + xoff*2 + conf.interpagespace in
925 loop (pageno+1) pdimno pdim x y rowh' pdims
927 loop 0 ~-1 (-1,-1,-1,-1) 0 0 0 state.pdims;
928 conf.columns <- Cmulti ((columns, coverA, coverB), a);
930 | Csplit (c, _) ->
931 let a = Array.make (state.pagecount*c) (-1, -1, -1, (-1, -1, -1, -1)) in
932 let rec loop pageno pdimno pdim y pdims =
933 if pageno != state.pagecount
934 then
935 let pdimno, ((_, w, h, _) as pdim), pdims =
936 match pdims with
937 | ((pageno', _, _, _) as pdim) :: rest when pageno' = pageno ->
938 pdimno+1, pdim, rest
939 | _ -> pdimno, pdim, pdims
941 let cw = w / c in
942 let rec loop1 n x y =
943 if n = c then y else (
944 a.(pageno*c + n) <- (pdimno, x, y, pdim);
945 loop1 (n+1) (x+cw) (y + h + conf.interpagespace)
948 let y = loop1 0 0 y in
949 loop (pageno+1) pdimno pdim y pdims
951 loop 0 ~-1 (-1,-1,-1,-1) 0 state.pdims;
952 conf.columns <- Csplit (c, a);
955 let represent () =
956 docolumns conf.columns;
957 state.maxy <- calcheight ();
958 if state.reprf == noreprf
959 then (
960 match state.mode with
961 | Birdseye (_, _, pageno, _, _) ->
962 let y, h = getpageyh pageno in
963 let top = (state.winh - h) / 2 in
964 gotoxy state.x (max 0 (y - top))
965 | Textentry _ | View | LinkNav _ ->
966 let y = getanchory state.anchor in
967 let y = min y (state.maxy - state.winh) in
968 gotoxy state.x y;
970 else (
971 state.reprf ();
972 state.reprf <- noreprf;
976 let reshape ?(firsttime=false) w h =
977 GlDraw.viewport ~x:0 ~y:0 ~w ~h;
978 if not firsttime && nogeomcmds state.geomcmds
979 then state.anchor <- getanchor ();
981 state.winw <- w;
982 let w = truncate (float w *. conf.zoom) in
983 let w = max w 2 in
984 state.winh <- h;
985 setfontsize fstate.fontsize;
986 GlMat.mode `modelview;
987 GlMat.load_identity ();
989 GlMat.mode `projection;
990 GlMat.load_identity ();
991 GlMat.rotate ~x:1.0 ~angle:180.0 ();
992 GlMat.translate ~x:~-.1.0 ~y:~-.1.0 ();
993 GlMat.scale3 (2.0 /. float state.winw, 2.0 /. float state.winh, 1.0);
995 let relx =
996 if conf.zoom <= 1.0
997 then 0.0
998 else float state.x /. float state.w
1000 invalidate "geometry"
1001 (fun () ->
1002 state.w <- w;
1003 if not firsttime
1004 then state.x <- truncate (relx *. float w);
1005 let w =
1006 match conf.columns with
1007 | Csingle _ -> w
1008 | Cmulti ((c, _, _), _) -> (w - (c-1)*conf.interpagespace) / c
1009 | Csplit (c, _) -> w * c
1011 wcmd "geometry %d %d %d" w (stateh h) (FMTE.to_int conf.fitmodel)
1015 let gctiles () =
1016 let len = Queue.length state.tilelru in
1017 let layout = lazy (if conf.preload
1018 then preloadlayout state.x state.y state.winw state.winh
1019 else state.layout) in
1020 let rec loop qpos =
1021 if state.memused > conf.memlimit
1022 then (
1023 if qpos < len
1024 then
1025 let (k, p, s) as lruitem = Queue.pop state.tilelru in
1026 let n, gen, colorspace, angle, pagew, pageh, col, row = k in
1027 let (_, pw, ph, _) = getpagedim n in
1028 if gen = state.gen
1029 && colorspace = conf.colorspace
1030 && angle = conf.angle
1031 && pagew = pw
1032 && pageh = ph
1033 && (
1034 let x = col*conf.tilew and y = row*conf.tileh in
1035 tilevisible (Lazy.force_val layout) n x y
1037 then Queue.push lruitem state.tilelru
1038 else (
1039 freepbo p;
1040 wcmd "freetile %s" (~> p);
1041 state.memused <- state.memused - s;
1042 state.uioh#infochanged Memused;
1043 Hashtbl.remove state.tilemap k;
1045 loop (qpos+1)
1048 loop 0
1051 let onpagerect pageno f =
1052 let b =
1053 match conf.columns with
1054 | Cmulti (_, b) -> b
1055 | Csingle b -> b
1056 | Csplit (_, b) -> b
1058 if pageno >= 0 && pageno < Array.length b
1059 then
1060 let (_, _, _, (_, w, h, _)) = b.(pageno) in
1061 f w h
1064 let gotopagexy1 pageno x y =
1065 let _,w1,h1,leftx = getpagedim pageno in
1066 let top = y /. (float h1) in
1067 let left = x /. (float w1) in
1068 let py, w, h = getpageywh pageno in
1069 let wh = state.winh in
1070 let x = left *. (float w) in
1071 let x = leftx + state.x + truncate x in
1072 let sx =
1073 if x < 0 || x >= state.winw
1074 then state.x - x
1075 else state.x
1077 let pdy = truncate (top *. float h) in
1078 let y' = py + pdy in
1079 let dy = y' - state.y in
1080 let sy =
1081 if x != state.x || not (dy > 0 && dy < wh)
1082 then (
1083 if conf.presentation
1084 then
1085 if abs (py - y') > wh
1086 then y'
1087 else py
1088 else y';
1090 else state.y
1092 if state.x != sx || state.y != sy
1093 then gotoxy sx sy
1094 else gotoxy state.x state.y;
1097 let gotopagexy pageno x y =
1098 match state.mode with
1099 | Birdseye _ -> gotopage pageno 0.0
1100 | Textentry _ | View | LinkNav _ -> gotopagexy1 pageno x y
1103 let getpassword () =
1104 let passcmd = getenvwithdef "LLPP_ASKPASS" conf.passcmd in
1105 if emptystr passcmd
1106 then E.s
1107 else getcmdoutput
1108 (fun s ->
1109 impmsg "error getting password: %s" s;
1110 dolog "%s" s) passcmd;
1113 let pgoto opaque pageno x y =
1114 let pdimno = getpdimno pageno in
1115 let x, y = project opaque pageno pdimno x y in
1116 gotopagexy pageno x y;
1119 let act cmds =
1120 (* dolog "%S" cmds; *)
1121 let spl = splitatchar cmds ' ' in
1122 let scan s fmt f =
1123 try Scanf.sscanf s fmt f
1124 with exn ->
1125 dolog "error processing '%S': %s" cmds @@ exntos exn;
1126 exit 1
1128 let addoutline outline =
1129 match state.currently with
1130 | Outlining outlines -> state.currently <- Outlining (outline :: outlines)
1131 | Idle -> state.currently <- Outlining [outline]
1132 | Loading _ | Tiling _ ->
1133 dolog "invalid outlining state";
1134 logcurrently state.currently
1136 match spl with
1137 | "clear", "" ->
1138 state.pdims <- [];
1139 state.uioh#infochanged Pdim;
1141 | "clearrects", "" ->
1142 state.rects <- state.rects1;
1143 postRedisplay "clearrects";
1145 | "continue", args ->
1146 let n = scan args "%u" (fun n -> n) in
1147 state.pagecount <- n;
1148 begin match state.currently with
1149 | Outlining l ->
1150 state.currently <- Idle;
1151 state.outlines <- Array.of_list (List.rev l)
1152 | Idle | Loading _ | Tiling _ -> ()
1153 end;
1155 let cur, cmds = state.geomcmds in
1156 if emptystr cur
1157 then error "empty geomcmd";
1159 begin match List.rev cmds with
1160 | [] ->
1161 state.geomcmds <- E.s, [];
1162 represent ();
1163 | (s, f) :: rest ->
1164 f ();
1165 state.geomcmds <- s, List.rev rest;
1166 end;
1167 postRedisplay "continue";
1169 | "msg", args ->
1170 showtext ' ' args
1172 | "vmsg", args ->
1173 if conf.verbose
1174 then showtext ' ' args
1176 | "emsg", args ->
1177 Buffer.add_string state.errmsgs args;
1178 state.newerrmsgs <- true;
1179 postRedisplay "error message"
1181 | "progress", args ->
1182 let progress, text =
1183 scan args "%f %n"
1184 (fun f pos ->
1185 f, String.sub args pos (String.length args - pos))
1187 state.text <- text;
1188 state.progress <- progress;
1189 postRedisplay "progress"
1191 | "firstmatch", args ->
1192 let pageno, c, x0, y0, x1, y1, x2, y2, x3, y3 =
1193 scan args "%u %d %f %f %f %f %f %f %f %f"
1194 (fun p c x0 y0 x1 y1 x2 y2 x3 y3 ->
1195 (p, c, x0, y0, x1, y1, x2, y2, x3, y3))
1197 let y = (getpagey pageno) + truncate y0 in
1198 let x =
1199 if (state.x < - truncate x0) || (state.x > state.winw - truncate x1)
1200 then state.winw/2 - truncate (x0 /. 2. +. x1 /. 2.)
1201 else state.x
1203 addnav ();
1204 gotoxy x y;
1205 let color = (0.0, 0.0, 1.0 /. float c, 0.5) in
1206 state.rects1 <- [pageno, color, (x0, y0, x1, y1, x2, y2, x3, y3)]
1208 | "match", args ->
1209 let pageno, c, x0, y0, x1, y1, x2, y2, x3, y3 =
1210 scan args "%u %d %f %f %f %f %f %f %f %f"
1211 (fun p c x0 y0 x1 y1 x2 y2 x3 y3 ->
1212 (p, c, x0, y0, x1, y1, x2, y2, x3, y3))
1214 let color = (0.0, 0.0, 1.0 /. float c, 0.5) in
1215 state.rects1 <-
1216 (pageno, color, (x0, y0, x1, y1, x2, y2, x3, y3)) :: state.rects1
1218 | "page", args ->
1219 let pageopaques, t = scan args "%s %f" (fun p t -> p, t) in
1220 let pageopaque = ~< pageopaques in
1221 begin match state.currently with
1222 | Loading (l, gen) ->
1223 vlog "page %d took %f sec" l.pageno t;
1224 Hashtbl.replace state.pagemap (l.pageno, gen) pageopaque;
1225 let preloadedpages =
1226 if conf.preload
1227 then preloadlayout state.x state.y state.winw state.winh
1228 else state.layout
1230 let evict () =
1231 let set = List.fold_left (fun s l -> IntSet.add l.pageno s)
1232 IntSet.empty preloadedpages
1234 let evictedpages =
1235 Hashtbl.fold (fun ((pageno, _) as key) opaque accu ->
1236 if not (IntSet.mem pageno set)
1237 then (
1238 wcmd "freepage %s" (~> opaque);
1239 key :: accu
1241 else accu
1242 ) state.pagemap []
1244 List.iter (Hashtbl.remove state.pagemap) evictedpages;
1246 evict ();
1247 state.currently <- Idle;
1248 if gen = state.gen
1249 then (
1250 tilepage l.pageno pageopaque state.layout;
1251 load state.layout;
1252 load preloadedpages;
1253 let visible = pagevisible state.layout l.pageno in
1254 if visible
1255 then (
1256 match state.mode with
1257 | LinkNav (Ltnotready (pageno, dir)) ->
1258 if pageno = l.pageno
1259 then (
1260 let link =
1261 let ld =
1262 if dir = 0
1263 then LDfirstvisible (l.pagex, l.pagey, dir)
1264 else (
1265 if dir > 0 then LDfirst else LDlast
1268 findlink pageopaque ld
1270 match link with
1271 | Lnotfound -> ()
1272 | Lfound n ->
1273 showlinktype (getlink pageopaque n);
1274 state.mode <- LinkNav (Ltexact (l.pageno, n))
1276 | LinkNav (Ltgendir _)
1277 | LinkNav (Ltexact _)
1278 | View
1279 | Birdseye _
1280 | Textentry _ -> ()
1283 if visible && layoutready state.layout
1284 then (
1285 postRedisplay "page";
1289 | Idle | Tiling _ | Outlining _ ->
1290 dolog "Inconsistent loading state";
1291 logcurrently state.currently;
1292 exit 1
1295 | "tile" , args ->
1296 let (x, y, opaques, size, t) =
1297 scan args "%u %u %s %u %f"
1298 (fun x y p size t -> (x, y, p, size, t))
1300 let opaque = ~< opaques in
1301 begin match state.currently with
1302 | Tiling (l, pageopaque, cs, angle, gen, col, row, tilew, tileh) ->
1303 vlog "tile %d [%d,%d] took %f sec" l.pageno col row t;
1305 unmappbo opaque;
1306 if tilew != conf.tilew || tileh != conf.tileh
1307 then (
1308 wcmd "freetile %s" (~> opaque);
1309 state.currently <- Idle;
1310 load state.layout;
1312 else (
1313 puttileopaque l col row gen cs angle opaque size t;
1314 state.memused <- state.memused + size;
1315 state.uioh#infochanged Memused;
1316 gctiles ();
1317 Queue.push ((l.pageno, gen, cs, angle, l.pagew, l.pageh, col, row),
1318 opaque, size) state.tilelru;
1320 state.currently <- Idle;
1321 if gen = state.gen
1322 && conf.colorspace = cs
1323 && conf.angle = angle
1324 && tilevisible state.layout l.pageno x y
1325 then conttiling l.pageno pageopaque;
1327 preload state.layout;
1328 if gen = state.gen
1329 && conf.colorspace = cs
1330 && conf.angle = angle
1331 && tilevisible state.layout l.pageno x y
1332 && layoutready state.layout
1333 then postRedisplay "tile nothrottle";
1336 | Idle | Loading _ | Outlining _ ->
1337 dolog "Inconsistent tiling state";
1338 logcurrently state.currently;
1339 exit 1
1342 | "pdim", args ->
1343 let (n, w, h, _) as pdim =
1344 scan args "%u %u %u %u" (fun n w h x -> n, w, h, x)
1346 let pdim =
1347 match conf.fitmodel with
1348 | FitWidth -> pdim
1349 | FitPage | FitProportional ->
1350 match conf.columns with
1351 | Csplit _ -> (n, w, h, 0)
1352 | Csingle _ | Cmulti _ -> pdim
1354 state.pdims <- pdim :: state.pdims;
1355 state.uioh#infochanged Pdim
1357 | "o", args ->
1358 let (l, n, t, h, pos) =
1359 scan args "%u %u %d %u %n" (fun l n t h pos -> l, n, t, h, pos)
1361 let s = String.sub args pos (String.length args - pos) in
1362 addoutline (s, l, Oanchor (n, float t /. float h, 0.0))
1364 | "ou", args ->
1365 let (l, len, pos) = scan args "%u %u %n" (fun l len pos -> l, len, pos) in
1366 let s = String.sub args pos len in
1367 let pos2 = pos + len + 1 in
1368 let uri = String.sub args pos2 (String.length args - pos2) in
1369 addoutline (s, l, Ouri uri)
1371 | "on", args ->
1372 let (l, pos) = scan args "%u %n" (fun l pos -> l, pos) in
1373 let s = String.sub args pos (String.length args - pos) in
1374 addoutline (s, l, Onone)
1376 | "a", args ->
1377 let (n, l, t) = scan args "%u %d %d" (fun n l t -> n, l, t) in
1378 state.reprf <- (fun () -> gotopagexy n (float l) (float t))
1380 | "info", args ->
1381 let c, v = splitatchar args '\t' in
1382 let s =
1383 if nonemptystr v
1384 then
1385 if c = "Title"
1386 then (
1387 conf.title <- v;
1388 if not !ignoredoctitlte
1389 then Wsi.settitle v;
1390 args
1392 else
1393 if let len = String.length c in
1394 len > 6 && ((String.sub c (len-4) 4) = "date")
1395 then (
1396 if String.length v >= 7 && v.[0] = 'D' && v.[1] = ':'
1397 then
1398 let b = Buffer.create 10 in
1399 Printf.bprintf b "%s\t" c;
1400 let sub p l c =
1402 Buffer.add_substring b v p l;
1403 Buffer.add_char b c;
1404 with exn -> Buffer.add_string b @@ exntos exn
1406 sub 2 4 '/';
1407 sub 6 2 '/';
1408 sub 8 2 ' ';
1409 sub 10 2 ':';
1410 sub 12 2 ':';
1411 sub 14 2 ' ';
1412 Buffer.add_char b '[';
1413 Buffer.add_string b v;
1414 Buffer.add_char b ']';
1415 Buffer.contents b
1416 else args
1418 else args
1419 else args
1421 state.docinfo <- (1, s) :: state.docinfo
1423 | "infoend", "" ->
1424 state.docinfo <- List.rev state.docinfo;
1425 state.uioh#infochanged Docinfo
1427 | "pass", args ->
1428 if args = "fail"
1429 then Wsi.settitle "Wrong password";
1430 let password = getpassword () in
1431 if emptystr password
1432 then error "document is password protected"
1433 else opendoc state.path password
1435 | _ -> error "unknown cmd `%S'" cmds
1438 let onhist cb =
1439 let rc = cb.rc in
1440 let action = function
1441 | HCprev -> cbget cb ~-1
1442 | HCnext -> cbget cb 1
1443 | HCfirst -> cbget cb ~-(cb.rc)
1444 | HClast -> cbget cb (cb.len - 1 - cb.rc)
1445 and cancel () = cb.rc <- rc
1446 in (action, cancel)
1449 let search pattern forward =
1450 match conf.columns with
1451 | Csplit _ -> impmsg "searching does not work properly in split columns mode"
1452 | Csingle _ | Cmulti _ ->
1453 if nonemptystr pattern
1454 then
1455 let pn, py =
1456 match state.layout with
1457 | [] -> 0, 0
1458 | l :: _ -> l.pageno, (l.pagey + if forward then 0 else 0*l.pagevh)
1460 wcmd "search %d %d %d %d,%s\000"
1461 (btod conf.icase) pn py (btod forward) pattern;
1464 let intentry text key =
1465 let text =
1466 if emptystr text && key = Keys.Ascii '-'
1467 then addchar text '-'
1468 else
1469 match [@warning "-4"] key with
1470 | Keys.Ascii ('0'..'9' as c) -> addchar text c
1471 | _ ->
1472 state.text <- "invalid key";
1473 text
1475 TEcont text
1478 let linknact f s =
1479 if nonemptystr s
1480 then (
1481 let n =
1482 let l = String.length s in
1483 let rec loop pos n =
1484 if pos = l
1485 then n
1486 else
1487 let m = Char.code s.[pos] - (if pos = 0 && l > 1 then 96 else 97) in
1488 loop (pos+1) (n*26 + m)
1489 in loop 0 0
1491 let rec loop n = function
1492 | [] -> ()
1493 | l :: rest ->
1494 match getopaque l.pageno with
1495 | None -> loop n rest
1496 | Some opaque ->
1497 let m = getlinkcount opaque in
1498 if n < m
1499 then (
1500 let under = getlink opaque n in
1501 f under
1503 else loop (n-m) rest
1505 loop n state.layout;
1509 let linknentry text key = match [@warning "-4"] key with
1510 | Keys.Ascii c ->
1511 let text = addchar text c in
1512 linknact (fun under -> state.text <- undertext under) text;
1513 TEcont text
1514 | _ ->
1515 state.text <- Printf.sprintf "invalid key";
1516 TEcont text
1519 let textentry text key = match [@warning "-4"] key with
1520 | Keys.Ascii c -> TEcont (addchar text c)
1521 | Keys.Code c -> TEcont (text ^ toutf8 c)
1522 | _ -> TEcont text
1525 let reqlayout angle fitmodel =
1526 if nogeomcmds state.geomcmds
1527 then state.anchor <- getanchor ();
1528 conf.angle <- angle mod 360;
1529 if conf.angle != 0
1530 then (
1531 match state.mode with
1532 | LinkNav _ -> state.mode <- View
1533 | Birdseye _ | Textentry _ | View -> ()
1535 conf.fitmodel <- fitmodel;
1536 invalidate "reqlayout"
1537 (fun () ->
1538 wcmd "reqlayout %d %d %d"
1539 conf.angle (FMTE.to_int conf.fitmodel) (stateh state.winh)
1543 let settrim trimmargins trimfuzz =
1544 if nogeomcmds state.geomcmds
1545 then state.anchor <- getanchor ();
1546 conf.trimmargins <- trimmargins;
1547 conf.trimfuzz <- trimfuzz;
1548 let x0, y0, x1, y1 = trimfuzz in
1549 invalidate "settrim"
1550 (fun () -> wcmd "settrim %d %d %d %d %d"
1551 (btod conf.trimmargins) x0 y0 x1 y1);
1552 flushpages ();
1555 let setzoom zoom =
1556 let zoom = max 0.0001 zoom in
1557 if zoom <> conf.zoom
1558 then (
1559 state.prevzoom <- (conf.zoom, state.x);
1560 conf.zoom <- zoom;
1561 reshape state.winw state.winh;
1562 state.text <- Printf.sprintf "zoom is now %-5.2f" (zoom *. 100.0);
1566 let pivotzoom ?(vw=min state.w state.winw)
1567 ?(vh=min (state.maxy-state.y) state.winh)
1568 ?(x=vw/2) ?(y=vh/2) zoom =
1569 let w = float state.w /. zoom in
1570 let hw = w /. 2.0 in
1571 let ratio = float vh /. float vw in
1572 let hh = hw *. ratio in
1573 let x0 = float x -. hw
1574 and y0 = float y -. hh in
1575 gotoxy (state.x - truncate x0) (state.y + truncate y0);
1576 setzoom zoom;
1579 let pivotzoom ?vw ?vh ?x ?y zoom =
1580 if nogeomcmds state.geomcmds
1581 then
1582 if zoom > 1.0
1583 then pivotzoom ?vw ?vh ?x ?y zoom
1584 else setzoom zoom
1587 let setcolumns mode columns coverA coverB =
1588 state.prevcolumns <- Some (conf.columns, conf.zoom);
1589 if columns < 0
1590 then (
1591 if isbirdseye mode
1592 then impmsg "split mode doesn't work in bird's eye"
1593 else (
1594 conf.columns <- Csplit (-columns, E.a);
1595 state.x <- 0;
1596 conf.zoom <- 1.0;
1599 else (
1600 if columns < 2
1601 then (
1602 conf.columns <- Csingle E.a;
1603 state.x <- 0;
1604 setzoom 1.0;
1606 else (
1607 conf.columns <- Cmulti ((columns, coverA, coverB), E.a);
1608 conf.zoom <- 1.0;
1611 reshape state.winw state.winh;
1614 let resetmstate () =
1615 state.mstate <- Mnone;
1616 Wsi.setcursor Wsi.CURSOR_INHERIT;
1619 let enterbirdseye () =
1620 let zoom = float conf.thumbw /. float state.winw in
1621 let birdseyepageno =
1622 let cy = state.winh / 2 in
1623 let fold = function
1624 | [] -> 0
1625 | l :: rest ->
1626 let rec fold best = function
1627 | [] -> best.pageno
1628 | l :: rest ->
1629 let d = cy - (l.pagedispy + l.pagevh/2)
1630 and dbest = cy - (best.pagedispy + best.pagevh/2) in
1631 if abs d < abs dbest
1632 then fold l rest
1633 else best.pageno
1634 in fold l rest
1636 fold state.layout
1638 state.mode <-
1639 Birdseye (
1640 { conf with zoom = conf.zoom },
1641 state.x, birdseyepageno, -1, getanchor ()
1643 resetmstate ();
1644 conf.zoom <- zoom;
1645 conf.presentation <- false;
1646 conf.interpagespace <- 10;
1647 conf.hlinks <- false;
1648 conf.fitmodel <- FitPage;
1649 state.x <- 0;
1650 conf.columns <- (
1651 match conf.beyecolumns with
1652 | Some c ->
1653 conf.zoom <- 1.0;
1654 Cmulti ((c, 0, 0), E.a)
1655 | None -> Csingle E.a
1657 if conf.verbose
1658 then
1659 state.text <- Printf.sprintf "birds eye mode on (zoom %3.1f%%)"
1660 (100.0*.zoom)
1661 else state.text <- E.s;
1662 reshape state.winw state.winh;
1665 let leavebirdseye (c, leftx, pageno, _, anchor) goback =
1666 state.mode <- View;
1667 conf.zoom <- c.zoom;
1668 conf.presentation <- c.presentation;
1669 conf.interpagespace <- c.interpagespace;
1670 conf.hlinks <- c.hlinks;
1671 conf.fitmodel <- c.fitmodel;
1672 conf.beyecolumns <- (
1673 match conf.columns with
1674 | Cmulti ((c, _, _), _) -> Some c
1675 | Csingle _ -> None
1676 | Csplit _ -> error "leaving bird's eye split mode"
1678 conf.columns <- (
1679 match c.columns with
1680 | Cmulti (c, _) -> Cmulti (c, E.a)
1681 | Csingle _ -> Csingle E.a
1682 | Csplit (c, _) -> Csplit (c, E.a)
1684 if conf.verbose
1685 then
1686 state.text <- Printf.sprintf "birds eye mode off (zoom %3.1f%%)"
1687 (100.0*.conf.zoom);
1688 reshape state.winw state.winh;
1689 state.anchor <- if goback then anchor else (pageno, 0.0, 1.0);
1690 state.x <- leftx;
1693 let togglebirdseye () =
1694 match state.mode with
1695 | Birdseye vals -> leavebirdseye vals true
1696 | View -> enterbirdseye ()
1697 | Textentry _ | LinkNav _ -> ()
1700 let upbirdseye incr (conf, leftx, pageno, hooverpageno, anchor) =
1701 let pageno = max 0 (pageno - incr) in
1702 let rec loop = function
1703 | [] -> gotopage1 pageno 0
1704 | l :: _ when l.pageno = pageno ->
1705 if l.pagedispy >= 0 && l.pagey = 0
1706 then postRedisplay "upbirdseye"
1707 else gotopage1 pageno 0
1708 | _ :: rest -> loop rest
1710 loop state.layout;
1711 state.text <- E.s;
1712 state.mode <- Birdseye (conf, leftx, pageno, hooverpageno, anchor)
1715 let downbirdseye incr (conf, leftx, pageno, hooverpageno, anchor) =
1716 let pageno = min (state.pagecount - 1) (pageno + incr) in
1717 state.mode <- Birdseye (conf, leftx, pageno, hooverpageno, anchor);
1718 let rec loop = function
1719 | [] ->
1720 let y, h = getpageyh pageno in
1721 let dy = (y - state.y) - (state.winh - h - conf.interpagespace) in
1722 gotoxy state.x (clamp dy)
1723 | l :: _ when l.pageno = pageno ->
1724 if l.pagevh != l.pageh
1725 then gotoxy state.x (clamp (l.pageh - l.pagevh + conf.interpagespace))
1726 else postRedisplay "downbirdseye"
1727 | _ :: rest -> loop rest
1729 loop state.layout;
1730 state.text <- E.s;
1733 let optentry mode _ key =
1734 let btos b = if b then "on" else "off" in
1735 match [@warning "-4"] key with
1736 | Keys.Ascii 'C' ->
1737 let ondone s =
1739 let n, a, b = multicolumns_of_string s in
1740 setcolumns mode n a b;
1741 with exn ->
1742 state.text <- Printf.sprintf "bad columns `%s': %s" s @@ exntos exn
1744 TEswitch ("columns: ", E.s, None, textentry, ondone, true)
1746 | Keys.Ascii 'Z' ->
1747 let ondone s =
1749 let zoom = float (int_of_string s) /. 100.0 in
1750 pivotzoom zoom
1751 with exn ->
1752 state.text <- Printf.sprintf "bad integer `%s': %s" s @@ exntos exn
1754 TEswitch ("zoom: ", E.s, None, intentry, ondone, true)
1756 | Keys.Ascii 'i' ->
1757 conf.icase <- not conf.icase;
1758 TEdone ("case insensitive search " ^ (btos conf.icase))
1760 | Keys.Ascii 'v' ->
1761 conf.verbose <- not conf.verbose;
1762 TEdone ("verbose " ^ (btos conf.verbose))
1764 | Keys.Ascii 'd' ->
1765 conf.debug <- not conf.debug;
1766 TEdone ("debug " ^ (btos conf.debug))
1768 | Keys.Ascii 'f' ->
1769 conf.underinfo <- not conf.underinfo;
1770 TEdone ("underinfo " ^ btos conf.underinfo)
1772 | Keys.Ascii 'T' ->
1773 settrim (not conf.trimmargins) conf.trimfuzz;
1774 TEdone ("trim margins " ^ btos conf.trimmargins)
1776 | Keys.Ascii 'I' ->
1777 conf.invert <- not conf.invert;
1778 TEdone ("invert colors " ^ btos conf.invert)
1780 | Keys.Ascii 'x' ->
1781 let ondone s =
1782 cbput state.hists.sel s;
1783 conf.selcmd <- s;
1785 TEswitch ("selection command: ", E.s, Some (onhist state.hists.sel),
1786 textentry, ondone, true)
1788 | Keys.Ascii 'M' ->
1789 if conf.pax == None
1790 then conf.pax <- Some 0.0
1791 else conf.pax <- None;
1792 TEdone ("PAX " ^ btos (conf.pax != None))
1794 | (Keys.Ascii c) ->
1795 state.text <- Printf.sprintf "bad option %d `%c'" (Char.code c) c;
1796 TEstop
1798 | _ -> TEcont state.text
1801 let adderrmsg src msg =
1802 Buffer.add_string state.errmsgs msg;
1803 state.newerrmsgs <- true;
1804 postRedisplay src
1807 let adderrfmt src fmt = Format.ksprintf (fun s -> adderrmsg src s) fmt;;
1809 class outlinelistview ~zebra ~source =
1810 let settext autonarrow s =
1811 if autonarrow
1812 then
1813 let ss = source#statestr in
1814 state.text <-
1815 if emptystr ss
1816 then "[" ^ s ^ "]"
1817 else "{" ^ ss ^ "} [" ^ s ^ "]"
1818 else state.text <- s
1820 object (self)
1821 inherit listview
1822 ~zebra
1823 ~helpmode:false
1824 ~source:(source :> lvsource)
1825 ~trusted:false
1826 ~modehash:(findkeyhash conf "outline")
1827 as super
1829 val m_autonarrow = false
1831 method! key key mask =
1832 let maxrows =
1833 if emptystr state.text
1834 then fstate.maxrows
1835 else fstate.maxrows - 2
1837 let calcfirst first active =
1838 if active > first
1839 then
1840 let rows = active - first in
1841 if rows > maxrows then active - maxrows else first
1842 else active
1844 let navigate incr =
1845 let active = m_active + incr in
1846 let active = bound active 0 (source#getitemcount - 1) in
1847 let first = calcfirst m_first active in
1848 postRedisplay "outline navigate";
1849 coe {< m_active = active; m_first = first >}
1851 let navscroll first =
1852 let active =
1853 let dist = m_active - first in
1854 if dist < 0
1855 then first
1856 else (
1857 if dist < maxrows
1858 then m_active
1859 else first + maxrows
1862 postRedisplay "outline navscroll";
1863 coe {< m_first = first; m_active = active >}
1865 let ctrl = Wsi.withctrl mask in
1866 let open Keys in
1867 match Wsi.kc2kt key with
1868 | Ascii 'a' when ctrl ->
1869 let text =
1870 if m_autonarrow
1871 then (
1872 source#denarrow;
1875 else (
1876 let pattern = source#renarrow in
1877 if nonemptystr m_qsearch
1878 then (source#narrow m_qsearch; m_qsearch)
1879 else pattern
1882 settext (not m_autonarrow) text;
1883 postRedisplay "toggle auto narrowing";
1884 coe {< m_first = 0; m_active = 0; m_autonarrow = not m_autonarrow >}
1886 | Ascii '/' when emptystr m_qsearch && not m_autonarrow ->
1887 settext true E.s;
1888 postRedisplay "toggle auto narrowing";
1889 coe {< m_first = 0; m_active = 0; m_autonarrow = true >}
1891 | Ascii 'n' when ctrl ->
1892 source#narrow m_qsearch;
1893 if not m_autonarrow
1894 then source#add_narrow_pattern m_qsearch;
1895 postRedisplay "outline ctrl-n";
1896 coe {< m_first = 0; m_active = 0 >}
1898 | Ascii 'S' when ctrl ->
1899 let active = source#calcactive (getanchor ()) in
1900 let first = firstof m_first active in
1901 postRedisplay "outline ctrl-s";
1902 coe {< m_first = first; m_active = active >}
1904 | Ascii 'u' when ctrl ->
1905 postRedisplay "outline ctrl-u";
1906 if m_autonarrow && nonemptystr m_qsearch
1907 then (
1908 ignore (source#renarrow);
1909 settext m_autonarrow E.s;
1910 coe {< m_first = 0; m_active = 0; m_qsearch = E.s >}
1912 else (
1913 source#del_narrow_pattern;
1914 let pattern = source#renarrow in
1915 let text =
1916 if emptystr pattern then E.s else "Narrowed to " ^ pattern
1918 settext m_autonarrow text;
1919 coe {< m_first = 0; m_active = 0; m_qsearch = E.s >}
1922 | Ascii 'l' when ctrl ->
1923 let first = max 0 (m_active - (fstate.maxrows / 2)) in
1924 postRedisplay "outline ctrl-l";
1925 coe {< m_first = first >}
1927 | Ascii '\t' when m_autonarrow ->
1928 if nonemptystr m_qsearch
1929 then (
1930 postRedisplay "outline list view tab";
1931 source#add_narrow_pattern m_qsearch;
1932 settext true E.s;
1933 coe {< m_qsearch = E.s >}
1935 else coe self
1937 | Escape when m_autonarrow ->
1938 if nonemptystr m_qsearch
1939 then source#add_narrow_pattern m_qsearch;
1940 super#key key mask
1942 | Enter when m_autonarrow ->
1943 if nonemptystr m_qsearch
1944 then source#add_narrow_pattern m_qsearch;
1945 super#key key mask
1947 | (Ascii _ | Code _) when m_autonarrow ->
1948 let pattern = m_qsearch ^ toutf8 key in
1949 postRedisplay "outlinelistview autonarrow add";
1950 source#narrow pattern;
1951 settext true pattern;
1952 coe {< m_first = 0; m_active = 0; m_qsearch = pattern >}
1954 | Backspace when m_autonarrow ->
1955 if emptystr m_qsearch
1956 then coe self
1957 else
1958 let pattern = withoutlastutf8 m_qsearch in
1959 postRedisplay "outlinelistview autonarrow backspace";
1960 ignore (source#renarrow);
1961 source#narrow pattern;
1962 settext true pattern;
1963 coe {< m_first = 0; m_active = 0; m_qsearch = pattern >}
1965 | Up when ctrl -> navscroll (max 0 (m_first - 1))
1967 | Down when ctrl ->
1968 navscroll (min (source#getitemcount - 1) (m_first + 1))
1970 | Up -> navigate ~-1
1971 | Down -> navigate 1
1972 | Prior -> navigate ~-(fstate.maxrows)
1973 | Next -> navigate fstate.maxrows
1975 | Right ->
1976 let o =
1977 if ctrl
1978 then (
1979 postRedisplay "outline ctrl right";
1980 {< m_pan = m_pan + 1 >}
1982 else self#updownlevel 1
1984 coe o
1986 | Left ->
1987 let o =
1988 if ctrl
1989 then (
1990 postRedisplay "outline ctrl left";
1991 {< m_pan = m_pan - 1 >}
1993 else self#updownlevel ~-1
1995 coe o
1997 | Home ->
1998 postRedisplay "outline home";
1999 coe {< m_first = 0; m_active = 0 >}
2001 | End ->
2002 let active = source#getitemcount - 1 in
2003 let first = max 0 (active - fstate.maxrows) in
2004 postRedisplay "outline end";
2005 coe {< m_active = active; m_first = first >}
2007 | Delete|Escape|Insert|Enter|Ascii _|Code _|Ctrl _|Backspace|Fn _ ->
2008 super#key key mask
2009 end;;
2011 let genhistoutlines () =
2012 Config.gethist ()
2013 |> List.sort (fun (_, c1, _, _, _, _) (_, c2, _, _, _, _) ->
2014 compare c2.lastvisit c1.lastvisit)
2015 |> List.map (fun ((path, c, _, _, _, origin) as hist) ->
2016 let path = if nonemptystr origin then origin else path in
2017 let base = mbtoutf8 @@ Filename.basename path in
2018 (base ^ "\000" ^ c.title, 1, Ohistory hist)
2022 let gotohist (path, c, bookmarks, x, anchor, origin) =
2023 Config.save leavebirdseye;
2024 state.anchor <- anchor;
2025 state.bookmarks <- bookmarks;
2026 state.origin <- origin;
2027 state.x <- x;
2028 setconf conf c;
2029 let x0, y0, x1, y1 = conf.trimfuzz in
2030 wcmd "trimset %d %d %d %d %d" (btod conf.trimmargins) x0 y0 x1 y1;
2031 reshape ~firsttime:true state.winw state.winh;
2032 opendoc path origin;
2033 setzoom c.zoom;
2036 let setcheckers enabled =
2037 match !checkerstexid with
2038 | None -> if enabled then checkerstexid := Some (makecheckers ())
2039 | Some id ->
2040 if not enabled
2041 then (
2042 GlTex.delete_texture id;
2043 checkerstexid := None;
2047 let describe_layout layout =
2048 let d =
2049 match layout with
2050 | [] -> "Page 0"
2051 | l :: [] -> Printf.sprintf "Page %d" (l.pageno+1)
2052 | l :: rest ->
2053 let rangestr a b =
2054 if a.pageno = b.pageno then Printf.sprintf "%d" (a.pageno+1)
2055 else Printf.sprintf "%d%s%d" (a.pageno+1)
2056 (if a.pageno+1 = b.pageno then ", " else Utf8syms.ellipsis)
2057 (b.pageno+1)
2059 let rec fold s la lb = function
2060 | [] -> Printf.sprintf "%s %s" s (rangestr la lb)
2061 | l :: rest when l.pageno = succ lb.pageno -> fold s la l rest
2062 | l :: rest -> fold (s ^ " " ^ rangestr la lb ^ ",") l l rest
2064 fold "Pages" l l rest
2066 let percent =
2067 let maxy = maxy () in
2068 if maxy <= 0
2069 then 100.
2070 else 100. *. (float state.y /. float maxy)
2072 Printf.sprintf "%s of %d [%.2f%%]" d state.pagecount percent
2075 let setpresentationmode v =
2076 let n = page_of_y state.y in
2077 state.anchor <- (n, 0.0, 1.0);
2078 conf.presentation <- v;
2079 if conf.fitmodel = FitPage
2080 then reqlayout conf.angle conf.fitmodel;
2081 represent ();
2084 let enterinfomode =
2085 let btos b = if b then Utf8syms.radical else E.s in
2086 let showextended = ref false in
2087 let showcolors = ref false in
2088 let leave mode _ = state.mode <- mode in
2089 let src =
2090 (object
2091 val mutable m_l = []
2092 val mutable m_a = E.a
2093 val mutable m_prev_uioh = nouioh
2094 val mutable m_prev_mode = View
2096 inherit lvsourcebase
2098 method reset prev_mode prev_uioh =
2099 m_a <- Array.of_list (List.rev m_l);
2100 m_l <- [];
2101 m_prev_mode <- prev_mode;
2102 m_prev_uioh <- prev_uioh;
2104 method int name get set =
2105 m_l <-
2106 (name, `int get, 1,
2107 Action (
2108 fun u ->
2109 let ondone s =
2110 try set (int_of_string s)
2111 with exn ->
2112 state.text <- Printf.sprintf "bad integer `%s': %s"
2113 s @@ exntos exn
2115 state.text <- E.s;
2116 let te = name ^ ": ", E.s, None, intentry, ondone, true in
2117 state.mode <- Textentry (te, leave m_prev_mode);
2119 )) :: m_l
2121 method int_with_suffix name get set =
2122 m_l <-
2123 (name, `intws get, 1,
2124 Action (
2125 fun u ->
2126 let ondone s =
2127 try set (int_of_string_with_suffix s)
2128 with exn ->
2129 state.text <- Printf.sprintf "bad integer `%s': %s"
2130 s @@ exntos exn
2132 state.text <- E.s;
2133 let te =
2134 name ^ ": ", E.s, None, intentry_with_suffix, ondone, true
2136 state.mode <- Textentry (te, leave m_prev_mode);
2138 )) :: m_l
2140 method bool ?(offset=1) ?(btos=btos) name get set =
2141 m_l <-
2142 (name, `bool (btos, get), offset, Action (
2143 fun u ->
2144 let v = get () in
2145 set (not v);
2147 )) :: m_l
2149 method color name get set =
2150 m_l <-
2151 (name, `color get, 1,
2152 Action (
2153 fun u ->
2154 let invalid = (nan, nan, nan) in
2155 let ondone s =
2156 let c =
2157 try color_of_string s
2158 with exn ->
2159 state.text <- Printf.sprintf "bad color `%s': %s"
2160 s @@ exntos exn;
2161 invalid
2163 if c <> invalid
2164 then set c;
2166 let te = name ^ ": ", E.s, None, textentry, ondone, true in
2167 state.text <- color_to_string (get ());
2168 state.mode <- Textentry (te, leave m_prev_mode);
2170 )) :: m_l
2172 method string name get set =
2173 m_l <-
2174 (name, `string get, 1,
2175 Action (
2176 fun u ->
2177 let ondone s = set s in
2178 let te = name ^ ": ", E.s, None, textentry, ondone, true in
2179 state.mode <- Textentry (te, leave m_prev_mode);
2181 )) :: m_l
2183 method colorspace name get set =
2184 m_l <-
2185 (name, `string get, 1,
2186 Action (
2187 fun _ ->
2188 let source =
2189 (object
2190 inherit lvsourcebase
2192 initializer
2193 m_active <- CSTE.to_int conf.colorspace;
2194 m_first <- 0;
2196 method getitemcount =
2197 Array.length CSTE.names
2198 method getitem n =
2199 (CSTE.names.(n), 0)
2200 method exit ~uioh ~cancel ~active ~first ~pan =
2201 ignore (uioh, first, pan);
2202 if not cancel then set active;
2203 None
2204 method hasaction _ = true
2205 end)
2207 state.text <- E.s;
2208 let modehash = findkeyhash conf "info" in
2209 coe (new listview ~zebra:false ~helpmode:false
2210 ~source ~trusted:true ~modehash)
2211 )) :: m_l
2213 method paxmark name get set =
2214 m_l <-
2215 (name, `string get, 1,
2216 Action (
2217 fun _ ->
2218 let source =
2219 (object
2220 inherit lvsourcebase
2222 initializer
2223 m_active <- MTE.to_int conf.paxmark;
2224 m_first <- 0;
2226 method getitemcount = Array.length MTE.names
2227 method getitem n = (MTE.names.(n), 0)
2228 method exit ~uioh ~cancel ~active ~first ~pan =
2229 ignore (uioh, first, pan);
2230 if not cancel then set active;
2231 None
2232 method hasaction _ = true
2233 end)
2235 state.text <- E.s;
2236 let modehash = findkeyhash conf "info" in
2237 coe (new listview ~zebra:false ~helpmode:false
2238 ~source ~trusted:true ~modehash)
2239 )) :: m_l
2241 method fitmodel name get set =
2242 m_l <-
2243 (name, `string get, 1,
2244 Action (
2245 fun _ ->
2246 let source =
2247 (object
2248 inherit lvsourcebase
2250 initializer
2251 m_active <- FMTE.to_int conf.fitmodel;
2252 m_first <- 0;
2254 method getitemcount = Array.length FMTE.names
2255 method getitem n = (FMTE.names.(n), 0)
2256 method exit ~uioh ~cancel ~active ~first ~pan =
2257 ignore (uioh, first, pan);
2258 if not cancel then set active;
2259 None
2260 method hasaction _ = true
2261 end)
2263 state.text <- E.s;
2264 let modehash = findkeyhash conf "info" in
2265 coe (new listview ~zebra:false ~helpmode:false
2266 ~source ~trusted:true ~modehash)
2267 )) :: m_l
2269 method caption s offset =
2270 m_l <- (s, `empty, offset, Noaction) :: m_l
2272 method caption2 s f offset =
2273 m_l <- (s, `string f, offset, Noaction) :: m_l
2275 method getitemcount = Array.length m_a
2277 method getitem n =
2278 let tostr = function
2279 | `int f -> string_of_int (f ())
2280 | `intws f -> string_with_suffix_of_int (f ())
2281 | `string f -> f ()
2282 | `color f -> color_to_string (f ())
2283 | `bool (btos, f) -> btos (f ())
2284 | `empty -> E.s
2286 let name, t, offset, _ = m_a.(n) in
2287 ((let s = tostr t in
2288 if nonemptystr s
2289 then Printf.sprintf "%s\t%s" name s
2290 else name),
2291 offset)
2293 method exit ~uioh ~cancel ~active ~first ~pan =
2294 let uiohopt =
2295 if not cancel
2296 then (
2297 let uioh =
2298 match m_a.(active) with
2299 | _, _, _, Action f -> f uioh
2300 | _, _, _, Noaction -> uioh
2302 Some uioh
2304 else None
2306 m_active <- active;
2307 m_first <- first;
2308 m_pan <- pan;
2309 uiohopt
2311 method hasaction n =
2312 match m_a.(n) with
2313 | _, _, _, Action _ -> true
2314 | _, _, _, Noaction -> false
2316 initializer m_active <- 1
2317 end)
2319 let rec fillsrc prevmode prevuioh =
2320 let sep () = src#caption E.s 0 in
2321 let colorp name get set =
2322 src#string name
2323 (fun () -> color_to_string (get ()))
2324 (fun v ->
2325 try set @@ color_of_string v
2326 with exn ->
2327 state.text <-
2328 Printf.sprintf "bad color `%s': %s" v @@ exntos exn
2331 let rgba name get set =
2332 src#string name
2333 (fun () -> get () |> rgba_to_string)
2334 (fun v ->
2335 try set @@ rgba_of_string v
2336 with exn ->
2337 state.text <-
2338 Printf.sprintf "bad color `%s': %s" v @@ exntos exn
2341 let oldmode = state.mode in
2342 let birdseye = isbirdseye state.mode in
2344 src#caption (if birdseye then "Setup (Bird's eye)" else "Setup") 0;
2346 src#bool "presentation mode"
2347 (fun () -> conf.presentation)
2348 (fun v -> setpresentationmode v);
2350 src#bool "ignore case in searches"
2351 (fun () -> conf.icase)
2352 (fun v -> conf.icase <- v);
2354 src#bool "preload"
2355 (fun () -> conf.preload)
2356 (fun v -> conf.preload <- v);
2358 src#bool "highlight links"
2359 (fun () -> conf.hlinks)
2360 (fun v -> conf.hlinks <- v);
2362 src#bool "under info"
2363 (fun () -> conf.underinfo)
2364 (fun v -> conf.underinfo <- v);
2366 src#fitmodel "fit model"
2367 (fun () -> FMTE.to_string conf.fitmodel)
2368 (fun v -> reqlayout conf.angle (FMTE.of_int v));
2370 src#bool "trim margins"
2371 (fun () -> conf.trimmargins)
2372 (fun v -> settrim v conf.trimfuzz; fillsrc prevmode prevuioh);
2374 sep ();
2375 src#int "inter-page space"
2376 (fun () -> conf.interpagespace)
2377 (fun n ->
2378 conf.interpagespace <- n;
2379 docolumns conf.columns;
2380 let pageno, py =
2381 match state.layout with
2382 | [] -> 0, 0
2383 | l :: _ -> l.pageno, l.pagey
2385 state.maxy <- calcheight ();
2386 let y = getpagey pageno in
2387 gotoxy state.x (y + py)
2390 src#int "page bias"
2391 (fun () -> conf.pagebias)
2392 (fun v -> conf.pagebias <- v);
2394 src#int "scroll step"
2395 (fun () -> conf.scrollstep)
2396 (fun n -> conf.scrollstep <- n);
2398 src#int "horizontal scroll step"
2399 (fun () -> conf.hscrollstep)
2400 (fun v -> conf.hscrollstep <- v);
2402 src#int "auto scroll step"
2403 (fun () ->
2404 match state.autoscroll with
2405 | Some step -> step
2406 | _ -> conf.autoscrollstep)
2407 (fun n ->
2408 let n = boundastep state.winh n in
2409 if state.autoscroll <> None
2410 then state.autoscroll <- Some n;
2411 conf.autoscrollstep <- n);
2413 src#int "zoom"
2414 (fun () -> truncate (conf.zoom *. 100.))
2415 (fun v -> pivotzoom ((float v) /. 100.));
2417 src#int "rotation"
2418 (fun () -> conf.angle)
2419 (fun v -> reqlayout v conf.fitmodel);
2421 src#int "scroll bar width"
2422 (fun () -> conf.scrollbw)
2423 (fun v ->
2424 conf.scrollbw <- v;
2425 reshape state.winw state.winh;
2428 src#int "scroll handle height"
2429 (fun () -> conf.scrollh)
2430 (fun v -> conf.scrollh <- v;);
2432 src#int "thumbnail width"
2433 (fun () -> conf.thumbw)
2434 (fun v ->
2435 conf.thumbw <- min 4096 v;
2436 match oldmode with
2437 | Birdseye beye ->
2438 leavebirdseye beye false;
2439 enterbirdseye ()
2440 | Textentry _
2441 | View
2442 | LinkNav _ -> ()
2445 let mode = state.mode in
2446 src#string "columns"
2447 (fun () ->
2448 match conf.columns with
2449 | Csingle _ -> "1"
2450 | Cmulti (multi, _) -> multicolumns_to_string multi
2451 | Csplit (count, _) -> "-" ^ string_of_int count
2453 (fun v ->
2454 let n, a, b = multicolumns_of_string v in
2455 setcolumns mode n a b);
2457 sep ();
2458 src#caption "Pixmap cache" 0;
2459 src#int_with_suffix "size (advisory)"
2460 (fun () -> conf.memlimit)
2461 (fun v -> conf.memlimit <- v);
2463 src#caption2 "used"
2464 (fun () ->
2465 Printf.sprintf "%s bytes, %d tiles"
2466 (string_with_suffix_of_int state.memused)
2467 (Hashtbl.length state.tilemap)) 1;
2469 sep ();
2470 src#caption "Layout" 0;
2471 src#caption2 "Dimension"
2472 (fun () -> Printf.sprintf "%dx%d (virtual %dx%d)"
2473 state.winw state.winh
2474 state.w state.maxy)
2476 if conf.debug
2477 then src#caption2 "Position" (fun () ->
2478 Printf.sprintf "%dx%d" state.x state.y
2480 else src#caption2 "Position" (fun () -> describe_layout state.layout) 1;
2482 sep ();
2483 src#bool ~offset:0 ~btos:(fun v -> if v then "(on)" else "(off)")
2484 "Save these parameters as global defaults at exit"
2485 (fun () -> conf.bedefault)
2486 (fun v -> conf.bedefault <- v);
2488 sep ();
2489 let btos b = Utf8syms.(if b then lguillemet else rguillemet) in
2490 src#bool ~offset:0 ~btos "Extended parameters"
2491 (fun () -> !showextended)
2492 (fun v -> showextended := v; fillsrc prevmode prevuioh);
2493 if !showextended
2494 then (
2495 src#bool "checkers"
2496 (fun () -> conf.checkers)
2497 (fun v -> conf.checkers <- v; setcheckers v);
2498 src#bool "update cursor"
2499 (fun () -> conf.updatecurs)
2500 (fun v -> conf.updatecurs <- v);
2501 src#bool "scroll-bar on the left"
2502 (fun () -> conf.leftscroll)
2503 (fun v -> conf.leftscroll <- v);
2504 src#bool "verbose"
2505 (fun () -> conf.verbose)
2506 (fun v -> conf.verbose <- v);
2507 src#bool "invert colors"
2508 (fun () -> conf.invert)
2509 (fun v -> conf.invert <- v);
2510 src#bool "max fit"
2511 (fun () -> conf.maxhfit)
2512 (fun v -> conf.maxhfit <- v);
2513 src#bool "pax mode"
2514 (fun () -> conf.pax != None)
2515 (fun v ->
2516 if v
2517 then conf.pax <- Some (now ())
2518 else conf.pax <- None);
2519 src#string "uri launcher"
2520 (fun () -> conf.urilauncher)
2521 (fun v -> conf.urilauncher <- v);
2522 src#string "path launcher"
2523 (fun () -> conf.pathlauncher)
2524 (fun v -> conf.pathlauncher <- v);
2525 src#string "tile size"
2526 (fun () -> Printf.sprintf "%dx%d" conf.tilew conf.tileh)
2527 (fun v ->
2529 let w, h = Scanf.sscanf v "%dx%d" (fun w h -> w, h) in
2530 conf.tilew <- max 64 w;
2531 conf.tileh <- max 64 h;
2532 flushtiles ();
2533 with exn ->
2534 state.text <- Printf.sprintf "bad tile size `%s': %s"
2535 v @@ exntos exn
2537 src#int "texture count"
2538 (fun () -> conf.texcount)
2539 (fun v ->
2540 if realloctexts v
2541 then conf.texcount <- v
2542 else impmsg "failed to set texture count please retry later"
2544 src#int "slice height"
2545 (fun () -> conf.sliceheight)
2546 (fun v ->
2547 conf.sliceheight <- v;
2548 wcmd "sliceh %d" conf.sliceheight;
2550 src#int "anti-aliasing level"
2551 (fun () -> conf.aalevel)
2552 (fun v ->
2553 conf.aalevel <- bound v 0 8;
2554 state.anchor <- getanchor ();
2555 opendoc state.path state.password;
2557 src#string "page scroll scaling factor"
2558 (fun () -> string_of_float conf.pgscale)
2559 (fun v ->
2560 try conf.pgscale <- float_of_string v
2561 with exn ->
2562 state.text <-
2563 Printf.sprintf "bad page scroll scaling factor `%s': %s" v
2564 @@ exntos exn
2566 src#int "ui font size"
2567 (fun () -> fstate.fontsize)
2568 (fun v -> setfontsize (bound v 5 100));
2569 src#int "hint font size"
2570 (fun () -> conf.hfsize)
2571 (fun v -> conf.hfsize <- bound v 5 100);
2572 src#string "trim fuzz"
2573 (fun () -> irect_to_string conf.trimfuzz)
2574 (fun v ->
2576 conf.trimfuzz <- irect_of_string v;
2577 if conf.trimmargins
2578 then settrim true conf.trimfuzz;
2579 with exn ->
2580 state.text <- Printf.sprintf "bad irect `%s': %s" v
2581 @@ exntos exn
2583 src#string "selection command"
2584 (fun () -> conf.selcmd)
2585 (fun v -> conf.selcmd <- v);
2586 src#string "synctex command"
2587 (fun () -> conf.stcmd)
2588 (fun v -> conf.stcmd <- v);
2589 src#string "pax command"
2590 (fun () -> conf.paxcmd)
2591 (fun v -> conf.paxcmd <- v);
2592 src#string "ask password command"
2593 (fun () -> conf.passcmd)
2594 (fun v -> conf.passcmd <- v);
2595 src#string "save path command"
2596 (fun () -> conf.savecmd)
2597 (fun v -> conf.savecmd <- v);
2598 src#colorspace "color space"
2599 (fun () -> CSTE.to_string conf.colorspace)
2600 (fun v ->
2601 conf.colorspace <- CSTE.of_int v;
2602 wcmd "cs %d" v;
2603 load state.layout;
2605 src#paxmark "pax mark method"
2606 (fun () -> MTE.to_string conf.paxmark)
2607 (fun v -> conf.paxmark <- MTE.of_int v);
2608 if bousable ()
2609 then
2610 src#bool "use PBO"
2611 (fun () -> conf.usepbo)
2612 (fun v -> conf.usepbo <- v);
2613 src#bool "mouse wheel scrolls pages"
2614 (fun () -> conf.wheelbypage)
2615 (fun v -> conf.wheelbypage <- v);
2616 src#bool "open remote links in a new instance"
2617 (fun () -> conf.riani)
2618 (fun v -> conf.riani <- v);
2619 src#bool "edit annotations inline"
2620 (fun () -> conf.annotinline)
2621 (fun v -> conf.annotinline <- v);
2622 src#bool "coarse positioning in presentation mode"
2623 (fun () -> conf.coarseprespos)
2624 (fun v -> conf.coarseprespos <- v);
2625 src#bool "use document CSS"
2626 (fun () -> conf.usedoccss)
2627 (fun v ->
2628 conf.usedoccss <- v;
2629 state.anchor <- getanchor ();
2630 opendoc state.path state.password;
2632 src#bool ~btos "colors"
2633 (fun () -> !showcolors)
2634 (fun v -> showcolors := v; fillsrc prevmode prevuioh);
2635 if !showcolors
2636 then (
2637 colorp " background"
2638 (fun () -> conf.bgcolor)
2639 (fun v -> conf.bgcolor <- v);
2640 rgba " scrollbar"
2641 (fun () -> conf.sbarcolor)
2642 (fun v -> conf.sbarcolor <- v);
2643 rgba " scrollbar handle"
2644 (fun () -> conf.sbarhndlcolor)
2645 (fun v -> conf.sbarhndlcolor <- v);
2649 sep ();
2650 src#caption "Document" 0;
2651 List.iter (fun (_, s) -> src#caption s 1) state.docinfo;
2652 src#caption2 "Pages"
2653 (fun () -> string_of_int state.pagecount) 1;
2654 src#caption2 "Dimensions"
2655 (fun () -> string_of_int (List.length state.pdims)) 1;
2656 if nonemptystr conf.css
2657 then src#caption2 "CSS" (fun () -> conf.css) 1;
2658 if conf.trimmargins
2659 then (
2660 sep ();
2661 src#caption "Trimmed margins" 0;
2662 src#caption2 "Dimensions"
2663 (fun () -> string_of_int (List.length state.pdims)) 1;
2666 sep ();
2667 src#caption "OpenGL" 0;
2668 src#caption (Printf.sprintf "Vendor\t%s" (GlMisc.get_string `vendor)) 1;
2669 src#caption (Printf.sprintf "Renderer\t%s" (GlMisc.get_string `renderer)) 1;
2671 sep ();
2672 src#caption "Location" 0;
2673 if nonemptystr state.origin
2674 then src#caption ("Orign\t" ^ mbtoutf8 state.origin) 1;
2675 src#caption ("Path\t" ^ mbtoutf8 state.path) 1;
2677 src#reset prevmode prevuioh;
2679 fun () ->
2680 state.text <- E.s;
2681 resetmstate ();
2682 let prevmode = state.mode
2683 and prevuioh = state.uioh in
2684 fillsrc prevmode prevuioh;
2685 let source = (src :> lvsource) in
2686 let modehash = findkeyhash conf "info" in
2687 state.uioh <-
2688 coe (object (self)
2689 inherit listview ~zebra:false ~helpmode:false
2690 ~source ~trusted:true ~modehash as super
2691 val mutable m_prevmemused = 0
2692 method! infochanged = function
2693 | Memused ->
2694 if m_prevmemused != state.memused
2695 then (
2696 m_prevmemused <- state.memused;
2697 postRedisplay "memusedchanged";
2699 | Pdim -> postRedisplay "pdimchanged"
2700 | Docinfo -> fillsrc prevmode prevuioh
2702 method! key key mask =
2703 if not (Wsi.withctrl mask)
2704 then
2705 match [@warning "-4"] Wsi.kc2kt key with
2706 | Keys.Left -> coe (self#updownlevel ~-1)
2707 | Keys.Right -> coe (self#updownlevel 1)
2708 | _ -> super#key key mask
2709 else super#key key mask
2710 end);
2711 postRedisplay "info";
2714 let enterhelpmode =
2715 let source =
2716 (object
2717 inherit lvsourcebase
2718 method getitemcount = Array.length state.help
2719 method getitem n =
2720 let s, l, _ = state.help.(n) in
2721 (s, l)
2723 method exit ~uioh ~cancel ~active ~first ~pan =
2724 let optuioh =
2725 if not cancel
2726 then (
2727 match state.help.(active) with
2728 | _, _, Action f -> Some (f uioh)
2729 | _, _, Noaction -> Some uioh
2731 else None
2733 m_active <- active;
2734 m_first <- first;
2735 m_pan <- pan;
2736 optuioh
2738 method hasaction n =
2739 match state.help.(n) with
2740 | _, _, Action _ -> true
2741 | _, _, Noaction -> false
2743 initializer
2744 m_active <- -1
2745 end)
2746 in fun () ->
2747 let modehash = findkeyhash conf "help" in
2748 resetmstate ();
2749 state.uioh <- coe (new listview
2750 ~zebra:false ~helpmode:true
2751 ~source ~trusted:true ~modehash);
2752 postRedisplay "help";
2755 let entermsgsmode =
2756 let msgsource =
2757 (object
2758 inherit lvsourcebase
2759 val mutable m_items = E.a
2761 method getitemcount = 1 + Array.length m_items
2763 method getitem n =
2764 if n = 0
2765 then "[Clear]", 0
2766 else m_items.(n-1), 0
2768 method exit ~uioh ~cancel ~active ~first ~pan =
2769 ignore uioh;
2770 if not cancel
2771 then (
2772 if active = 0
2773 then Buffer.clear state.errmsgs;
2775 m_active <- active;
2776 m_first <- first;
2777 m_pan <- pan;
2778 None
2780 method hasaction n =
2781 n = 0
2783 method reset =
2784 state.newerrmsgs <- false;
2785 let l = Str.split Utils.Re.crlf (Buffer.contents state.errmsgs) in
2786 m_items <- Array.of_list l
2788 initializer
2789 m_active <- 0
2790 end)
2791 in fun () ->
2792 state.text <- E.s;
2793 resetmstate ();
2794 msgsource#reset;
2795 let source = (msgsource :> lvsource) in
2796 let modehash = findkeyhash conf "listview" in
2797 state.uioh <-
2798 coe (object
2799 inherit listview ~zebra:false ~helpmode:false
2800 ~source ~trusted:false ~modehash as super
2801 method! display =
2802 if state.newerrmsgs
2803 then msgsource#reset;
2804 super#display
2805 end);
2806 postRedisplay "msgs";
2809 let getusertext s =
2810 let editor = getenvwithdef "EDITOR" E.s in
2811 if emptystr editor
2812 then E.s
2813 else
2814 let tmppath = Filename.temp_file "llpp" "note" in
2815 if nonemptystr s
2816 then (
2817 let oc = open_out tmppath in
2818 output_string oc s;
2819 close_out oc;
2821 let execstr = editor ^ " " ^ tmppath in
2822 let s =
2823 match spawn execstr [] with
2824 | exception exn ->
2825 impmsg "spawn(%S) failed: %s" execstr @@ exntos exn;
2827 | pid ->
2828 match Unix.waitpid [] pid with
2829 | exception exn ->
2830 impmsg "waitpid(%d) failed: %s" pid @@ exntos exn;
2832 | (_pid, status) ->
2833 match status with
2834 | Unix.WEXITED 0 -> filecontents tmppath
2835 | Unix.WEXITED n ->
2836 impmsg "editor process(%s) exited abnormally: %d" execstr n;
2838 | Unix.WSIGNALED n ->
2839 impmsg "editor process(%s) was killed by signal %d" execstr n;
2841 | Unix.WSTOPPED n ->
2842 impmsg "editor(%s) process was stopped by signal %d" execstr n;
2845 match Unix.unlink tmppath with
2846 | exception exn ->
2847 impmsg "failed to ulink %S: %s" tmppath @@ exntos exn;
2849 | () -> s
2852 let enterannotmode opaque slinkindex =
2853 let msgsource =
2854 (object
2855 inherit lvsourcebase
2856 val mutable m_text = E.s
2857 val mutable m_items = E.a
2859 method getitemcount = Array.length m_items
2861 method getitem n =
2862 let label, _func = m_items.(n) in
2863 label, 0
2865 method exit ~uioh ~cancel ~active ~first ~pan =
2866 ignore (uioh, first, pan);
2867 if not cancel
2868 then (
2869 let _label, func = m_items.(active) in
2870 func ()
2872 None
2874 method hasaction n = nonemptystr @@ fst m_items.(n)
2876 method reset s =
2877 let rec split accu b i =
2878 let p = b+i in
2879 if p = String.length s
2880 then (String.sub s b (p-b), unit) :: accu
2881 else
2882 if (i > 70 && s.[p] = ' ') || s.[p] = '\r' || s.[p] = '\n'
2883 then
2884 let ss = if i = 0 then E.s else String.sub s b i in
2885 split ((ss, unit)::accu) (p+1) 0
2886 else split accu b (i+1)
2888 let cleanup () =
2889 wcmd "freepage %s" (~> opaque);
2890 let keys =
2891 Hashtbl.fold (fun key opaque' accu ->
2892 if opaque' = opaque'
2893 then key :: accu else accu) state.pagemap []
2895 List.iter (Hashtbl.remove state.pagemap) keys;
2896 flushtiles ();
2897 gotoxy state.x state.y
2899 let dele () =
2900 delannot opaque slinkindex;
2901 cleanup ();
2903 let edit inline () =
2904 let update s =
2905 if emptystr s
2906 then dele ()
2907 else (
2908 modannot opaque slinkindex s;
2909 cleanup ();
2912 if inline
2913 then
2914 let mode = state.mode in
2915 state.mode <-
2916 Textentry (
2917 ("annotation: ", m_text, None, textentry, update, true),
2918 fun _ -> state.mode <- mode
2920 state.text <- E.s;
2921 enttext ();
2922 else
2923 let s = getusertext m_text in
2924 update s
2926 m_text <- s;
2927 m_items <-
2928 ( "[Copy]", fun () -> selstring conf.selcmd m_text)
2929 :: ("[Delete]", dele)
2930 :: ("[Edit]", edit conf.annotinline)
2931 :: (E.s, unit)
2932 :: split [] 0 0 |> List.rev |> Array.of_list
2934 initializer
2935 m_active <- 0
2936 end)
2938 state.text <- E.s;
2939 let s = getannotcontents opaque slinkindex in
2940 resetmstate ();
2941 msgsource#reset s;
2942 let source = (msgsource :> lvsource) in
2943 let modehash = findkeyhash conf "listview" in
2944 state.uioh <- coe (object
2945 inherit listview ~zebra:false ~helpmode:false
2946 ~source ~trusted:false ~modehash
2947 end);
2948 postRedisplay "enterannotmode";
2951 let gotoremote spec =
2952 let filename, dest = splitatchar spec '#' in
2953 let getpath filename =
2954 let path =
2955 if nonemptystr filename
2956 then
2957 if Filename.is_relative filename
2958 then
2959 let dir = Filename.dirname state.path in
2960 let dir =
2961 if Filename.is_implicit dir
2962 then Filename.concat (Sys.getcwd ()) dir
2963 else dir
2965 Filename.concat dir filename
2966 else filename
2967 else E.s
2969 if Sys.file_exists path
2970 then path
2971 else E.s
2973 let path = getpath filename in
2974 let dospawn lcmd =
2975 if conf.riani
2976 then
2977 let cmd = Lazy.force_val lcmd in
2978 match spawn cmd with
2979 | _pid -> ()
2980 | exception exn -> dolog "failed to execute `%s': %s" cmd @@ exntos exn
2981 else
2982 let anchor = getanchor () in
2983 let ranchor = state.path, state.password, anchor, state.origin in
2984 state.origin <- E.s;
2985 state.ranchors <- ranchor :: state.ranchors;
2986 opendoc path E.s;
2988 if substratis spec 0 "page="
2989 then
2990 match Scanf.sscanf spec "page=%d" (fun n -> n) with
2991 | pageno ->
2992 state.anchor <- (pageno, 0.0, 0.0);
2993 dospawn @@ lazy (Printf.sprintf "%s -page %d %S" !selfexec pageno path);
2994 | exception exn ->
2995 adderrfmt "error parsing remote destination" "page: %s" @@ exntos exn
2996 else (
2997 state.nameddest <- dest;
2998 dospawn @@ lazy (!selfexec ^ " " ^ path ^ " -dest " ^ dest)
3002 let gotounder = function
3003 | Ulinkuri s when isexternallink s ->
3004 if substratis s 0 "file://"
3005 then gotoremote @@ String.sub s 7 (String.length s - 7)
3006 else Help.gotouri conf.urilauncher s
3007 | Ulinkuri s ->
3008 let pageno, x, y = uritolocation s in
3009 addnav ();
3010 gotopagexy pageno x y
3011 | Utext _ | Unone -> ()
3012 | Uannotation (opaque, slinkindex) -> enterannotmode opaque slinkindex
3015 let gotooutline (_, _, kind) =
3016 match kind with
3017 | Onone -> ()
3018 | Oanchor anchor ->
3019 let (pageno, y, _) = anchor in
3020 let y = getanchory
3021 (if conf.presentation then (pageno, y, 1.0) else anchor)
3023 addnav ();
3024 gotoxy state.x y
3025 | Ouri uri -> gotounder (Ulinkuri uri)
3026 | Olaunch cmd -> error "gotounder (Ulaunch %S)" cmd
3027 | Oremote (remote, pageno) ->
3028 error "gotounder (Uremote (%S,%d) )" remote pageno
3029 | Ohistory hist -> gotohist hist
3030 | Oremotedest (path, dest) ->
3031 error "gotounder (Uremotedest (%S, %S))" path dest
3034 class outlinesoucebase fetchoutlines = object (self)
3035 inherit lvsourcebase
3036 val mutable m_items = E.a
3037 val mutable m_minfo = E.a
3038 val mutable m_orig_items = E.a
3039 val mutable m_orig_minfo = E.a
3040 val mutable m_narrow_patterns = []
3041 val mutable m_gen = -1
3043 method getitemcount = Array.length m_items
3045 method getitem n =
3046 let s, n, _ = m_items.(n) in
3047 (s, n+0)
3049 method exit ~(uioh:uioh) ~cancel ~active ~(first:int) ~pan : uioh option =
3050 ignore (uioh, first);
3051 let items, minfo =
3052 if m_narrow_patterns = []
3053 then m_orig_items, m_orig_minfo
3054 else m_items, m_minfo
3056 m_pan <- pan;
3057 if not cancel
3058 then (
3059 m_items <- items;
3060 m_minfo <- minfo;
3061 gotooutline m_items.(active);
3063 else (
3064 m_items <- items;
3065 m_minfo <- minfo;
3067 None
3069 method hasaction (_:int) = true
3071 method greetmsg =
3072 if Array.length m_items != Array.length m_orig_items
3073 then
3074 let s =
3075 match m_narrow_patterns with
3076 | one :: [] -> one
3077 | many -> String.concat Utf8syms.ellipsis (List.rev many)
3079 "Narrowed to " ^ s ^ " (ctrl-u to restore)"
3080 else E.s
3082 method statestr =
3083 match m_narrow_patterns with
3084 | [] -> E.s
3085 | one :: [] -> one
3086 | head :: _ -> Utf8syms.ellipsis ^ head
3088 method narrow pattern =
3089 match Str.regexp_case_fold pattern with
3090 | exception _ -> ()
3091 | re ->
3092 let rec loop accu minfo n =
3093 if n = -1
3094 then (
3095 m_items <- Array.of_list accu;
3096 m_minfo <- Array.of_list minfo;
3098 else
3099 let (s, _, _) as o = m_items.(n) in
3100 let accu, minfo =
3101 match Str.search_forward re s 0 with
3102 | exception Not_found -> accu, minfo
3103 | first -> o :: accu, (first, Str.match_end ()) :: minfo
3105 loop accu minfo (n-1)
3107 loop [] [] (Array.length m_items - 1)
3109 method! getminfo = m_minfo
3111 method denarrow =
3112 m_orig_items <- fetchoutlines ();
3113 m_minfo <- m_orig_minfo;
3114 m_items <- m_orig_items
3116 method add_narrow_pattern pattern =
3117 m_narrow_patterns <- pattern :: m_narrow_patterns
3119 method del_narrow_pattern =
3120 match m_narrow_patterns with
3121 | _ :: rest -> m_narrow_patterns <- rest
3122 | [] -> ()
3124 method renarrow =
3125 self#denarrow;
3126 match m_narrow_patterns with
3127 | pattern :: [] -> self#narrow pattern; pattern
3128 | list ->
3129 List.fold_left (fun accu pattern ->
3130 self#narrow pattern;
3131 pattern ^ Utf8syms.ellipsis ^ accu) E.s list
3133 method calcactive (_:anchor) = 0
3135 method reset anchor items =
3136 if state.gen != m_gen
3137 then (
3138 m_orig_items <- items;
3139 m_items <- items;
3140 m_narrow_patterns <- [];
3141 m_minfo <- E.a;
3142 m_orig_minfo <- E.a;
3143 m_gen <- state.gen;
3145 else (
3146 if items != m_orig_items
3147 then (
3148 m_orig_items <- items;
3149 if m_narrow_patterns == []
3150 then m_items <- items;
3153 let active = self#calcactive anchor in
3154 m_active <- active;
3155 m_first <- firstof m_first active
3159 let outlinesource fetchoutlines =
3160 (object
3161 inherit outlinesoucebase fetchoutlines
3162 method! calcactive anchor =
3163 let rely = getanchory anchor in
3164 let rec loop n best bestd =
3165 if n = Array.length m_items
3166 then best
3167 else
3168 let _, _, kind = m_items.(n) in
3169 match kind with
3170 | Oanchor anchor ->
3171 let orely = getanchory anchor in
3172 let d = abs (orely - rely) in
3173 if d < bestd
3174 then loop (n+1) n d
3175 else loop (n+1) best bestd
3176 | Onone | Oremote _ | Olaunch _
3177 | Oremotedest _ | Ouri _ | Ohistory _ ->
3178 loop (n+1) best bestd
3180 loop 0 ~-1 max_int
3181 end)
3184 let enteroutlinemode, enterbookmarkmode, enterhistmode =
3185 let mkselector sourcetype =
3186 let fetchoutlines () =
3187 match sourcetype with
3188 | `bookmarks -> Array.of_list state.bookmarks
3189 | `outlines -> state.outlines
3190 | `history -> genhistoutlines () |> Array.of_list
3192 let source =
3193 if sourcetype = `history
3194 then new outlinesoucebase fetchoutlines
3195 else outlinesource fetchoutlines
3197 (fun errmsg ->
3198 let outlines = fetchoutlines () in
3199 if Array.length outlines = 0
3200 then showtext ' ' errmsg
3201 else (
3202 resetmstate ();
3203 Wsi.setcursor Wsi.CURSOR_INHERIT;
3204 let anchor = getanchor () in
3205 source#reset anchor outlines;
3206 state.text <- source#greetmsg;
3207 state.uioh <-
3208 coe (new outlinelistview ~zebra:(sourcetype=`history) ~source);
3209 postRedisplay "enter selector";
3213 let mkenter sourcetype errmsg = fun () -> mkselector sourcetype errmsg in
3214 ( mkenter `outlines "document has no outline"
3215 , mkenter `bookmarks "document has no bookmarks (yet)"
3216 , mkenter `history "history is empty" )
3219 let quickbookmark ?title () =
3220 match state.layout with
3221 | [] -> ()
3222 | l :: _ ->
3223 let title =
3224 match title with
3225 | None ->
3226 Unix.(
3227 let tm = localtime (now ()) in
3228 Printf.sprintf
3229 "Quick (page %d) (bookmarked on %02d/%02d/%d at %02d:%02d)"
3230 (l.pageno+1)
3231 tm.tm_mday (tm.tm_mon+1) (tm.tm_year+1900) tm.tm_hour tm.tm_min
3233 | Some title -> title
3235 state.bookmarks <- (title, 0, Oanchor (getanchor1 l)) :: state.bookmarks
3238 let setautoscrollspeed step goingdown =
3239 let incr = max 1 ((abs step) / 2) in
3240 let incr = if goingdown then incr else -incr in
3241 let astep = boundastep state.winh (step + incr) in
3242 state.autoscroll <- Some astep;
3245 let canpan () =
3246 match conf.columns with
3247 | Csplit _ -> true
3248 | Csingle _ | Cmulti _ -> state.x != 0 || conf.zoom > 1.0
3251 let panbound x = bound x (-state.w) state.winw;;
3253 let existsinrow pageno (columns, coverA, coverB) p =
3254 let last = ((pageno - coverA) mod columns) + columns in
3255 let rec any = function
3256 | [] -> false
3257 | l :: rest ->
3258 if l.pageno = coverA - 1 || l.pageno = state.pagecount - coverB
3259 then p l
3260 else (
3261 if not (p l)
3262 then (if l.pageno = last then false else any rest)
3263 else true
3266 any state.layout
3269 let nextpage () =
3270 match state.layout with
3271 | [] ->
3272 let pageno = page_of_y state.y in
3273 gotoxy state.x (getpagey (pageno+1))
3274 | l :: rest ->
3275 match conf.columns with
3276 | Csingle _ ->
3277 if conf.presentation && rest == [] && l.pageh > l.pagey + l.pagevh
3278 then
3279 let y = clamp (pgscale state.winh) in
3280 gotoxy state.x y
3281 else
3282 let pageno = min (l.pageno+1) (state.pagecount-1) in
3283 gotoxy state.x (getpagey pageno)
3284 | Cmulti ((c, _, _) as cl, _) ->
3285 if conf.presentation
3286 && (existsinrow l.pageno cl
3287 (fun l -> l.pageh > l.pagey + l.pagevh))
3288 then
3289 let y = clamp (pgscale state.winh) in
3290 gotoxy state.x y
3291 else
3292 let pageno = min (l.pageno+c) (state.pagecount-1) in
3293 gotoxy state.x (getpagey pageno)
3294 | Csplit (n, _) ->
3295 if l.pageno < state.pagecount - 1 || l.pagecol < n - 1
3296 then
3297 let pagey, pageh = getpageyh l.pageno in
3298 let pagey = pagey + pageh * l.pagecol in
3299 let ips = if l.pagecol = 0 then 0 else conf.interpagespace in
3300 gotoxy state.x (pagey + pageh + ips)
3303 let prevpage () =
3304 match state.layout with
3305 | [] ->
3306 let pageno = page_of_y state.y in
3307 gotoxy state.x (getpagey (pageno-1))
3308 | l :: _ ->
3309 match conf.columns with
3310 | Csingle _ ->
3311 if conf.presentation && l.pagey != 0
3312 then
3313 gotoxy state.x (clamp (pgscale ~-(state.winh)))
3314 else
3315 let pageno = max 0 (l.pageno-1) in
3316 gotoxy state.x (getpagey pageno)
3317 | Cmulti ((c, _, coverB) as cl, _) ->
3318 if conf.presentation &&
3319 (existsinrow l.pageno cl (fun l -> l.pagey != 0))
3320 then
3321 gotoxy state.x (clamp (pgscale ~-(state.winh)))
3322 else
3323 let decr =
3324 if l.pageno = state.pagecount - coverB
3325 then 1
3326 else c
3328 let pageno = max 0 (l.pageno-decr) in
3329 gotoxy state.x (getpagey pageno)
3330 | Csplit (n, _) ->
3331 let y =
3332 if l.pagecol = 0
3333 then
3334 if l.pageno = 0
3335 then l.pagey
3336 else
3337 let pageno = max 0 (l.pageno-1) in
3338 let pagey, pageh = getpageyh pageno in
3339 pagey + (n-1)*pageh
3340 else
3341 let pagey, pageh = getpageyh l.pageno in
3342 pagey + pageh * (l.pagecol-1) - conf.interpagespace
3344 gotoxy state.x y
3347 let save () =
3348 if emptystr conf.savecmd
3349 then adderrmsg "savepath-command is empty"
3350 "don't know where to save modified document"
3351 else
3352 let savecmd = Str.global_replace Utils.Re.percent state.path conf.savecmd in
3353 let path =
3354 getcmdoutput
3355 (fun exn ->
3356 adderrfmt savecmd "failed to produce path to the saved copy: %s" exn)
3357 savecmd
3359 if nonemptystr path
3360 then
3361 let tmp = path ^ ".tmp" in
3362 savedoc tmp;
3363 Unix.rename tmp path;
3366 let viewkeyboard key mask =
3367 let enttext te =
3368 let mode = state.mode in
3369 state.mode <- Textentry (te, fun _ -> state.mode <- mode);
3370 state.text <- E.s;
3371 enttext ();
3372 postRedisplay "view:enttext"
3374 let ctrl = Wsi.withctrl mask in
3375 let open Keys in
3376 match Wsi.kc2kt key with
3377 | Ascii 'S' -> state.slideshow <- state.slideshow lxor 1
3379 | Ascii 'Q' -> exit 0
3381 | Ascii 'W' ->
3382 if hasunsavedchanges ()
3383 then save ()
3385 | Insert ->
3386 if conf.angle mod 360 = 0 && not (isbirdseye state.mode)
3387 then (
3388 state.mode <- (
3389 match state.lnava with
3390 | None -> LinkNav (Ltgendir 0)
3391 | Some pn -> LinkNav (Ltexact pn)
3393 gotoxy state.x state.y;
3395 else impmsg "keyboard link navigation does not work under rotation"
3397 | Escape | Ascii 'q' ->
3398 begin match state.mstate with
3399 | Mzoomrect _ ->
3400 resetmstate ();
3401 postRedisplay "kill rect";
3402 | Msel _
3403 | Mpan _
3404 | Mscrolly | Mscrollx
3405 | Mzoom _
3406 | Mnone ->
3407 begin match state.mode with
3408 | LinkNav ln ->
3409 begin match ln with
3410 | Ltexact pl -> state.lnava <- Some pl
3411 | Ltgendir _ | Ltnotready _ -> state.lnava <- None
3412 end;
3413 state.mode <- View;
3414 postRedisplay "esc leave linknav"
3415 | Birdseye _ | Textentry _ | View ->
3416 match state.ranchors with
3417 | [] -> raise Quit
3418 | (path, password, anchor, origin) :: rest ->
3419 state.ranchors <- rest;
3420 state.anchor <- anchor;
3421 state.origin <- origin;
3422 state.nameddest <- E.s;
3423 opendoc path password
3424 end;
3425 end;
3427 | Backspace ->
3428 addnavnorc ();
3429 gotoxy state.x (getnav ~-1)
3431 | Ascii 'o' ->
3432 enteroutlinemode ()
3434 | Ascii 'H' ->
3435 enterhistmode ()
3437 | Ascii 'u' ->
3438 state.rects <- [];
3439 state.text <- E.s;
3440 Hashtbl.iter (fun _ opaque ->
3441 clearmark opaque;
3442 Hashtbl.clear state.prects) state.pagemap;
3443 postRedisplay "dehighlight";
3445 | Ascii (('/' | '?') as c) ->
3446 let ondone isforw s =
3447 cbput state.hists.pat s;
3448 state.searchpattern <- s;
3449 search s isforw
3451 let s = String.make 1 c in
3452 enttext (s, E.s, Some (onhist state.hists.pat),
3453 textentry, ondone (c = '/'), true)
3455 | Ascii '+' | Ascii '=' when ctrl ->
3456 let incr = if conf.zoom +. 0.01 > 0.1 then 0.1 else 0.01 in
3457 pivotzoom (conf.zoom +. incr)
3459 | Ascii '+' ->
3460 let ondone s =
3461 let n =
3462 try int_of_string s with exn ->
3463 state.text <-
3464 Printf.sprintf "bad integer `%s': %s" s @@ exntos exn;
3465 max_int
3467 if n != max_int
3468 then (
3469 conf.pagebias <- n;
3470 state.text <- "page bias is now " ^ string_of_int n;
3473 enttext ("page bias: ", E.s, None, intentry, ondone, true)
3475 | Ascii '-' when ctrl ->
3476 let decr = if conf.zoom -. 0.1 < 0.1 then 0.01 else 0.1 in
3477 pivotzoom (max 0.01 (conf.zoom -. decr))
3479 | Ascii '-' ->
3480 let ondone msg = state.text <- msg in
3481 enttext ("option: ", E.s, None,
3482 optentry state.mode, ondone, true)
3484 | Ascii '0' when ctrl ->
3485 if conf.zoom = 1.0
3486 then gotoxy 0 state.y
3487 else setzoom 1.0
3489 | Ascii ('1'|'2' as c) when ctrl && conf.fitmodel != FitPage ->
3490 let cols =
3491 match conf.columns with
3492 | Csingle _ | Cmulti _ -> 1
3493 | Csplit (n, _) -> n
3495 let h = state.winh -
3496 conf.interpagespace lsl (if conf.presentation then 1 else 0)
3498 let zoom = zoomforh state.winw h 0 cols in
3499 if zoom > 0.0 && (c = '2' || zoom < 1.0)
3500 then setzoom zoom
3502 | Ascii '3' when ctrl ->
3503 let fm =
3504 match conf.fitmodel with
3505 | FitWidth -> FitProportional
3506 | FitProportional -> FitPage
3507 | FitPage -> FitWidth
3509 state.text <- "fit model: " ^ FMTE.to_string fm;
3510 reqlayout conf.angle fm
3512 | Ascii '4' when ctrl ->
3513 let zoom = getmaxw () /. float state.winw in
3514 if zoom > 0.0 then setzoom zoom
3516 | Fn 9 | Ascii '9' when ctrl -> togglebirdseye ()
3518 | Ascii ('0'..'9' as c) when not ctrl ->
3519 let ondone s =
3520 let n =
3521 try int_of_string s with exn ->
3522 state.text <- Printf.sprintf "bad integer `%s': %s" s @@ exntos exn;
3525 if n >= 0
3526 then (
3527 addnav ();
3528 cbput state.hists.pag (string_of_int n);
3529 gotopage1 (n + conf.pagebias - 1) 0;
3532 let pageentry text = function [@warning "-4"]
3533 | Keys.Ascii 'g' -> TEdone text
3534 | key -> intentry text key
3536 let text = String.make 1 c in
3537 enttext (":", text, Some (onhist state.hists.pag),
3538 pageentry, ondone, true)
3540 | Ascii 'b' ->
3541 conf.scrollb <- if conf.scrollb = 0 then (scrollbvv lor scrollbhv) else 0;
3542 postRedisplay "toggle scrollbar";
3544 | Ascii 'B' ->
3545 state.bzoom <- not state.bzoom;
3546 state.rects <- [];
3547 showtext ' ' ("block zoom " ^ if state.bzoom then "on" else "off")
3549 | Ascii 'l' ->
3550 conf.hlinks <- not conf.hlinks;
3551 state.text <- "highlightlinks " ^ if conf.hlinks then "on" else "off";
3552 postRedisplay "toggle highlightlinks";
3554 | Ascii 'F' ->
3555 if conf.angle mod 360 = 0
3556 then (
3557 state.glinks <- true;
3558 let mode = state.mode in
3559 state.mode <-
3560 Textentry (
3561 (":", E.s, None, linknentry, linknact gotounder, false),
3562 (fun _ ->
3563 state.glinks <- false;
3564 state.mode <- mode)
3566 state.text <- E.s;
3567 postRedisplay "view:linkent(F)"
3569 else impmsg "hint mode does not work under rotation"
3571 | Ascii 'y' ->
3572 state.glinks <- true;
3573 let mode = state.mode in
3574 state.mode <-
3575 Textentry (
3576 (":", E.s, None, linknentry,
3577 linknact (fun under ->
3578 selstring conf.selcmd (undertext under)), false),
3579 (fun _ ->
3580 state.glinks <- false;
3581 state.mode <- mode)
3583 state.text <- E.s;
3584 postRedisplay "view:linkent"
3586 | Ascii 'a' ->
3587 begin match state.autoscroll with
3588 | Some step ->
3589 conf.autoscrollstep <- step;
3590 state.autoscroll <- None
3591 | None ->
3592 state.autoscroll <- Some conf.autoscrollstep;
3593 state.slideshow <- state.slideshow land lnot 2
3596 | Ascii 'p' when ctrl ->
3597 launchpath () (* XXX where do error messages go? *)
3599 | Ascii 'P' ->
3600 setpresentationmode (not conf.presentation);
3601 showtext ' ' ("presentation mode " ^
3602 if conf.presentation then "on" else "off");
3604 | Ascii 'f' ->
3605 if List.mem Wsi.Fullscreen state.winstate
3606 then Wsi.reshape conf.cwinw conf.cwinh
3607 else Wsi.fullscreen ()
3609 | Ascii ('p'|'N') ->
3610 search state.searchpattern false
3612 | Ascii 'n' | Fn 3 ->
3613 search state.searchpattern true
3615 | Ascii 't' ->
3616 begin match state.layout with
3617 | [] -> ()
3618 | l :: _ -> gotoxy state.x (getpagey l.pageno)
3621 | Ascii ' ' -> nextpage ()
3622 | Delete -> prevpage ()
3623 | Ascii '=' -> showtext ' ' (describe_layout state.layout);
3625 | Ascii 'w' ->
3626 begin match state.layout with
3627 | [] -> ()
3628 | l :: _ ->
3629 Wsi.reshape l.pagew l.pageh;
3630 postRedisplay "w"
3633 | Ascii '\'' -> enterbookmarkmode ()
3634 | Ascii 'h' | Fn 1 -> enterhelpmode ()
3635 | Ascii 'i' -> enterinfomode ()
3636 | Ascii 'e' when Buffer.length state.errmsgs > 0 -> entermsgsmode ()
3638 | Ascii 'm' ->
3639 let ondone s =
3640 match state.layout with
3641 | l :: _ when nonemptystr s ->
3642 state.bookmarks <- (s, 0, Oanchor (getanchor1 l)) :: state.bookmarks
3643 | _ -> ()
3645 enttext ("bookmark: ", E.s, None, textentry, ondone, true)
3647 | Ascii '~' ->
3648 quickbookmark ();
3649 showtext ' ' "Quick bookmark added";
3651 | Ascii 'x' -> state.roam ()
3653 | Ascii ('<'|'>' as c) ->
3654 reqlayout (conf.angle + (if c = '>' then 30 else -30)) conf.fitmodel
3656 | Ascii ('['|']' as c) ->
3657 conf.colorscale <-
3658 bound (conf.colorscale +. (if c = ']' then 0.1 else -0.1)) 0.0 1.0;
3659 postRedisplay "brightness";
3661 | Ascii 'c' when state.mode = View ->
3662 if Wsi.withalt mask
3663 then (
3664 if conf.zoom > 1.0
3665 then
3666 let m = (state.winw - state.w) / 2 in
3667 gotoxy m state.y
3669 else
3670 let (c, a, b), z =
3671 match state.prevcolumns with
3672 | None -> (1, 0, 0), 1.0
3673 | Some (columns, z) ->
3674 let cab =
3675 match columns with
3676 | Csplit (c, _) -> -c, 0, 0
3677 | Cmulti ((c, a, b), _) -> c, a, b
3678 | Csingle _ -> 1, 0, 0
3680 cab, z
3682 setcolumns View c a b;
3683 setzoom z
3685 | Down | Up when ctrl && Wsi.withshift mask ->
3686 let zoom, x = state.prevzoom in
3687 setzoom zoom;
3688 state.x <- x;
3690 | Ascii 'k' | Up ->
3691 begin match state.autoscroll with
3692 | None ->
3693 begin match state.mode with
3694 | Birdseye beye -> upbirdseye 1 beye
3695 | Textentry _ | View | LinkNav _ ->
3696 if ctrl
3697 then gotoxy state.x (clamp ~-(state.winh/2))
3698 else (
3699 if not (Wsi.withshift mask) && conf.presentation
3700 then prevpage ()
3701 else gotoxy state.x (clamp (-conf.scrollstep))
3704 | Some n -> setautoscrollspeed n false
3707 | Ascii 'j' | Down ->
3708 begin match state.autoscroll with
3709 | None ->
3710 begin match state.mode with
3711 | Birdseye beye -> downbirdseye 1 beye
3712 | Textentry _ | View | LinkNav _ ->
3713 if ctrl
3714 then gotoxy state.x (clamp (state.winh/2))
3715 else (
3716 if not (Wsi.withshift mask) && conf.presentation
3717 then nextpage ()
3718 else gotoxy state.x (clamp (conf.scrollstep))
3721 | Some n -> setautoscrollspeed n true
3724 | Left | Right when not (Wsi.withalt mask) ->
3725 if canpan ()
3726 then
3727 let dx =
3728 if ctrl
3729 then state.winw / 2
3730 else conf.hscrollstep
3732 let dx =
3733 let pv = Wsi.kc2kt key in
3734 if pv = Keys.Left then dx else -dx
3736 gotoxy (panbound (state.x + dx)) state.y
3737 else (
3738 state.text <- E.s;
3739 postRedisplay "left/right"
3742 | Prior ->
3743 let y =
3744 if ctrl
3745 then
3746 match state.layout with
3747 | [] -> state.y
3748 | l :: _ -> state.y - l.pagey
3749 else clamp (pgscale (-state.winh))
3751 gotoxy state.x y
3753 | Next ->
3754 let y =
3755 if ctrl
3756 then
3757 match List.rev state.layout with
3758 | [] -> state.y
3759 | l :: _ -> getpagey l.pageno
3760 else clamp (pgscale state.winh)
3762 gotoxy state.x y
3764 | Ascii 'g' | Home ->
3765 addnav ();
3766 gotoxy 0 0
3767 | Ascii 'G' | End ->
3768 addnav ();
3769 gotoxy 0 (clamp state.maxy)
3771 | Right when Wsi.withalt mask ->
3772 addnavnorc ();
3773 gotoxy state.x (getnav 1)
3774 | Left when Wsi.withalt mask ->
3775 addnavnorc ();
3776 gotoxy state.x (getnav ~-1)
3778 | Ascii 'r' ->
3779 reload ()
3781 | Ascii 'v' when conf.debug ->
3782 state.rects <- [];
3783 List.iter (fun l ->
3784 match getopaque l.pageno with
3785 | None -> ()
3786 | Some opaque ->
3787 let x0, y0, x1, y1 = pagebbox opaque in
3788 let rect = (float x0, float y0,
3789 float x1, float y0,
3790 float x1, float y1,
3791 float x0, float y1) in
3792 debugrect rect;
3793 let color = (0.0, 0.0, 1.0 /. (l.pageno mod 3 |> float), 0.5) in
3794 state.rects <- (l.pageno, color, rect) :: state.rects;
3795 ) state.layout;
3796 postRedisplay "v";
3798 | Ascii '|' ->
3799 let mode = state.mode in
3800 let cmd = ref E.s in
3801 let onleave = function
3802 | Cancel -> state.mode <- mode
3803 | Confirm ->
3804 List.iter (fun l ->
3805 match getopaque l.pageno with
3806 | Some opaque -> pipesel opaque !cmd
3807 | None -> ()) state.layout;
3808 state.mode <- mode
3810 let ondone s =
3811 cbput state.hists.sel s;
3812 cmd := s
3814 let te =
3815 "| ", !cmd, Some (onhist state.hists.sel), textentry, ondone, true
3817 postRedisplay "|";
3818 state.mode <- Textentry (te, onleave);
3820 | (Ascii _|Fn _|Enter|Left|Right|Code _|Ctrl _) ->
3821 vlog "huh? %s" (Wsi.keyname key)
3824 let linknavkeyboard key mask linknav =
3825 let pv = Wsi.kc2kt key in
3826 let getpage pageno =
3827 let rec loop = function
3828 | [] -> None
3829 | l :: _ when l.pageno = pageno -> Some l
3830 | _ :: rest -> loop rest
3831 in loop state.layout
3833 let doexact (pageno, n) =
3834 match getopaque pageno, getpage pageno with
3835 | Some opaque, Some l ->
3836 if pv = Keys.Enter
3837 then
3838 let under = getlink opaque n in
3839 postRedisplay "link gotounder";
3840 gotounder under;
3841 state.mode <- View;
3842 else
3843 let opt, dir =
3844 let open Keys in
3845 match pv with
3846 | Home -> Some (findlink opaque LDfirst), -1
3847 | End -> Some (findlink opaque LDlast), 1
3848 | Left -> Some (findlink opaque (LDleft n)), -1
3849 | Right -> Some (findlink opaque (LDright n)), 1
3850 | Up -> Some (findlink opaque (LDup n)), -1
3851 | Down -> Some (findlink opaque (LDdown n)), 1
3852 | Delete|Escape|Insert|Enter|Next|Prior|Ascii _
3853 | Code _|Fn _|Ctrl _|Backspace -> None, 0
3855 let pwl l dir =
3856 begin match findpwl l.pageno dir with
3857 | Pwlnotfound -> ()
3858 | Pwl pageno ->
3859 let notfound dir =
3860 state.mode <- LinkNav (Ltgendir dir);
3861 let y, h = getpageyh pageno in
3862 let y =
3863 if dir < 0
3864 then y + h - state.winh
3865 else y
3867 gotoxy state.x y
3869 begin match getopaque pageno, getpage pageno with
3870 | Some opaque, Some _ ->
3871 let link =
3872 let ld = if dir > 0 then LDfirst else LDlast in
3873 findlink opaque ld
3875 begin match link with
3876 | Lfound m ->
3877 showlinktype (getlink opaque m);
3878 state.mode <- LinkNav (Ltexact (pageno, m));
3879 postRedisplay "linknav jpage";
3880 | Lnotfound -> notfound dir
3881 end;
3882 | _ -> notfound dir
3883 end;
3884 end;
3886 begin match opt with
3887 | Some Lnotfound -> pwl l dir;
3888 | Some (Lfound m) ->
3889 if m = n
3890 then pwl l dir
3891 else (
3892 let _, y0, _, y1 = getlinkrect opaque m in
3893 if y0 < l.pagey
3894 then gotopage1 l.pageno y0
3895 else (
3896 let d = fstate.fontsize + 1 in
3897 if y1 - l.pagey > l.pagevh - d
3898 then gotopage1 l.pageno (y1 - state.winh + d)
3899 else postRedisplay "linknav";
3901 showlinktype (getlink opaque m);
3902 state.mode <- LinkNav (Ltexact (l.pageno, m));
3905 | None -> viewkeyboard key mask
3906 end;
3907 | _ -> viewkeyboard key mask
3909 if pv = Keys.Insert
3910 then (
3911 begin match linknav with
3912 | Ltexact pa -> state.lnava <- Some pa
3913 | Ltgendir _ | Ltnotready _ -> ()
3914 end;
3915 state.mode <- View;
3916 postRedisplay "leave linknav"
3918 else
3919 match linknav with
3920 | Ltgendir _ | Ltnotready _ -> viewkeyboard key mask
3921 | Ltexact exact -> doexact exact
3924 let keyboard key mask =
3925 if (key = Char.code 'g' && Wsi.withctrl mask) && not (istextentry state.mode)
3926 then wcmd "interrupt"
3927 else state.uioh <- state.uioh#key key mask
3930 let birdseyekeyboard key mask
3931 ((oconf, leftx, pageno, hooverpageno, anchor) as beye) =
3932 let incr =
3933 match conf.columns with
3934 | Csingle _ -> 1
3935 | Cmulti ((c, _, _), _) -> c
3936 | Csplit _ -> error "bird's eye split mode"
3938 let pgh layout = List.fold_left
3939 (fun m l -> max l.pageh m) state.winh layout in
3940 let open Keys in
3941 match Wsi.kc2kt key with
3942 | Ascii 'l' when Wsi.withctrl mask ->
3943 let y, h = getpageyh pageno in
3944 let top = (state.winh - h) / 2 in
3945 gotoxy state.x (max 0 (y - top))
3946 | Enter -> leavebirdseye beye false
3947 | Escape -> leavebirdseye beye true
3948 | Up -> upbirdseye incr beye
3949 | Down -> downbirdseye incr beye
3950 | Left -> upbirdseye 1 beye
3951 | Right -> downbirdseye 1 beye
3953 | Prior ->
3954 begin match state.layout with
3955 | l :: _ ->
3956 if l.pagey != 0
3957 then (
3958 state.mode <- Birdseye (
3959 oconf, leftx, l.pageno, hooverpageno, anchor
3961 gotopage1 l.pageno 0;
3963 else (
3964 let layout = layout state.x (state.y-state.winh)
3965 state.winw
3966 (pgh state.layout) in
3967 match layout with
3968 | [] -> gotoxy state.x (clamp (-state.winh))
3969 | l :: _ ->
3970 state.mode <- Birdseye (
3971 oconf, leftx, l.pageno, hooverpageno, anchor
3973 gotopage1 l.pageno 0
3976 | [] -> gotoxy state.x (clamp (-state.winh))
3977 end;
3979 | Next ->
3980 begin match List.rev state.layout with
3981 | l :: _ ->
3982 let layout = layout state.x
3983 (state.y + (pgh state.layout))
3984 state.winw state.winh in
3985 begin match layout with
3986 | [] ->
3987 let incr = l.pageh - l.pagevh in
3988 if incr = 0
3989 then (
3990 state.mode <-
3991 Birdseye (
3992 oconf, leftx, state.pagecount - 1, hooverpageno, anchor
3994 postRedisplay "birdseye pagedown";
3996 else gotoxy state.x (clamp (incr + conf.interpagespace*2));
3998 | l :: _ ->
3999 state.mode <-
4000 Birdseye (oconf, leftx, l.pageno, hooverpageno, anchor);
4001 gotopage1 l.pageno 0;
4004 | [] -> gotoxy state.x (clamp state.winh)
4005 end;
4007 | Home ->
4008 state.mode <- Birdseye (oconf, leftx, 0, hooverpageno, anchor);
4009 gotopage1 0 0
4011 | End ->
4012 let pageno = state.pagecount - 1 in
4013 state.mode <- Birdseye (oconf, leftx, pageno, hooverpageno, anchor);
4014 if not (pagevisible state.layout pageno)
4015 then
4016 let h =
4017 match List.rev state.pdims with
4018 | [] -> state.winh
4019 | (_, _, h, _) :: _ -> h
4021 gotoxy
4022 state.x
4023 (max 0 (getpagey pageno - (state.winh - h - conf.interpagespace)))
4024 else postRedisplay "birdseye end";
4026 | Delete|Insert|Ascii _|Code _|Ctrl _|Fn _|Backspace -> viewkeyboard key mask
4029 let drawpage l =
4030 let color =
4031 match state.mode with
4032 | Textentry _ -> scalecolor 0.4
4033 | LinkNav _ | View -> scalecolor 1.0
4034 | Birdseye (_, _, pageno, hooverpageno, _) ->
4035 if l.pageno = hooverpageno
4036 then scalecolor 0.9
4037 else (
4038 if l.pageno = pageno
4039 then (
4040 let c = scalecolor 1.0 in
4041 GlDraw.color c;
4042 GlDraw.line_width 3.0;
4043 let dispx = l.pagedispx in
4044 linerect
4045 (float (dispx-1)) (float (l.pagedispy-1))
4046 (float (dispx+l.pagevw+1))
4047 (float (l.pagedispy+l.pagevh+1));
4048 GlDraw.line_width 1.0;
4051 else scalecolor 0.8
4054 drawtiles l color;
4057 let postdrawpage l linkindexbase =
4058 match getopaque l.pageno with
4059 | Some opaque ->
4060 if tileready l l.pagex l.pagey
4061 then
4062 let x = l.pagedispx - l.pagex
4063 and y = l.pagedispy - l.pagey in
4064 let hlmask =
4065 match conf.columns with
4066 | Csingle _ | Cmulti _ ->
4067 (if conf.hlinks then 1 else 0)
4068 + (if state.glinks
4069 && not (isbirdseye state.mode) then 2 else 0)
4070 | Csplit _ -> 0
4072 let s =
4073 match state.mode with
4074 | Textentry ((_, s, _, _, _, _), _) when state.glinks -> s
4075 | Textentry _
4076 | Birdseye _
4077 | View
4078 | LinkNav _ -> E.s
4080 Hashtbl.find_all state.prects l.pageno |>
4081 List.iter (fun vals -> drawprect opaque x y vals);
4082 let n = postprocess opaque hlmask x y (linkindexbase, s, conf.hfsize) in
4083 if n < 0
4084 then (Glutils.redisplay := true; 0)
4085 else n
4086 else 0
4087 | _ -> 0
4090 let scrollindicator () =
4091 let sbw, ph, sh = state.uioh#scrollph in
4092 let sbh, pw, sw = state.uioh#scrollpw in
4094 let x0,x1,hx0 =
4095 if conf.leftscroll
4096 then (0, sbw, sbw)
4097 else ((state.winw - sbw), state.winw, 0)
4100 Gl.enable `blend;
4101 GlFunc.blend_func ~src:`src_alpha ~dst:`one_minus_src_alpha;
4102 let (r, g, b, alpha) = conf.sbarcolor in
4103 GlDraw.color (r, g, b) ~alpha;
4104 filledrect (float x0) 0. (float x1) (float state.winh);
4105 filledrect
4106 (float hx0) (float (state.winh - sbh))
4107 (float (hx0 + state.winw)) (float state.winh);
4108 let (r, g, b, alpha) = conf.sbarhndlcolor in
4109 GlDraw.color (r, g, b) ~alpha;
4111 filledrect (float x0) ph (float x1) (ph +. sh);
4112 let pw = pw +. float hx0 in
4113 filledrect pw (float (state.winh - sbh)) (pw +. sw) (float state.winh);
4114 Gl.disable `blend;
4117 let showsel () =
4118 match state.mstate with
4119 | Mnone | Mscrolly | Mscrollx | Mpan _ | Mzoom _ | Mzoomrect _ -> ()
4120 | Msel ((x0, y0), (x1, y1)) ->
4121 let identify opaque l px py = Some (opaque, l.pageno, px, py) in
4122 let o0,n0,px0,py0 = onppundermouse identify x0 y0 (~< E.s, -1, 0, 0) in
4123 let _o1,n1,px1,py1 = onppundermouse identify x1 y1 (~< E.s, -1, 0, 0) in
4124 if n0 != -1 && n0 = n1 then seltext o0 (px0, py0, px1, py1);
4127 let showrects = function
4128 | [] -> ()
4129 | rects ->
4130 Gl.enable `blend;
4131 GlDraw.color (0.0, 0.0, 1.0) ~alpha:0.5;
4132 GlFunc.blend_func ~src:`src_alpha ~dst:`one_minus_src_alpha;
4133 List.iter
4134 (fun (pageno, c, (x0, y0, x1, y1, x2, y2, x3, y3)) ->
4135 List.iter (fun l ->
4136 if l.pageno = pageno
4137 then (
4138 let dx = float (l.pagedispx - l.pagex) in
4139 let dy = float (l.pagedispy - l.pagey) in
4140 let r, g, b, alpha = c in
4141 GlDraw.color (r, g, b) ~alpha;
4142 filledrect2
4143 (x0+.dx) (y0+.dy)
4144 (x1+.dx) (y1+.dy)
4145 (x3+.dx) (y3+.dy)
4146 (x2+.dx) (y2+.dy);
4148 ) state.layout
4149 ) rects;
4150 Gl.disable `blend;
4153 let display () =
4154 GlDraw.color (scalecolor2 conf.bgcolor);
4155 GlClear.color (scalecolor2 conf.bgcolor);
4156 GlClear.clear [`color];
4157 List.iter drawpage state.layout;
4158 let rects =
4159 match state.mode with
4160 | LinkNav (Ltexact (pageno, linkno)) ->
4161 begin match getopaque pageno with
4162 | Some opaque ->
4163 let x0, y0, x1, y1 = getlinkrect opaque linkno in
4164 let color = (0.0, 0.0, 0.5, 0.5) in
4165 (pageno, color,
4166 (float x0, float y0,
4167 float x1, float y0,
4168 float x1, float y1,
4169 float x0, float y1)
4170 ) :: state.rects
4171 | None -> state.rects
4173 | LinkNav (Ltgendir _) | LinkNav (Ltnotready _)
4174 | Birdseye _
4175 | Textentry _
4176 | View -> state.rects
4178 showrects rects;
4179 let rec postloop linkindexbase = function
4180 | l :: rest ->
4181 let linkindexbase = linkindexbase + postdrawpage l linkindexbase in
4182 postloop linkindexbase rest
4183 | [] -> ()
4185 showsel ();
4186 postloop 0 state.layout;
4187 state.uioh#display;
4188 begin match state.mstate with
4189 | Mzoomrect ((x0, y0), (x1, y1)) ->
4190 Gl.enable `blend;
4191 GlDraw.color (0.3, 0.3, 0.3) ~alpha:0.5;
4192 GlFunc.blend_func ~src:`src_alpha ~dst:`one_minus_src_alpha;
4193 filledrect (float x0) (float y0) (float x1) (float y1);
4194 Gl.disable `blend;
4195 | Msel _
4196 | Mpan _
4197 | Mscrolly | Mscrollx
4198 | Mzoom _
4199 | Mnone -> ()
4200 end;
4201 enttext ();
4202 scrollindicator ();
4203 Wsi.swapb ();
4206 let zoomrect x y x1 y1 =
4207 let x0 = min x x1
4208 and x1 = max x x1
4209 and y0 = min y y1 in
4210 let zoom = (float state.w) /. float (x1 - x0) in
4211 let margin =
4212 let simple () =
4213 if state.w < state.winw
4214 then (state.winw - state.w) / 2
4215 else 0
4217 match conf.fitmodel with
4218 | FitWidth | FitProportional -> simple ()
4219 | FitPage ->
4220 match conf.columns with
4221 | Csplit _ ->
4222 onppundermouse (fun _ l _ _ -> Some l.pagedispx) x0 y0 x0
4223 | Cmulti _ | Csingle _ -> simple ()
4225 gotoxy ((state.x + margin) - x0) (state.y + y0);
4226 state.anchor <- getanchor ();
4227 setzoom zoom;
4228 resetmstate ();
4231 let annot inline x y =
4232 match unproject x y with
4233 | Some (opaque, n, ux, uy) ->
4234 let add text =
4235 addannot opaque ux uy text;
4236 wcmd "freepage %s" (~> opaque);
4237 Hashtbl.remove state.pagemap (n, state.gen);
4238 flushtiles ();
4239 gotoxy state.x state.y
4241 if inline
4242 then
4243 let ondone s = add s in
4244 let mode = state.mode in
4245 state.mode <- Textentry (
4246 ("annotation: ", E.s, None, textentry, ondone, true),
4247 fun _ -> state.mode <- mode);
4248 state.text <- E.s;
4249 enttext ();
4250 postRedisplay "annot"
4251 else add @@ getusertext E.s
4252 | _ -> ()
4255 let zoomblock x y =
4256 let g opaque l px py =
4257 match rectofblock opaque px py with
4258 | Some a ->
4259 let x0 = a.(0) -. 20. in
4260 let x1 = a.(1) +. 20. in
4261 let y0 = a.(2) -. 20. in
4262 let zoom = (float state.w) /. (x1 -. x0) in
4263 let pagey = getpagey l.pageno in
4264 let margin = (state.w - l.pagew)/2 in
4265 let nx = -truncate x0 - margin in
4266 gotoxy nx (pagey + truncate y0);
4267 state.anchor <- getanchor ();
4268 setzoom zoom;
4269 None
4270 | None -> None
4272 match conf.columns with
4273 | Csplit _ ->
4274 impmsg "block zooming does not work properly in split columns mode"
4275 | Cmulti _ | Csingle _ -> onppundermouse g x y ()
4278 let scrollx x =
4279 let winw = state.winw - 1 in
4280 let s = float x /. float winw in
4281 let destx = truncate (float (state.w + winw) *. s) in
4282 gotoxy (winw - destx) state.y;
4283 state.mstate <- Mscrollx;
4286 let scrolly y =
4287 let s = float y /. float state.winh in
4288 let desty = truncate (s *. float (maxy ())) in
4289 gotoxy state.x desty;
4290 state.mstate <- Mscrolly;
4293 let viewmulticlick clicks x y mask =
4294 let g opaque l px py =
4295 let mark =
4296 match clicks with
4297 | 2 -> Mark_word
4298 | 3 -> Mark_line
4299 | 4 -> Mark_block
4300 | _ -> Mark_page
4302 if markunder opaque px py mark
4303 then (
4304 Some (fun () ->
4305 let dopipe cmd =
4306 match getopaque l.pageno with
4307 | None -> ()
4308 | Some opaque -> pipesel opaque cmd
4310 state.roam <- (fun () -> dopipe conf.paxcmd);
4311 if not (Wsi.withctrl mask) then dopipe conf.selcmd;
4314 else None
4316 postRedisplay "viewmulticlick";
4317 onppundermouse g x y (fun () -> impmsg "nothing to select") ();
4320 let canselect () =
4321 match conf.columns with
4322 | Csplit _ -> false
4323 | Csingle _ | Cmulti _ -> conf.angle mod 360 = 0
4326 let viewmouse button down x y mask =
4327 match button with
4328 | n when (n == 4 || n == 5) && not down ->
4329 if Wsi.withctrl mask
4330 then (
4331 let incr =
4332 if n = 5
4333 then if conf.zoom +. 0.01 > 0.1 then 0.1 else 0.01
4334 else if conf.zoom -. 0.1 < 0.1 then -0.01 else -0.1
4336 let fx, fy =
4337 match state.mstate with
4338 | Mzoom (oldn, _, pos) when n = oldn -> pos
4339 | Mzoomrect _ | Mnone | Mpan _
4340 | Msel _ | Mscrollx | Mscrolly | Mzoom _ -> (x, y)
4342 let zoom = conf.zoom -. incr in
4343 state.mstate <- Mzoom (n, 0, (x, y));
4344 if false && abs (fx - x) > 5 || abs (fy - y) > 5
4345 then pivotzoom ~x ~y zoom
4346 else pivotzoom zoom
4348 else (
4349 match state.autoscroll with
4350 | Some step -> setautoscrollspeed step (n=4)
4351 | None ->
4352 if conf.wheelbypage || conf.presentation
4353 then (
4354 if n = 4
4355 then prevpage ()
4356 else nextpage ()
4358 else
4359 let incr = if n = 4 then -conf.scrollstep else conf.scrollstep in
4360 let incr = incr * 2 in
4361 let y = clamp incr in
4362 gotoxy state.x y
4365 | n when (n = 6 || n = 7) && not down && canpan () ->
4366 let x =
4367 panbound (state.x + (if n = 7 then -2 else 2) * conf.hscrollstep) in
4368 gotoxy x state.y
4370 | 1 when Wsi.withshift mask ->
4371 state.mstate <- Mnone;
4372 if not down
4373 then (
4374 match unproject x y with
4375 | None -> ()
4376 | Some (_, pageno, ux, uy) ->
4377 let cmd = Printf.sprintf
4378 "%s %s %d %d %d"
4379 conf.stcmd state.path pageno ux uy
4381 match spawn cmd [] with
4382 | exception exn ->
4383 impmsg "execution of synctex command(%S) failed: %S"
4384 conf.stcmd @@ exntos exn
4385 | _pid -> ()
4388 | 1 when Wsi.withctrl mask ->
4389 if down
4390 then (
4391 Wsi.setcursor Wsi.CURSOR_FLEUR;
4392 state.mstate <- Mpan (x, y)
4394 else state.mstate <- Mnone
4396 | 3 ->
4397 if down
4398 then (
4399 if Wsi.withshift mask
4400 then (
4401 annot conf.annotinline x y;
4402 postRedisplay "addannot"
4404 else
4405 let p = (x, y) in
4406 Wsi.setcursor Wsi.CURSOR_CYCLE;
4407 state.mstate <- Mzoomrect (p, p)
4409 else (
4410 match state.mstate with
4411 | Mzoomrect ((x0, y0), _) ->
4412 if abs (x-x0) > 10 && abs (y - y0) > 10
4413 then zoomrect x0 y0 x y
4414 else (
4415 resetmstate ();
4416 postRedisplay "kill accidental zoom rect";
4418 | Msel _
4419 | Mpan _
4420 | Mscrolly | Mscrollx
4421 | Mzoom _
4422 | Mnone -> resetmstate ()
4425 | 1 when vscrollhit x ->
4426 if down
4427 then
4428 let _, position, sh = state.uioh#scrollph in
4429 if y > truncate position && y < truncate (position +. sh)
4430 then state.mstate <- Mscrolly
4431 else scrolly y
4432 else state.mstate <- Mnone
4434 | 1 when y > state.winh - hscrollh () ->
4435 if down
4436 then
4437 let _, position, sw = state.uioh#scrollpw in
4438 if x > truncate position && x < truncate (position +. sw)
4439 then state.mstate <- Mscrollx
4440 else scrollx x
4441 else state.mstate <- Mnone
4443 | 1 when state.bzoom -> if not down then zoomblock x y
4445 | 1 ->
4446 let dest = if down then getunder x y else Unone in
4447 begin match dest with
4448 | Ulinkuri _ -> gotounder dest
4449 | Unone when down ->
4450 Wsi.setcursor Wsi.CURSOR_FLEUR;
4451 state.mstate <- Mpan (x, y);
4452 | Uannotation (opaque, slinkindex) -> enterannotmode opaque slinkindex
4453 | Unone | Utext _ ->
4454 if down
4455 then (
4456 if canselect ()
4457 then (
4458 state.mstate <- Msel ((x, y), (x, y));
4459 postRedisplay "mouse select";
4462 else (
4463 match state.mstate with
4464 | Mnone -> ()
4465 | Mzoom _ | Mscrollx | Mscrolly -> state.mstate <- Mnone
4466 | Mzoomrect ((x0, y0), _) -> zoomrect x0 y0 x y
4467 | Mpan _ ->
4468 Wsi.setcursor Wsi.CURSOR_INHERIT;
4469 state.mstate <- Mnone
4470 | Msel ((x0, y0), (x1, y1)) ->
4471 let rec loop = function
4472 | [] -> ()
4473 | l :: rest ->
4474 let inside =
4475 let a0 = l.pagedispy in
4476 let a1 = a0 + l.pagevh in
4477 let b0 = l.pagedispx in
4478 let b1 = b0 + l.pagevw in
4479 ((y0 >= a0 && y0 <= a1) || (y1 >= a0 && y1 <= a1))
4480 && ((x0 >= b0 && x0 <= b1) || (x1 >= b0 && x1 <= b1))
4482 if inside
4483 then
4484 match getopaque l.pageno with
4485 | Some opaque ->
4486 let dosel cmd () =
4487 pipef ~closew:false "Msel"
4488 (fun w ->
4489 copysel w opaque;
4490 postRedisplay "Msel") cmd
4492 dosel conf.selcmd ();
4493 state.roam <- dosel conf.paxcmd;
4494 | None -> ()
4495 else loop rest
4497 loop state.layout;
4498 resetmstate ();
4501 | _ -> ()
4504 let birdseyemouse button down x y mask
4505 (conf, leftx, _, hooverpageno, anchor) =
4506 match button with
4507 | 1 when down ->
4508 let rec loop = function
4509 | [] -> ()
4510 | l :: rest ->
4511 if y > l.pagedispy && y < l.pagedispy + l.pagevh
4512 && x > l.pagedispx && x < l.pagedispx + l.pagevw
4513 then (
4514 leavebirdseye (conf, leftx, l.pageno, hooverpageno, anchor) false;
4516 else loop rest
4518 loop state.layout
4519 | 3 -> ()
4520 | _ -> viewmouse button down x y mask
4523 let uioh = object
4524 method display = ()
4526 method key key mask =
4527 begin match state.mode with
4528 | Textentry textentry -> textentrykeyboard key mask textentry
4529 | Birdseye birdseye -> birdseyekeyboard key mask birdseye
4530 | View -> viewkeyboard key mask
4531 | LinkNav linknav -> linknavkeyboard key mask linknav
4532 end;
4533 state.uioh
4535 method button button bstate x y mask =
4536 begin match state.mode with
4537 | LinkNav _ | View -> viewmouse button bstate x y mask
4538 | Birdseye beye -> birdseyemouse button bstate x y mask beye
4539 | Textentry _ -> ()
4540 end;
4541 state.uioh
4543 method multiclick clicks x y mask =
4544 begin match state.mode with
4545 | LinkNav _ | View -> viewmulticlick clicks x y mask
4546 | Birdseye _ | Textentry _ -> ()
4547 end;
4548 state.uioh
4550 method motion x y =
4551 begin match state.mode with
4552 | Textentry _ -> ()
4553 | View | Birdseye _ | LinkNav _ ->
4554 match state.mstate with
4555 | Mzoom _ | Mnone -> ()
4556 | Mpan (x0, y0) ->
4557 let dx = x - x0
4558 and dy = y0 - y in
4559 state.mstate <- Mpan (x, y);
4560 let x = if canpan () then panbound (state.x + dx) else state.x in
4561 let y = clamp dy in
4562 gotoxy x y
4564 | Msel (a, _) ->
4565 state.mstate <- Msel (a, (x, y));
4566 postRedisplay "motion select";
4568 | Mscrolly ->
4569 let y = min state.winh (max 0 y) in
4570 scrolly y
4572 | Mscrollx ->
4573 let x = min state.winw (max 0 x) in
4574 scrollx x
4576 | Mzoomrect (p0, _) ->
4577 state.mstate <- Mzoomrect (p0, (x, y));
4578 postRedisplay "motion zoomrect";
4579 end;
4580 state.uioh
4582 method pmotion x y =
4583 begin match state.mode with
4584 | Birdseye (conf, leftx, pageno, hooverpageno, anchor) ->
4585 let rec loop = function
4586 | [] ->
4587 if hooverpageno != -1
4588 then (
4589 state.mode <- Birdseye (conf, leftx, pageno, -1, anchor);
4590 postRedisplay "pmotion birdseye no hoover";
4592 | l :: rest ->
4593 if y > l.pagedispy && y < l.pagedispy + l.pagevh
4594 && x > l.pagedispx && x < l.pagedispx + l.pagevw
4595 then (
4596 state.mode <- Birdseye (conf, leftx, pageno, l.pageno, anchor);
4597 postRedisplay "pmotion birdseye hoover";
4599 else loop rest
4601 loop state.layout
4603 | Textentry _ -> ()
4605 | LinkNav _ | View ->
4606 match state.mstate with
4607 | Mpan _ | Msel _ | Mzoom _ | Mscrolly | Mscrollx | Mzoomrect _ -> ()
4608 | Mnone ->
4609 updateunder x y;
4610 if canselect ()
4611 then
4612 match conf.pax with
4613 | None -> ()
4614 | Some past ->
4615 let now = now () in
4616 let delta = now -. past in
4617 if delta > 0.01
4618 then paxunder x y
4619 else conf.pax <- Some now
4620 end;
4621 state.uioh
4623 method infochanged _ = ()
4625 method scrollph =
4626 let maxy = maxy () in
4627 let p, h =
4628 if maxy = 0
4629 then 0.0, float state.winh
4630 else scrollph state.y maxy
4632 vscrollw (), p, h
4634 method scrollpw =
4635 let fwinw = float (state.winw - vscrollw ()) in
4636 let sw =
4637 let sw = fwinw /. float state.w in
4638 let sw = fwinw *. sw in
4639 max sw (float conf.scrollh)
4641 let position =
4642 let maxx = state.w + state.winw in
4643 let x = state.winw - state.x in
4644 let percent = float x /. float maxx in
4645 (fwinw -. sw) *. percent
4647 hscrollh (), position, sw
4649 method modehash =
4650 let modename =
4651 match state.mode with
4652 | LinkNav _ -> "links"
4653 | Textentry _ -> "textentry"
4654 | Birdseye _ -> "birdseye"
4655 | View -> "view"
4657 findkeyhash conf modename
4659 method eformsgs = true
4660 method alwaysscrolly = false
4661 method scroll dx dy =
4662 let x = if canpan () then panbound (state.x + dx) else state.x in
4663 gotoxy x (clamp (2 * dy));
4664 state.uioh
4665 method zoom z x y =
4666 pivotzoom ~x ~y (conf.zoom *. exp z);
4667 end;;
4669 let addrect pageno r g b a x0 y0 x1 y1 =
4670 Hashtbl.add state.prects pageno [|r; g; b; a; x0; y0; x1; y1|];
4673 let ract cmds =
4674 let cl = splitatchar cmds ' ' in
4675 let scan s fmt f =
4676 try Scanf.sscanf s fmt f
4677 with exn -> adderrfmt "remote exec" "error processing '%S': %s\n"
4678 cmds @@ exntos exn
4680 let rectx s pageno (r, g, b, a) x0 y0 x1 y1 =
4681 vlog "%s page %d color (%f %f %f %f) x0,y0,x1,y1 = %f %f %f %f"
4682 s pageno r g b a x0 y0 x1 y1;
4683 onpagerect
4684 pageno
4685 (fun w h ->
4686 let _,w1,h1,_ = getpagedim pageno in
4687 let sw = float w1 /. float w
4688 and sh = float h1 /. float h in
4689 let x0s = x0 *. sw
4690 and x1s = x1 *. sw
4691 and y0s = y0 *. sh
4692 and y1s = y1 *. sh in
4693 let rect = (x0s,y0s,x1s,y0s,x1s,y1s,x0s,y1s) in
4694 let color = (r, g, b, a) in
4695 if conf.verbose then debugrect rect;
4696 state.rects <- (pageno, color, rect) :: state.rects;
4697 postRedisplay s;
4700 match cl with
4701 | "reload", "" -> reload ()
4702 | "goto", args ->
4703 scan args "%u %f %f"
4704 (fun pageno x y ->
4705 let cmd, _ = state.geomcmds in
4706 if emptystr cmd
4707 then gotopagexy pageno x y
4708 else
4709 let f prevf () =
4710 gotopagexy pageno x y;
4711 prevf ()
4713 state.reprf <- f state.reprf
4715 | "goto1", args -> scan args "%u %f" gotopage
4716 | "gotor", args -> scan args "%S" gotoremote
4717 | "rect", args ->
4718 scan args "%u %u %f %f %f %f"
4719 (fun pageno c x0 y0 x1 y1 ->
4720 let color = (0.0, 0.0, 1.0 /. float c, 0.5) in
4721 rectx "rect" pageno color x0 y0 x1 y1;
4723 | "prect", args ->
4724 scan args "%u %f %f %f %f %f %f %f %f"
4725 (fun pageno r g b alpha x0 y0 x1 y1 ->
4726 addrect pageno r g b alpha x0 y0 x1 y1;
4727 postRedisplay "prect"
4729 | "pgoto", args ->
4730 scan args "%u %f %f"
4731 (fun pageno x y ->
4732 let optopaque =
4733 match getopaque pageno with
4734 | Some opaque -> opaque
4735 | None -> ~< E.s
4737 pgoto optopaque pageno x y;
4738 let rec fixx = function
4739 | [] -> ()
4740 | l :: rest ->
4741 if l.pageno = pageno
4742 then gotoxy (state.x - l.pagedispx) state.y
4743 else fixx rest
4745 let layout =
4746 let mult =
4747 match conf.columns with
4748 | Csingle _ | Csplit _ -> 1
4749 | Cmulti ((n, _, _), _) -> n
4751 layout 0 state.y (state.winw * mult) state.winh
4753 fixx layout
4755 | "activatewin", "" -> Wsi.activatewin ()
4756 | "quit", "" -> raise Quit
4757 | "keys", keys ->
4758 begin try
4759 let l = Config.keys_of_string keys in
4760 List.iter (fun (k, m) -> keyboard k m) l
4761 with exn -> adderrfmt "error processing keys" "`%S': %s\n"
4762 cmds @@ exntos exn
4764 | "clearrects", "" ->
4765 Hashtbl.clear state.prects;
4766 postRedisplay "clearrects"
4767 | _ ->
4768 adderrfmt "remote command"
4769 "error processing remote command: %S\n" cmds;
4772 let remote =
4773 let scratch = Bytes.create 80 in
4774 let buf = Buffer.create 80 in
4775 fun fd ->
4776 match tempfailureretry (Unix.read fd scratch 0) 80 with
4777 | exception Unix.Unix_error (Unix.EAGAIN, _, _) -> None
4778 | 0 ->
4779 Unix.close fd;
4780 if Buffer.length buf > 0
4781 then (
4782 let s = Buffer.contents buf in
4783 Buffer.clear buf;
4784 ract s;
4786 None
4787 | n ->
4788 let rec eat ppos =
4789 let nlpos =
4790 match Bytes.index_from scratch ppos '\n' with
4791 | pos -> if pos >= n then -1 else pos
4792 | exception Not_found -> -1
4794 if nlpos >= 0
4795 then (
4796 Buffer.add_subbytes buf scratch ppos (nlpos-ppos);
4797 let s = Buffer.contents buf in
4798 Buffer.clear buf;
4799 ract s;
4800 eat (nlpos+1);
4802 else (
4803 Buffer.add_subbytes buf scratch ppos (n-ppos);
4804 Some fd
4806 in eat 0
4809 let remoteopen path =
4810 try Some (Unix.openfile path [Unix.O_NONBLOCK; Unix.O_RDONLY] 0o0)
4811 with exn ->
4812 adderrfmt "remoteopen" "error opening %S: %s" path @@ exntos exn;
4813 None
4816 let () =
4817 let gcconfig = ref false in
4818 let trimcachepath = ref E.s in
4819 let rcmdpath = ref E.s in
4820 let pageno = ref None in
4821 let openlast = ref false in
4822 let doreap = ref false in
4823 let csspath = ref None in
4824 selfexec := Sys.executable_name;
4825 Arg.parse
4826 (Arg.align
4827 [("-p", Arg.String (fun s -> state.password <- s),
4828 "<password> Set password");
4830 ("-f", Arg.String
4831 (fun s ->
4832 Config.fontpath := s;
4833 selfexec := !selfexec ^ " -f " ^ Filename.quote s;
4835 "<path> Set path to the user interface font");
4837 ("-c", Arg.String
4838 (fun s ->
4839 selfexec := !selfexec ^ " -c " ^ Filename.quote s;
4840 Config.confpath := s),
4841 "<path> Set path to the configuration file");
4843 ("-last", Arg.Set openlast, " Open last document");
4845 ("-page", Arg.Int (fun pageno1 -> pageno := Some (pageno1-1)),
4846 "<page-number> Jump to page");
4848 ("-tcf", Arg.String (fun s -> trimcachepath := s),
4849 "<path> Set path to the trim cache file");
4851 ("-dest", Arg.String (fun s -> state.nameddest <- s),
4852 "<named-destination> Set named destination");
4854 ("-remote", Arg.String (fun s -> rcmdpath := s),
4855 "<path> Set path to the source of remote commands");
4857 ("-gc", Arg.Set gcconfig, " Collect config garbage");
4859 ("-v", Arg.Unit (fun () ->
4860 Printf.printf
4861 "%s\nconfiguration file: %s\n"
4862 (Help.version ())
4863 Config.defconfpath;
4864 exit 0), " Print version and exit");
4866 ("-css", Arg.String (fun s -> csspath := Some s),
4867 "<path> Set path to the style sheet to use with EPUB/HTML");
4869 ("-origin", Arg.String (fun s -> state.origin <- s),
4870 "<origin> <undocumented>");
4872 ("-no-title", Arg.Set ignoredoctitlte, " ignore document title");
4873 ("-layout-height", Arg.Set_int layouth,
4874 "<height> layout height html/epub/etc (-1, 0, N)");
4877 (fun s -> state.path <- s)
4878 ("Usage: " ^ Sys.argv.(0) ^ " [options] some.pdf\nOptions:");
4880 let histmode = emptystr state.path && not !openlast in
4882 if not (Config.load !openlast)
4883 then dolog "failed to load configuration";
4885 begin match !pageno with
4886 | Some pageno -> state.anchor <- (pageno, 0.0, 0.0)
4887 | None -> ()
4888 end;
4890 fillhelp ();
4891 if !gcconfig
4892 then (
4893 Config.gc ();
4894 exit 0
4897 let mu =
4898 object (self)
4899 val mutable m_clicks = 0
4900 val mutable m_click_x = 0
4901 val mutable m_click_y = 0
4902 val mutable m_lastclicktime = infinity
4904 method private cleanup =
4905 state.roam <- noroam;
4906 Hashtbl.iter (fun _ opaque -> clearmark opaque) state.pagemap
4907 method expose = postRedisplay "expose"
4908 method visible v =
4909 let name =
4910 match v with
4911 | Wsi.Unobscured -> "unobscured"
4912 | Wsi.PartiallyObscured -> "partiallyobscured"
4913 | Wsi.FullyObscured -> "fullyobscured"
4915 vlog "visibility change %s" name
4916 method display = display ()
4917 method map mapped = vlog "mapped %b" mapped
4918 method reshape w h =
4919 self#cleanup;
4920 reshape w h
4921 method mouse b d x y m =
4922 if d && canselect ()
4923 then (
4925 * http://blogs.msdn.com/b/oldnewthing/archive/2004/10/18/243925.aspx
4927 m_click_x <- x;
4928 m_click_y <- y;
4929 if b = 1
4930 then (
4931 let t = now () in
4932 if abs x - m_click_x > 10
4933 || abs y - m_click_y > 10
4934 || abs_float (t -. m_lastclicktime) > 0.3
4935 then m_clicks <- 0;
4936 m_clicks <- m_clicks + 1;
4937 m_lastclicktime <- t;
4938 if m_clicks = 1
4939 then (
4940 self#cleanup;
4941 postRedisplay "cleanup";
4942 state.uioh <- state.uioh#button b d x y m;
4944 else state.uioh <- state.uioh#multiclick m_clicks x y m
4946 else (
4947 self#cleanup;
4948 m_clicks <- 0;
4949 m_lastclicktime <- infinity;
4950 state.uioh <- state.uioh#button b d x y m
4953 else state.uioh <- state.uioh#button b d x y m
4954 method motion x y =
4955 state.mpos <- (x, y);
4956 state.uioh <- state.uioh#motion x y
4957 method pmotion x y =
4958 state.mpos <- (x, y);
4959 state.uioh <- state.uioh#pmotion x y
4960 method key k m =
4961 vlog "k=%#x m=%#x" k m;
4962 let mascm = m land (
4963 Wsi.altmask + Wsi.shiftmask + Wsi.ctrlmask + Wsi.metamask
4964 ) in
4965 let keyboard k m =
4966 let x = state.x and y = state.y in
4967 keyboard k m;
4968 if x != state.x || y != state.y then self#cleanup
4970 match state.keystate with
4971 | KSnone ->
4972 let km = k, mascm in
4973 begin
4974 match
4975 let modehash = state.uioh#modehash in
4976 try Hashtbl.find modehash km
4977 with Not_found ->
4978 try Hashtbl.find (findkeyhash conf "global") km
4979 with Not_found -> KMinsrt (k, m)
4980 with
4981 | KMinsrt (k, m) -> keyboard k m
4982 | KMinsrl l -> List.iter (fun (k, m) -> keyboard k m) l
4983 | KMmulti (l, r) -> state.keystate <- KSinto (l, r)
4985 | KSinto ((k', m') :: [], insrt) when k'=k && m' land mascm = m' ->
4986 List.iter (fun (k, m) -> keyboard k m) insrt;
4987 state.keystate <- KSnone
4988 | KSinto ((k', m') :: keys, insrt) when k'=k && m' land mascm = m' ->
4989 state.keystate <- KSinto (keys, insrt)
4990 | KSinto _ -> state.keystate <- KSnone
4992 method enter x y =
4993 state.mpos <- (x, y);
4994 state.uioh <- state.uioh#pmotion x y
4995 method leave = state.mpos <- (-1, -1)
4996 method winstate wsl = state.winstate <- wsl
4997 method quit : 'a. 'a = raise Quit
4998 method scroll dx dy = state.uioh <- state.uioh#scroll dx dy
4999 method zoom z x y = state.uioh#zoom z x y
5000 method opendoc path =
5001 state.mode <- View;
5002 state.uioh <- uioh;
5003 postRedisplay "opendoc";
5004 opendoc path state.password
5007 let wsfd, winw, winh = Wsi.init mu conf.cwinw conf.cwinh platform in
5008 state.wsfd <- wsfd;
5010 if not @@ List.exists GlMisc.check_extension
5011 [ "GL_ARB_texture_rectangle"
5012 ; "GL_EXT_texture_recangle"
5013 ; "GL_NV_texture_rectangle" ]
5014 then (dolog "OpenGL does not suppport rectangular textures"; exit 1);
5016 if substratis (GlMisc.get_string `renderer) 0 "Mesa DRI Intel("
5017 then (
5018 defconf.sliceheight <- 1024;
5019 defconf.texcount <- 32;
5020 defconf.usepbo <- true;
5023 let cs, ss =
5024 match Unix.socketpair Unix.PF_UNIX Unix.SOCK_STREAM 0 with
5025 | exception exn ->
5026 dolog "socketpair failed: %s" @@ exntos exn;
5027 exit 1
5028 | (r, w) ->
5029 cloexec r;
5030 cloexec w;
5031 r, w
5034 setcheckers conf.checkers;
5035 begin match !csspath with
5036 | None -> ()
5037 | Some "" -> conf.css <- E.s
5038 | Some path ->
5039 let css = filecontents path in
5040 let l = String.length css in
5041 conf.css <-
5042 if substratis css (l-2) "\r\n"
5043 then String.sub css 0 (l-2)
5044 else (if css.[l-1] = '\n' then String.sub css 0 (l-1) else css)
5045 end;
5046 init cs (
5047 conf.angle, conf.fitmodel, (conf.trimmargins, conf.trimfuzz),
5048 conf.texcount, conf.sliceheight, conf.mustoresize, conf.colorspace,
5049 !Config.fontpath, !trimcachepath
5051 List.iter GlArray.enable [`texture_coord; `vertex];
5052 state.ss <- ss;
5053 reshape ~firsttime:true winw winh;
5054 state.uioh <- uioh;
5055 if histmode
5056 then (
5057 Wsi.settitle "llpp (history)";
5058 enterhistmode ();
5060 else (
5061 state.text <- "Opening " ^ (mbtoutf8 state.path);
5062 opendoc state.path state.password;
5064 display ();
5065 Wsi.mapwin ();
5066 Wsi.setcursor Wsi.CURSOR_INHERIT;
5067 Sys.set_signal Sys.sighup (Sys.Signal_handle (fun _ -> reload ()));
5069 let rec reap () =
5070 match Unix.waitpid [Unix.WNOHANG] ~-1 with
5071 | exception (Unix.Unix_error (Unix.ECHILD, _, _)) -> ()
5072 | exception exn -> dolog "Unix.waitpid: %s" @@ exntos exn
5073 | 0, _ -> ()
5074 | _pid, _status -> reap ()
5076 Sys.set_signal Sys.sigchld (Sys.Signal_handle (fun _ -> doreap := true));
5078 let optrfd =
5079 ref (if nonemptystr !rcmdpath then remoteopen !rcmdpath else None)
5082 let rec loop deadline =
5083 if !doreap
5084 then (
5085 doreap := false;
5086 reap ()
5088 let r = [state.ss; state.wsfd] in
5089 let r =
5090 match !optrfd with
5091 | None -> r
5092 | Some fd -> fd :: r
5094 if !redisplay
5095 then (
5096 Glutils.redisplay := false;
5097 display ();
5099 let timeout =
5100 let now = now () in
5101 if deadline > now
5102 then (
5103 if deadline = infinity
5104 then ~-.1.0
5105 else max 0.0 (deadline -. now)
5107 else 0.0
5109 let r, _, _ =
5110 try Unix.select r [] [] timeout
5111 with Unix.Unix_error (Unix.EINTR, _, _) -> [], [], []
5113 begin match r with
5114 | [] ->
5115 let newdeadline =
5116 match state.autoscroll with
5117 | Some step when step != 0 ->
5118 if state.slideshow land 1 = 1
5119 then (
5120 if state.slideshow land 2 = 0
5121 then state.slideshow <- state.slideshow lor 2
5122 else if step < 0 then prevpage () else nextpage ();
5123 deadline +. (float (abs step))
5125 else
5126 let y = state.y + step in
5127 let fy = if conf.maxhfit then state.winh else 0 in
5128 let y =
5129 if y < 0
5130 then state.maxy - fy
5131 else if y >= state.maxy - fy then 0 else y
5133 gotoxy state.x y;
5134 deadline +. 0.01
5135 | _ -> infinity
5137 loop newdeadline
5139 | l ->
5140 let rec checkfds = function
5141 | [] -> ()
5142 | fd :: rest when fd = state.ss ->
5143 let cmd = rcmd state.ss in
5144 act cmd;
5145 checkfds rest
5147 | fd :: rest when fd = state.wsfd ->
5148 Wsi.readresp fd;
5149 checkfds rest
5151 | fd :: rest when Some fd = !optrfd ->
5152 begin match remote fd with
5153 | None -> optrfd := remoteopen !rcmdpath;
5154 | opt -> optrfd := opt
5155 end;
5156 checkfds rest
5158 | _ :: rest ->
5159 dolog "select returned unknown descriptor";
5160 checkfds rest
5162 checkfds l;
5163 let newdeadline =
5164 let deadline1 =
5165 if deadline = infinity
5166 then now () +. 0.01
5167 else deadline
5169 match state.autoscroll with
5170 | Some step when step != 0 -> deadline1
5171 | _ -> infinity
5173 loop newdeadline
5174 end;
5176 match loop infinity with
5177 | exception Quit ->
5178 Config.save leavebirdseye;
5179 if hasunsavedchanges ()
5180 then save ()
5181 | _ -> error "umpossible - infinity reached"