Cosmetics
[llpp.git] / main.ml
blob641a14e9b05a7ec5717483e35a504beb764c2218
1 open Utils;;
2 open Config;;
4 exception Quit;;
6 external init : Unix.file_descr -> initparams -> unit = "ml_init";;
7 external seltext : opaque -> (int * int * int * int) -> unit = "ml_seltext";;
8 external hassel : opaque -> bool = "ml_hassel";;
9 external copysel : Unix.file_descr -> opaque -> unit = "ml_copysel";;
10 external getpdimrect : int -> float array = "ml_getpdimrect";;
11 external whatsunder : opaque -> int -> int -> under = "ml_whatsunder";;
12 external markunder : opaque -> int -> int -> mark -> bool = "ml_markunder";;
13 external clearmark : opaque -> unit = "ml_clearmark";;
14 external zoomforh : int -> int -> int -> int -> float = "ml_zoom_for_height";;
15 external getmaxw : unit -> float = "ml_getmaxw";;
16 external drawstr : int -> int -> int -> string -> float = "ml_draw_string";;
17 external measurestr : int -> string -> float = "ml_measure_string";;
18 external postprocess :
19 opaque -> int -> int -> int -> (int * string * int) -> int
20 = "ml_postprocess";;
21 external pagebbox : opaque -> (int * int * int * int) = "ml_getpagebox";;
22 external setaalevel : int -> unit = "ml_setaalevel";;
23 external realloctexts : int -> bool = "ml_realloctexts";;
24 external findlink : opaque -> linkdir -> link = "ml_findlink";;
25 external getlink : opaque -> int -> under = "ml_getlink";;
26 external getlinkrect : opaque -> int -> irect = "ml_getlinkrect";;
27 external getlinkcount : opaque -> int = "ml_getlinkcount";;
28 external findpwl : int -> int -> pagewithlinks = "ml_find_page_with_links";;
29 external getpbo : width -> height -> colorspace -> opaque = "ml_getpbo";;
30 external freepbo : opaque -> unit = "ml_freepbo";;
31 external unmappbo : opaque -> unit = "ml_unmappbo";;
32 external bousable : unit -> bool = "ml_bo_usable";;
33 external unproject : opaque -> int -> int -> (int * int) option
34 = "ml_unproject";;
35 external project : opaque -> int -> int -> float -> float -> (float * float)
36 = "ml_project";;
37 external drawtile : tileparams -> opaque -> unit = "ml_drawtile";;
38 external rectofblock : opaque -> int -> int -> float array option
39 = "ml_rectofblock";;
40 external begintiles : unit -> unit = "ml_begintiles";;
41 external endtiles : unit -> unit = "ml_endtiles";;
42 external addannot : opaque -> int -> int -> string -> unit = "ml_addannot";;
43 external modannot : opaque -> slinkindex -> string -> unit = "ml_modannot";;
44 external delannot : opaque -> slinkindex -> unit = "ml_delannot";;
45 external hasunsavedchanges : unit -> bool = "ml_hasunsavedchanges";;
46 external savedoc : string -> unit = "ml_savedoc";;
47 external getannotcontents : opaque -> slinkindex -> string
48 = "ml_getannotcontents";;
49 external drawprect : opaque -> int -> int -> float array -> unit
50 = "ml_drawprect";;
51 external wcmd : Unix.file_descr -> bytes -> int -> unit = "ml_wcmd";;
52 external rcmd : Unix.file_descr -> string = "ml_rcmd";;
53 external uritolocation : string -> (pageno * float * float)
54 = "ml_uritolocation";;
55 external isexternallink : string -> bool = "ml_isexternallink";;
57 let selfexec = ref E.s;;
58 let opengl_has_pbo = ref false;;
60 let drawstring size x y s =
61 Gl.enable `blend;
62 Gl.enable `texture_2d;
63 GlFunc.blend_func ~src:`src_alpha ~dst:`one_minus_src_alpha;
64 ignore (drawstr size x y s);
65 Gl.disable `blend;
66 Gl.disable `texture_2d;
69 let drawstring1 size x y s =
70 drawstr size x y s;
73 let drawstring2 size x y fmt =
74 Printf.kprintf (drawstring size (x+1) (y+size+1)) fmt
77 module UniSyms = struct
78 let ellipsis = "\xe2\x80\xa6";;
79 let radical = "\xe2\x88\x9a";;
80 let lguillemet = "\xc2\xab";;
81 let rguillemet = "\xc2\xbb";;
82 end;;
84 let _debugl l =
85 dolog {|l %d dim=%d {
86 WxH %dx%d
87 vWxH %dx%d
88 pagex,y %d,%d
89 dispx,y %d,%d
90 column %d
91 }|}
92 l.pageno l.pagedimno
93 l.pagew l.pageh
94 l.pagevw l.pagevh
95 l.pagex l.pagey
96 l.pagedispx l.pagedispy
97 l.pagecol
100 let debugrect (x0, y0, x1, y1, x2, y2, x3, y3) =
101 dolog {|rect {
102 x0,y0=(% f, % f)
103 x1,y1=(% f, % f)
104 x2,y2=(% f, % f)
105 x3,y3=(% f, % f)
106 }|} x0 y0 x1 y1 x2 y2 x3 y3;
109 let isbirdseye = function
110 | Birdseye _ -> true
111 | Textentry _ | View | LinkNav _ -> false
114 let istextentry = function
115 | Textentry _ -> true
116 | Birdseye _ | View | LinkNav _ -> false
119 let wtmode = ref false;;
120 let cxack = ref false;;
122 let pgscale h = truncate (float h *. conf.pgscale);;
124 let hscrollh () =
125 if state.uioh#alwaysscrolly || ((conf.scrollb land scrollbhv != 0)
126 && (state.w > state.winw))
127 then conf.scrollbw
128 else 0
131 let vscrollw () =
132 if state.uioh#alwaysscrolly || ((conf.scrollb land scrollbvv != 0)
133 && (state.maxy > state.winh))
134 then conf.scrollbw
135 else 0
138 let vscrollhit x =
139 if conf.leftscroll
140 then x < vscrollw ()
141 else x > state.winw - vscrollw ()
144 let setfontsize n =
145 fstate.fontsize <- n;
146 fstate.wwidth <- measurestr fstate.fontsize "w";
147 fstate.maxrows <- (state.winh - fstate.fontsize - 1) / (fstate.fontsize + 1);
150 let vlog fmt =
151 if conf.verbose
152 then dolog fmt
153 else Printf.kprintf ignore fmt
156 let launchpath () =
157 if emptystr conf.pathlauncher
158 then dolog "%s" state.path
159 else (
160 let command = Str.global_replace percentsre state.path conf.pathlauncher in
161 match spawn command [] with
162 | _pid -> ()
163 | exception exn ->
164 dolog "failed to execute `%s': %s" command @@ exntos exn
168 module G =
169 struct
170 let postRedisplay who =
171 vlog "redisplay for [%S]" who;
172 state.redisplay <- true;
174 end;;
176 let getopaque pageno =
177 try Some (Hashtbl.find state.pagemap (pageno, state.gen))
178 with Not_found -> None
181 let pagetranslatepoint l x y =
182 let dy = y - l.pagedispy in
183 let y = dy + l.pagey in
184 let dx = x - l.pagedispx in
185 let x = dx + l.pagex in
186 (x, y);
189 let onppundermouse g x y d =
190 let rec f = function
191 | l :: rest ->
192 begin match getopaque l.pageno with
193 | Some opaque ->
194 let x0 = l.pagedispx in
195 let x1 = x0 + l.pagevw in
196 let y0 = l.pagedispy in
197 let y1 = y0 + l.pagevh in
198 if y >= y0 && y <= y1 && x >= x0 && x <= x1
199 then
200 let px, py = pagetranslatepoint l x y in
201 match g opaque l px py with
202 | Some res -> res
203 | None -> f rest
204 else f rest
205 | _ ->
206 f rest
208 | [] -> d
210 f state.layout
213 let getunder x y =
214 let g opaque l px py =
215 if state.bzoom
216 then (
217 match rectofblock opaque px py with
218 | Some [|x0;x1;y0;y1|] ->
219 let rect = (x0, y0, x1, y0, x1, y1, x0, y1) in
220 let color = (0.0, 0.0, 1.0 /. (l.pageno mod 3 |> float), 0.5) in
221 state.rects <- [l.pageno, color, rect];
222 G.postRedisplay "getunder";
223 | _otherwise -> ()
225 let under = whatsunder opaque px py in
226 if under = Unone then None else Some under
228 onppundermouse g x y Unone
231 let unproject x y =
232 let g opaque l x y =
233 match unproject opaque x y with
234 | Some (x, y) -> Some (Some (opaque, l.pageno, x, y))
235 | None -> None
237 onppundermouse g x y None;
240 let showtext c s =
241 state.text <- Printf.sprintf "%c%s" c s;
242 G.postRedisplay "showtext";
245 let impmsg fmt =
246 Format.ksprintf (fun s -> showtext '!' s) fmt;
249 let pipesel opaque cmd =
250 if hassel opaque
251 then
252 match Unix.pipe () with
253 | exception exn -> dolog "pipesel cannot create pipe: %S" @@ exntos exn;
254 | (r, w) ->
255 let doclose what fd =
256 Ne.clo fd (fun msg -> dolog "%s close failed: %s" what msg)
258 begin match spawn cmd [r, 0; w, -1] with
259 | exception exn ->
260 doclose "pipesel pipe/w" w;
261 dolog "cannot execute %S: %s" cmd @@ exntos exn
262 | _pid ->
263 copysel w opaque;
264 G.postRedisplay "pipesel";
265 end;
266 doclose "pipesel pipe/r" r;
269 let paxunder x y =
270 let g opaque l px py =
271 if markunder opaque px py conf.paxmark
272 then (
273 Some (fun () ->
274 match getopaque l.pageno with
275 | None -> ()
276 | Some opaque -> pipesel opaque conf.paxcmd
279 else None
281 G.postRedisplay "paxunder";
282 if conf.paxmark = Mark_page
283 then
284 List.iter (fun l ->
285 match getopaque l.pageno with
286 | None -> ()
287 | Some opaque -> clearmark opaque) state.layout;
288 state.roam <- onppundermouse g x y (fun () -> impmsg "whoopsie daisy");
291 let selstring s =
292 match Unix.pipe () with
293 | exception exn -> impmsg "pipe failed: %s" @@ exntos exn
294 | (r, w) ->
295 let clo cap fd =
296 Ne.clo fd (fun msg -> impmsg "failed to close %s: %s" cap msg)
298 begin match spawn conf.selcmd [r, 0; w, -1] with
299 | exception exn ->
300 clo "selstring pipe/w" w;
301 impmsg "failed to execute %s: %s" conf.selcmd @@ exntos exn
302 | _pid ->
304 let l = String.length s in
305 let bytes = Bytes.unsafe_of_string s in
306 let n = tempfailureretry (Unix.write w bytes 0) l in
307 if n != l
308 then impmsg "failed to write %d characters to sel pipe, wrote %d" l n
309 with exn -> impmsg "failed to write to sel pipe: %s" @@ exntos exn
310 end;
311 clo "selstring pipe/r" r;
314 let undertext = function
315 | Unone -> "none"
316 | Ulinkuri s -> s
317 | Utext s -> "font: " ^ s
318 | Uannotation (opaque, slinkindex) ->
319 "annotation: " ^ getannotcontents opaque slinkindex
322 let updateunder x y =
323 match getunder x y with
324 | Unone -> Wsi.setcursor Wsi.CURSOR_INHERIT
325 | Ulinkuri uri ->
326 if conf.underinfo then showtext 'u' ("ri: " ^ uri);
327 Wsi.setcursor Wsi.CURSOR_INFO
328 | Utext s ->
329 if conf.underinfo then showtext 'f' ("ont: " ^ s);
330 Wsi.setcursor Wsi.CURSOR_TEXT
331 | Uannotation _ ->
332 if conf.underinfo then showtext 'a' "nnotation";
333 Wsi.setcursor Wsi.CURSOR_INFO
336 let showlinktype under =
337 if conf.underinfo && under != Unone
338 then showtext ' ' @@ undertext under
341 let [@warning "-4"] intentry_with_suffix text key =
342 let text =
343 match key with
344 | Keys.Ascii ('0'..'9' as c) -> addchar text c
345 | Keys.Ascii ('k' | 'm' | 'g' | 'K' | 'M' | 'G' as c) ->
346 addchar text @@ asciilower c
347 | _ ->
348 state.text <- Printf.sprintf "invalid key";
349 text
351 TEcont text
354 let wcmd fmt =
355 let b = Buffer.create 16 in
356 Printf.kbprintf
357 (fun b ->
358 let b = Buffer.to_bytes b in
359 wcmd state.ss b @@ Bytes.length b
360 ) b fmt
363 let nogeomcmds cmds =
364 match cmds with
365 | s, [] -> emptystr s
366 | _ -> false
369 let layoutN ((columns, coverA, coverB), b) x y sw sh =
370 let rec fold accu n =
371 if n = Array.length b
372 then accu
373 else
374 let pdimno, dx, vy, (_, w, h, xoff) = b.(n) in
375 if (vy - y) > sh &&
376 (n = coverA - 1
377 || n = state.pagecount - coverB
378 || (n - coverA) mod columns = columns - 1)
379 then accu
380 else
381 let accu =
382 if vy + h > y
383 then
384 let pagey = max 0 (y - vy) in
385 let pagedispy = if pagey > 0 then 0 else vy - y in
386 let pagedispx, pagex =
387 let pdx =
388 if n = coverA - 1 || n = state.pagecount - coverB
389 then x + (sw - w) / 2
390 else dx + xoff + x
392 if pdx < 0
393 then 0, -pdx
394 else pdx, 0
396 let pagevw =
397 let vw = sw - pagedispx in
398 let pw = w - pagex in
399 min vw pw
401 let pagevh = min (h - pagey) (sh - pagedispy) in
402 if pagevw > 0 && pagevh > 0
403 then
404 let e =
405 { pageno = n
406 ; pagedimno = pdimno
407 ; pagew = w
408 ; pageh = h
409 ; pagex = pagex
410 ; pagey = pagey
411 ; pagevw = pagevw
412 ; pagevh = pagevh
413 ; pagedispx = pagedispx
414 ; pagedispy = pagedispy
415 ; pagecol = 0
418 e :: accu
419 else
420 accu
421 else
422 accu
424 fold accu (n+1)
426 if Array.length b = 0
427 then []
428 else List.rev (fold [] (page_of_y y))
431 let layoutS (columns, b) x y sw sh =
432 let rec fold accu n =
433 if n = Array.length b
434 then accu
435 else
436 let pdimno, px, vy, (_, pagew, pageh, xoff) = b.(n) in
437 if (vy - y) > sh
438 then accu
439 else
440 let accu =
441 if vy + pageh > y
442 then
443 let x = xoff + x in
444 let pagey = max 0 (y - vy) in
445 let pagedispy = if pagey > 0 then 0 else vy - y in
446 let pagedispx, pagex =
447 if px = 0
448 then (
449 if x < 0
450 then 0, -x
451 else x, 0
453 else (
454 let px = px - x in
455 if px < 0
456 then -px, 0
457 else 0, px
460 let pagecolw = pagew/columns in
461 let pagedispx =
462 if pagecolw < sw
463 then pagedispx + ((sw - pagecolw) / 2)
464 else pagedispx
466 let pagevw =
467 let vw = sw - pagedispx in
468 let pw = pagew - pagex in
469 min vw pw
471 let pagevw = min pagevw pagecolw in
472 let pagevh = min (pageh - pagey) (sh - pagedispy) in
473 if pagevw > 0 && pagevh > 0
474 then
475 let e =
476 { pageno = n/columns
477 ; pagedimno = pdimno
478 ; pagew = pagew
479 ; pageh = pageh
480 ; pagex = pagex
481 ; pagey = pagey
482 ; pagevw = pagevw
483 ; pagevh = pagevh
484 ; pagedispx = pagedispx
485 ; pagedispy = pagedispy
486 ; pagecol = n mod columns
489 e :: accu
490 else
491 accu
492 else
493 accu
495 fold accu (n+1)
497 List.rev (fold [] 0)
500 let layout x y sw sh =
501 if nogeomcmds state.geomcmds
502 then
503 match conf.columns with
504 | Csingle b -> layoutN ((1, 0, 0), b) x y sw sh
505 | Cmulti c -> layoutN c x y sw sh
506 | Csplit s -> layoutS s x y sw sh
507 else []
510 let maxy () = state.maxy - if conf.maxhfit then state.winh else 0;;
512 let clamp incr = bound (state.y + incr) 0 @@ maxy ();;
514 let itertiles l f =
515 let tilex = l.pagex mod conf.tilew in
516 let tiley = l.pagey mod conf.tileh in
518 let col = l.pagex / conf.tilew in
519 let row = l.pagey / conf.tileh in
521 let rec rowloop row y0 dispy h =
522 if h = 0
523 then ()
524 else (
525 let dh = conf.tileh - y0 in
526 let dh = min h dh in
527 let rec colloop col x0 dispx w =
528 if w = 0
529 then ()
530 else (
531 let dw = conf.tilew - x0 in
532 let dw = min w dw in
533 f col row dispx dispy x0 y0 dw dh;
534 colloop (col+1) 0 (dispx+dw) (w-dw)
537 colloop col tilex l.pagedispx l.pagevw;
538 rowloop (row+1) 0 (dispy+dh) (h-dh)
541 if l.pagevw > 0 && l.pagevh > 0
542 then rowloop row tiley l.pagedispy l.pagevh;
545 let gettileopaque l col row =
546 let key =
547 l.pageno, state.gen, conf.colorspace, conf.angle, l.pagew, l.pageh, col, row
549 try Some (Hashtbl.find state.tilemap key)
550 with Not_found -> None
553 let puttileopaque l col row gen colorspace angle opaque size elapsed =
554 let key = l.pageno, gen, colorspace, angle, l.pagew, l.pageh, col, row in
555 Hashtbl.add state.tilemap key (opaque, size, elapsed)
558 let filledrect2 x0 y0 x1 y1 x2 y2 x3 y3 =
559 Raw.sets_float state.vraw ~pos:0 [| x0; y0; x1; y1; x2; y2; x3; y3 |];
560 GlArray.vertex `two state.vraw;
561 GlArray.draw_arrays `triangle_strip ~first:0 ~count:4;
564 let filledrect1 x0 y0 x1 y1 = filledrect2 x0 y0 x0 y1 x1 y0 x1 y1;;
566 let filledrect x0 y0 x1 y1 =
567 GlArray.disable `texture_coord;
568 filledrect1 x0 y0 x1 y1;
569 GlArray.enable `texture_coord;
572 let linerect x0 y0 x1 y1 =
573 GlArray.disable `texture_coord;
574 Raw.sets_float state.vraw ~pos:0 [| x0; y0; x0; y1; x1; y1; x1; y0 |];
575 GlArray.vertex `two state.vraw;
576 GlArray.draw_arrays `line_loop ~first:0 ~count:4;
577 GlArray.enable `texture_coord;
580 let drawtiles l color =
581 GlDraw.color color;
582 begintiles ();
583 let f col row x y tilex tiley w h =
584 match gettileopaque l col row with
585 | Some (opaque, _, t) ->
586 let params = x, y, w, h, tilex, tiley in
587 if conf.invert
588 then GlTex.env (`mode `blend);
589 drawtile params opaque;
590 if conf.invert
591 then GlTex.env (`mode `modulate);
592 if conf.debug
593 then (
594 endtiles ();
595 let s = Printf.sprintf
596 "%d[%d,%d] %f sec"
597 l.pageno col row t
599 let w = measurestr fstate.fontsize s in
600 GlDraw.color (0.0, 0.0, 0.0);
601 filledrect (float (x-2))
602 (float (y-2))
603 (float (x+2) +. w)
604 (float (y + fstate.fontsize + 2));
605 GlDraw.color color;
606 drawstring fstate.fontsize x (y + fstate.fontsize - 1) s;
607 begintiles ();
610 | None ->
611 endtiles ();
612 let w =
613 let lw = state.winw - x in
614 min lw w
615 and h =
616 let lh = state.winh - y in
617 min lh h
619 if conf.invert
620 then GlTex.env (`mode `blend);
621 begin match state.checkerstexid with
622 | Some id ->
623 Gl.enable `texture_2d;
624 GlTex.bind_texture ~target:`texture_2d id;
625 let x0 = float x
626 and y0 = float y
627 and x1 = float (x+w)
628 and y1 = float (y+h) in
630 let tw = float w /. 16.0
631 and th = float h /. 16.0 in
632 let tx0 = float tilex /. 16.0
633 and ty0 = float tiley /. 16.0 in
634 let tx1 = tx0 +. tw
635 and ty1 = ty0 +. th in
636 Raw.sets_float state.vraw ~pos:0
637 [| x0; y0; x0; y1; x1; y0; x1; y1 |];
638 Raw.sets_float state.traw ~pos:0
639 [| tx0; ty0; tx0; ty1; tx1; ty0; tx1; ty1 |];
640 GlArray.vertex `two state.vraw;
641 GlArray.tex_coord `two state.traw;
642 GlArray.draw_arrays `triangle_strip ~first:0 ~count:4;
643 Gl.disable `texture_2d;
645 | None ->
646 GlDraw.color (1.0, 1.0, 1.0);
647 filledrect (float x) (float y) (float (x+w)) (float (y+h));
648 end;
649 if conf.invert
650 then GlTex.env (`mode `modulate);
651 if w > 128 && h > fstate.fontsize + 10
652 then (
653 let c = if conf.invert then 1.0 else 0.0 in
654 GlDraw.color (c, c, c);
655 let c, r =
656 if conf.verbose
657 then (col*conf.tilew, row*conf.tileh)
658 else col, row
660 drawstring2 fstate.fontsize x y "Loading %d [%d,%d]" l.pageno c r;
662 GlDraw.color color;
663 begintiles ();
665 itertiles l f;
666 endtiles ();
669 let pagevisible layout n = List.exists (fun l -> l.pageno = n) layout;;
671 let tilevisible1 l x y =
672 let ax0 = l.pagex
673 and ax1 = l.pagex + l.pagevw
674 and ay0 = l.pagey
675 and ay1 = l.pagey + l.pagevh in
677 let bx0 = x
678 and by0 = y in
679 let bx1 = min (bx0 + conf.tilew) l.pagew
680 and by1 = min (by0 + conf.tileh) l.pageh in
682 let rx0 = max ax0 bx0
683 and ry0 = max ay0 by0
684 and rx1 = min ax1 bx1
685 and ry1 = min ay1 by1 in
687 let nonemptyintersection = rx1 > rx0 && ry1 > ry0 in
688 nonemptyintersection
691 let tilevisible layout n x y =
692 let rec findpageinlayout m = function
693 | l :: rest when l.pageno = n ->
694 tilevisible1 l x y || (
695 match conf.columns with
696 | Csplit (c, _) when c > m -> findpageinlayout (m+1) rest
697 | Csplit _ | Csingle _ | Cmulti _ -> false
699 | _ :: rest -> findpageinlayout 0 rest
700 | [] -> false
702 findpageinlayout 0 layout;
705 let tileready l x y =
706 tilevisible1 l x y &&
707 gettileopaque l (x/conf.tilew) (y/conf.tileh) != None
710 let tilepage n p layout =
711 let rec loop = function
712 | l :: rest ->
713 if l.pageno = n
714 then
715 let f col row _ _ _ _ _ _ =
716 if state.currently = Idle
717 then
718 match gettileopaque l col row with
719 | Some _ -> ()
720 | None ->
721 let x = col*conf.tilew
722 and y = row*conf.tileh in
723 let w =
724 let w = l.pagew - x in
725 min w conf.tilew
727 let h =
728 let h = l.pageh - y in
729 min h conf.tileh
731 let pbo =
732 if conf.usepbo
733 then getpbo w h conf.colorspace
734 else ~< "0"
736 wcmd "tile %s %d %d %d %d %s"
737 (~> p) x y w h (~> pbo);
738 state.currently <-
739 Tiling (
740 l, p, conf.colorspace, conf.angle,
741 state.gen, col, row, conf.tilew, conf.tileh
744 itertiles l f;
745 else
746 loop rest
748 | [] -> ()
750 if nogeomcmds state.geomcmds
751 then loop layout;
754 let preloadlayout x y sw sh =
755 let y = if y < sh then 0 else y - sh in
756 let x = min 0 (x + sw) in
757 let h = sh*3 in
758 let w = sw*3 in
759 layout x y w h;
762 let load pages =
763 let rec loop pages =
764 if state.currently != Idle
765 then ()
766 else
767 match pages with
768 | l :: rest ->
769 begin match getopaque l.pageno with
770 | None ->
771 wcmd "page %d %d" l.pageno l.pagedimno;
772 state.currently <- Loading (l, state.gen);
773 | Some opaque ->
774 tilepage l.pageno opaque pages;
775 loop rest
776 end;
777 | _ -> ()
779 if nogeomcmds state.geomcmds
780 then loop pages
783 let preload pages =
784 load pages;
785 if conf.preload && state.currently = Idle
786 then load (preloadlayout state.x state.y state.winw state.winh);
789 let layoutready layout =
790 let rec fold all ls =
791 all && match ls with
792 | l :: rest ->
793 let seen = ref false in
794 let allvisible = ref true in
795 let foo col row _ _ _ _ _ _ =
796 seen := true;
797 allvisible := !allvisible &&
798 begin match gettileopaque l col row with
799 | Some _ -> true
800 | None -> false
803 itertiles l foo;
804 fold (!seen && !allvisible) rest
805 | [] -> true
807 let alltilesvisible = fold true layout in
808 alltilesvisible;
811 let gotoxy x y =
812 let y = bound y 0 state.maxy in
813 let y, layout, proceed =
814 match conf.maxwait with
815 | Some time when state.ghyll == noghyll ->
816 begin match state.throttle with
817 | None ->
818 let layout = layout x y state.winw state.winh in
819 let ready = layoutready layout in
820 if not ready
821 then (
822 load layout;
823 state.throttle <- Some (layout, y, now ());
825 else G.postRedisplay "gotoxy showall (None)";
826 y, layout, ready
827 | Some (_, _, started) ->
828 let dt = now () -. started in
829 if dt > time
830 then (
831 state.throttle <- None;
832 let layout = layout x y state.winw state.winh in
833 load layout;
834 G.postRedisplay "maxwait";
835 y, layout, true
837 else -1, [], false
840 | _ ->
841 let layout = layout x y state.winw state.winh in
842 if not !wtmode || layoutready layout
843 then G.postRedisplay "gotoxy ready";
844 y, layout, true
846 if proceed
847 then (
848 state.x <- x;
849 state.y <- y;
850 state.layout <- layout;
851 begin match state.mode with
852 | LinkNav ln ->
853 begin match ln with
854 | Ltexact (pageno, linkno) ->
855 let rec loop = function
856 | [] ->
857 state.lnava <- Some (pageno, linkno);
858 state.mode <- LinkNav (Ltgendir 0)
859 | l :: _ when l.pageno = pageno ->
860 begin match getopaque pageno with
861 | None -> state.mode <- LinkNav (Ltnotready (pageno, 0))
862 | Some opaque ->
863 let x0, y0, x1, y1 = getlinkrect opaque linkno in
864 if not (x0 >= l.pagex && x1 <= l.pagex + l.pagevw
865 && y0 >= l.pagey && y1 <= l.pagey + l.pagevh)
866 then state.mode <- LinkNav (Ltgendir 0)
868 | _ :: rest -> loop rest
870 loop layout
871 | Ltnotready _ | Ltgendir _ -> ()
873 | Birdseye _ | Textentry _ | View -> ()
874 end;
875 begin match state.mode with
876 | Birdseye (conf, leftx, pageno, hooverpageno, anchor) ->
877 if not (pagevisible layout pageno)
878 then (
879 match state.layout with
880 | [] -> ()
881 | l :: _ ->
882 state.mode <- Birdseye (
883 conf, leftx, l.pageno, hooverpageno, anchor
886 | LinkNav lt ->
887 begin match lt with
888 | Ltnotready (_, dir)
889 | Ltgendir dir ->
890 let linknav =
891 let rec loop = function
892 | [] -> lt
893 | l :: rest ->
894 match getopaque l.pageno with
895 | None -> Ltnotready (l.pageno, dir)
896 | Some opaque ->
897 let link =
898 let ld =
899 if dir = 0
900 then LDfirstvisible (l.pagex, l.pagey, dir)
901 else (
902 if dir > 0 then LDfirst else LDlast
905 findlink opaque ld
907 match link with
908 | Lnotfound -> loop rest
909 | Lfound n ->
910 showlinktype (getlink opaque n);
911 Ltexact (l.pageno, n)
913 loop state.layout
915 state.mode <- LinkNav linknav
916 | Ltexact _ -> ()
918 | Textentry _ | View -> ()
919 end;
920 preload layout;
922 state.ghyll <- noghyll;
923 if conf.updatecurs
924 then (
925 let mx, my = state.mpos in
926 updateunder mx my;
930 let conttiling pageno opaque =
931 tilepage pageno opaque
932 (if conf.preload
933 then preloadlayout state.x state.y state.winw state.winh
934 else state.layout)
937 let gotoxy_and_clear_text x y =
938 if not conf.verbose then state.text <- E.s;
939 gotoxy x y;
942 let getanchory (n, top, dtop) =
943 let y, h = getpageyh n in
944 if conf.presentation
945 then
946 let ips = calcips h in
947 y + truncate (top*.float h -. dtop*.float ips) + ips;
948 else
949 y + truncate (top*.float h -. dtop*.float conf.interpagespace)
952 let gotoanchor anchor =
953 gotoxy state.x (getanchory anchor);
956 let addnav () =
957 cbput state.hists.nav (getanchor ());
960 let getnav dir =
961 let anchor = cbgetc state.hists.nav dir in
962 getanchory anchor;
965 let gotoghyll1 single y =
966 let scroll f n a b =
967 (* http://devmaster.net/forums/topic/9796-ease-in-ease-out-algorithm/ *)
968 let snake f a b =
969 let s x = 3.0*.x**2.0 -. 2.0*.x**3.0 in
970 if f < a
971 then s (float f /. float a)
972 else (
973 if f > b
974 then 1.0 -. s ((float (f-b) /. float (n-b)))
975 else 1.0
978 snake f a b
979 and summa n a b =
980 let ins = float a *. 0.5
981 and outs = float (n-b) *. 0.5 in
982 let ones = b - a in
983 ins +. outs +. float ones
985 let rec set nab y sy =
986 let (_N, _A, _B), y =
987 if single
988 then
989 let scl = if y > sy then 2 else -2 in
990 let _N, _, _ = nab in
991 (_N,0,_N), y+conf.scrollstep*scl
992 else nab,y in
993 let sum = summa _N _A _B in
994 let dy = float (y - sy) in
995 state.ghyll <- (
996 let rec gf n y1 o =
997 if n >= _N
998 then state.ghyll <- noghyll
999 else
1000 let go n =
1001 let s = scroll n _N _A _B in
1002 let y1 = y1 +. ((s *. dy) /. sum) in
1003 gotoxy_and_clear_text state.x (truncate y1);
1004 state.ghyll <- gf (n+1) y1;
1006 match o with
1007 | None -> go n
1008 | Some y' when single -> set nab y' state.y
1009 | Some y' -> set (_N/2, 1, 1) y' state.y
1011 gf 0 (float state.y)
1014 match conf.ghyllscroll with
1015 | Some nab when not conf.presentation ->
1016 if state.ghyll == noghyll
1017 then set nab y state.y
1018 else state.ghyll (Some y)
1019 | _ ->
1020 gotoxy_and_clear_text state.x y
1023 let gotoghyll = gotoghyll1 false;;
1025 let gotopage n top =
1026 let y, h = getpageyh n in
1027 let y = y + (truncate (top *. float h)) in
1028 gotoghyll y
1031 let gotopage1 n top =
1032 let y = getpagey n in
1033 let y = y + top in
1034 gotoghyll y
1037 let invalidate s f =
1038 state.redisplay <- false;
1039 state.layout <- [];
1040 state.pdims <- [];
1041 state.rects <- [];
1042 state.rects1 <- [];
1043 match state.geomcmds with
1044 | ps, [] when emptystr ps ->
1045 f ();
1046 state.geomcmds <- s, [];
1048 | ps, [] ->
1049 state.geomcmds <- ps, [s, f];
1051 | ps, (s', _) :: rest when s' = s ->
1052 state.geomcmds <- ps, ((s, f) :: rest);
1054 | ps, cmds ->
1055 state.geomcmds <- ps, ((s, f) :: cmds);
1058 let flushpages () =
1059 Hashtbl.iter (fun _ opaque ->
1060 wcmd "freepage %s" (~> opaque);
1061 ) state.pagemap;
1062 Hashtbl.clear state.pagemap;
1065 let flushtiles () =
1066 if not (Queue.is_empty state.tilelru)
1067 then (
1068 Queue.iter (fun (k, p, s) ->
1069 wcmd "freetile %s" (~> p);
1070 state.memused <- state.memused - s;
1071 Hashtbl.remove state.tilemap k;
1072 ) state.tilelru;
1073 state.uioh#infochanged Memused;
1074 Queue.clear state.tilelru;
1076 load state.layout;
1079 let stateh h =
1080 let h = truncate (float h*.conf.zoom) in
1081 let d = conf.interpagespace lsl (if conf.presentation then 1 else 0) in
1082 h - d
1085 let opendoc path password =
1086 state.path <- path;
1087 state.password <- password;
1088 state.gen <- state.gen + 1;
1089 state.docinfo <- [];
1090 state.outlines <- [||];
1092 flushpages ();
1093 setaalevel conf.aalevel;
1094 let titlepath =
1095 if emptystr state.origin
1096 then path
1097 else state.origin
1099 Wsi.settitle ("llpp " ^ (mbtoutf8 (Filename.basename titlepath)));
1100 wcmd "open %d %d %d %s\000%s\000%s\000"
1101 (btod !wtmode) (btod !cxack) (btod conf.usedoccss)
1102 path password conf.css;
1103 invalidate "reqlayout"
1104 (fun () ->
1105 wcmd "reqlayout %d %d %d %s\000"
1106 conf.angle (FMTE.to_int conf.fitmodel)
1107 (stateh state.winh) state.nameddest
1109 state.help <-
1110 let sl = keystostrlist conf in
1111 let rec loop accu =
1112 function | [] -> accu
1113 | s :: rest -> loop ((s, 0, Noaction) :: accu) rest
1114 in makehelp () @ (("", 0, Noaction) :: loop [] sl) |> Array.of_list
1117 let reload () =
1118 state.anchor <- getanchor ();
1119 opendoc state.path state.password;
1122 let scalecolor c =
1123 let c = c *. conf.colorscale in
1124 (c, c, c);
1127 let scalecolor2 (r, g, b) =
1128 (r *. conf.colorscale, g *. conf.colorscale, b *. conf.colorscale);
1131 let docolumns columns =
1132 match columns with
1133 | Csingle _ ->
1134 let a = Array.make state.pagecount (-1, -1, -1, (-1, -1, -1, -1)) in
1135 let rec loop pageno pdimno pdim y ph pdims =
1136 if pageno = state.pagecount
1137 then ()
1138 else
1139 let pdimno, ((_, w, h, xoff) as pdim), pdims =
1140 match pdims with
1141 | ((pageno', _, _, _) as pdim) :: rest when pageno' = pageno ->
1142 pdimno+1, pdim, rest
1143 | _ ->
1144 pdimno, pdim, pdims
1146 let x = max 0 (((state.winw - w) / 2) - xoff) in
1147 let y =
1148 y + (if conf.presentation
1149 then (if pageno = 0 then calcips h else calcips ph + calcips h)
1150 else (if pageno = 0 then 0 else conf.interpagespace)
1153 a.(pageno) <- (pdimno, x, y, pdim);
1154 loop (pageno+1) pdimno pdim (y + h) h pdims
1156 loop 0 ~-1 (-1,-1,-1,-1) 0 0 state.pdims;
1157 conf.columns <- Csingle a;
1159 | Cmulti ((columns, coverA, coverB), _) ->
1160 let a = Array.make state.pagecount (-1, -1, -1, (-1, -1, -1, -1)) in
1161 let rec loop pageno pdimno pdim x y rowh pdims =
1162 let rec fixrow m =
1163 if m = pageno then () else
1164 let (pdimno, x, y, ((_, _, h, _) as pdim)) = a.(m) in
1165 if h < rowh
1166 then (
1167 let y = y + (rowh - h) / 2 in
1168 a.(m) <- (pdimno, x, y, pdim);
1170 fixrow (m+1)
1172 if pageno = state.pagecount
1173 then fixrow (((pageno - 1) / columns) * columns)
1174 else
1175 let pdimno, ((_, w, h, xoff) as pdim), pdims =
1176 match pdims with
1177 | ((pageno', _, _, _) as pdim) :: rest when pageno' = pageno ->
1178 pdimno+1, pdim, rest
1179 | _ ->
1180 pdimno, pdim, pdims
1182 let x, y, rowh' =
1183 if pageno = coverA - 1 || pageno = state.pagecount - coverB
1184 then (
1185 let x = (state.winw - w) / 2 in
1186 let ips =
1187 if conf.presentation then calcips h else conf.interpagespace in
1188 x, y + ips + rowh, h
1190 else (
1191 if (pageno - coverA) mod columns = 0
1192 then (
1193 let x = max 0 (state.winw - state.w) / 2 in
1194 let y =
1195 if conf.presentation
1196 then
1197 let ips = calcips h in
1198 y + (if pageno = 0 then 0 else calcips rowh + ips)
1199 else
1200 y + (if pageno = 0 then 0 else conf.interpagespace)
1202 x, y + rowh, h
1204 else x, y, max rowh h
1207 let y =
1208 if pageno > 1 && (pageno - coverA) mod columns = 0
1209 then (
1210 let y =
1211 if pageno = columns && conf.presentation
1212 then (
1213 let ips = calcips rowh in
1214 for i = 0 to pred columns
1216 let (pdimno, x, y, pdim) = a.(i) in
1217 a.(i) <- (pdimno, x, y+ips, pdim)
1218 done;
1219 y+ips;
1221 else y
1223 fixrow (pageno - columns);
1226 else y
1228 a.(pageno) <- (pdimno, x, y, pdim);
1229 let x = x + w + xoff*2 + conf.interpagespace in
1230 loop (pageno+1) pdimno pdim x y rowh' pdims
1232 loop 0 ~-1 (-1,-1,-1,-1) 0 0 0 state.pdims;
1233 conf.columns <- Cmulti ((columns, coverA, coverB), a);
1235 | Csplit (c, _) ->
1236 let a = Array.make (state.pagecount*c) (-1, -1, -1, (-1, -1, -1, -1)) in
1237 let rec loop pageno pdimno pdim y pdims =
1238 if pageno = state.pagecount
1239 then ()
1240 else
1241 let pdimno, ((_, w, h, _) as pdim), pdims =
1242 match pdims with
1243 | ((pageno', _, _, _) as pdim) :: rest when pageno' = pageno ->
1244 pdimno+1, pdim, rest
1245 | _ ->
1246 pdimno, pdim, pdims
1248 let cw = w / c in
1249 let rec loop1 n x y =
1250 if n = c then y else (
1251 a.(pageno*c + n) <- (pdimno, x, y, pdim);
1252 loop1 (n+1) (x+cw) (y + h + conf.interpagespace)
1255 let y = loop1 0 0 y in
1256 loop (pageno+1) pdimno pdim y pdims
1258 loop 0 ~-1 (-1,-1,-1,-1) 0 state.pdims;
1259 conf.columns <- Csplit (c, a);
1262 let represent () =
1263 docolumns conf.columns;
1264 state.maxy <- calcheight ();
1265 if state.reprf == noreprf
1266 then (
1267 match state.mode with
1268 | Birdseye (_, _, pageno, _, _) ->
1269 let y, h = getpageyh pageno in
1270 let top = (state.winh - h) / 2 in
1271 gotoxy state.x (max 0 (y - top))
1272 | Textentry _ | View | LinkNav _ ->
1273 let y = getanchory state.anchor in
1274 let y = min y (state.maxy - state.winh) in
1275 gotoxy state.x y;
1277 else (
1278 state.reprf ();
1279 state.reprf <- noreprf;
1283 let reshape ?(firsttime=false) w h =
1284 GlDraw.viewport ~x:0 ~y:0 ~w ~h;
1285 if not firsttime && nogeomcmds state.geomcmds
1286 then state.anchor <- getanchor ();
1288 state.winw <- w;
1289 let w = truncate (float w *. conf.zoom) in
1290 let w = max w 2 in
1291 state.winh <- h;
1292 setfontsize fstate.fontsize;
1293 GlMat.mode `modelview;
1294 GlMat.load_identity ();
1296 GlMat.mode `projection;
1297 GlMat.load_identity ();
1298 GlMat.rotate ~x:1.0 ~angle:180.0 ();
1299 GlMat.translate ~x:~-.1.0 ~y:~-.1.0 ();
1300 GlMat.scale3 (2.0 /. float state.winw, 2.0 /. float state.winh, 1.0);
1302 let relx =
1303 if conf.zoom <= 1.0
1304 then 0.0
1305 else float state.x /. float state.w
1307 invalidate "geometry"
1308 (fun () ->
1309 state.w <- w;
1310 if not firsttime
1311 then state.x <- truncate (relx *. float w);
1312 let w =
1313 match conf.columns with
1314 | Csingle _ -> w
1315 | Cmulti ((c, _, _), _) -> (w - (c-1)*conf.interpagespace) / c
1316 | Csplit (c, _) -> w * c
1318 wcmd "geometry %d %d %d"
1319 w (stateh h) (FMTE.to_int conf.fitmodel)
1323 let enttext () =
1324 let len = String.length state.text in
1325 let x0 = if conf.leftscroll then vscrollw () else 0 in
1326 let drawstring s =
1327 let hscrollh =
1328 match state.mode with
1329 | Textentry _ | View | LinkNav _ ->
1330 let h, _, _ = state.uioh#scrollpw in
1332 | Birdseye _ -> 0
1334 let rect x w =
1335 filledrect
1336 x (float (state.winh - (fstate.fontsize + 4) - hscrollh))
1337 (x+.w) (float (state.winh - hscrollh))
1340 let w = float (state.winw - 1 - vscrollw ()) in
1341 if state.progress >= 0.0 && state.progress < 1.0
1342 then (
1343 GlDraw.color (0.3, 0.3, 0.3);
1344 let w1 = w *. state.progress in
1345 rect (float x0) w1;
1346 GlDraw.color (0.0, 0.0, 0.0);
1347 rect (float x0+.w1) (float x0+.w-.w1)
1349 else (
1350 GlDraw.color (0.0, 0.0, 0.0);
1351 rect (float x0) w;
1354 GlDraw.color (1.0, 1.0, 1.0);
1355 drawstring
1356 fstate.fontsize
1357 (if conf.leftscroll then x0 + 2 else x0 + if len > 0 then 8 else 2)
1358 (state.winh - hscrollh - 5) s;
1360 let s =
1361 match state.mode with
1362 | Textentry ((prefix, text, _, _, _, _), _) ->
1363 let s =
1364 if len > 0
1365 then Printf.sprintf "%s%s_ [%s]" prefix text state.text
1366 else Printf.sprintf "%s%s_" prefix text
1370 | Birdseye _ | View | LinkNav _ -> state.text
1372 let s =
1373 if state.newerrmsgs
1374 then (
1375 if not (istextentry state.mode) && state.uioh#eformsgs
1376 then
1377 let s1 = "(press 'e' to review error messasges)" in
1378 if nonemptystr s then s ^ " " ^ s1 else s1
1379 else s
1381 else s
1383 if nonemptystr s
1384 then drawstring s
1387 let gctiles () =
1388 let len = Queue.length state.tilelru in
1389 let layout = lazy (
1390 match state.throttle with
1391 | None ->
1392 if conf.preload
1393 then preloadlayout state.x state.y state.winw state.winh
1394 else state.layout
1395 | Some (layout, _, _) ->
1396 layout
1397 ) in
1398 let rec loop qpos =
1399 if state.memused > conf.memlimit
1400 then (
1401 if qpos < len
1402 then
1403 let (k, p, s) as lruitem = Queue.pop state.tilelru in
1404 let n, gen, colorspace, angle, pagew, pageh, col, row = k in
1405 let (_, pw, ph, _) = getpagedim n in
1406 if gen = state.gen
1407 && colorspace = conf.colorspace
1408 && angle = conf.angle
1409 && pagew = pw
1410 && pageh = ph
1411 && (
1412 let x = col*conf.tilew
1413 and y = row*conf.tileh in
1414 tilevisible (Lazy.force_val layout) n x y
1416 then Queue.push lruitem state.tilelru
1417 else (
1418 freepbo p;
1419 wcmd "freetile %s" (~> p);
1420 state.memused <- state.memused - s;
1421 state.uioh#infochanged Memused;
1422 Hashtbl.remove state.tilemap k;
1424 loop (qpos+1)
1427 loop 0
1430 let onpagerect pageno f =
1431 let b =
1432 match conf.columns with
1433 | Cmulti (_, b) -> b
1434 | Csingle b -> b
1435 | Csplit (_, b) -> b
1437 if pageno >= 0 && pageno < Array.length b
1438 then
1439 let (_, _, _, (_, w, h, _)) = b.(pageno) in
1440 f w h
1443 let gotopagexy1 wtmode pageno x y =
1444 let _,w1,h1,leftx = getpagedim pageno in
1445 let top = y /. (float h1) in
1446 let left = x /. (float w1) in
1447 let py, w, h = getpageywh pageno in
1448 let wh = state.winh in
1449 let x = left *. (float w) in
1450 let x = leftx + state.x + truncate x in
1451 let sx =
1452 if x < 0 || x >= state.winw
1453 then state.x - x
1454 else state.x
1456 let pdy = truncate (top *. float h) in
1457 let y' = py + pdy in
1458 let dy = y' - state.y in
1459 let sy =
1460 if x != state.x || not (dy > 0 && dy < wh)
1461 then (
1462 if conf.presentation
1463 then
1464 if abs (py - y') > wh
1465 then y'
1466 else py
1467 else y';
1469 else state.y
1471 if state.x != sx || state.y != sy
1472 then (
1473 let x, y =
1474 if wtmode
1475 then (
1476 let ww = state.winw in
1477 let qx = sx / ww
1478 and qy = pdy / wh in
1479 let x = qx * ww
1480 and y = py + qy * wh in
1481 let x = if -x + ww > w1 then -(w1-ww) else x
1482 and y' = if y + wh > state.maxy then state.maxy - wh else y in
1483 let y =
1484 if conf.presentation
1485 then
1486 if abs (py - y') > wh
1487 then y'
1488 else py
1489 else y';
1491 (x, y)
1493 else (sx, sy)
1495 gotoxy_and_clear_text x y;
1497 else gotoxy_and_clear_text state.x state.y;
1500 let gotopagexy wtmode pageno x y =
1501 match state.mode with
1502 | Birdseye _ -> gotopage pageno 0.0
1503 | Textentry _ | View | LinkNav _ -> gotopagexy1 wtmode pageno x y
1506 let getpassword () =
1507 let passcmd = getenvwithdef "LLPP_ASKPASS" conf.passcmd in
1508 if emptystr passcmd
1509 then E.s
1510 else getcmdoutput
1511 (fun s ->
1512 impmsg "error getting password: %s" s;
1513 dolog "%s" s) passcmd;
1516 let pgoto opaque pageno x y =
1517 let pdimno = getpdimno pageno in
1518 let x, y = project opaque pageno pdimno x y in
1519 gotopagexy false pageno x y;
1522 let act cmds =
1523 (* dolog "%S" cmds; *)
1524 let spl = splitatchar cmds ' ' in
1525 let scan s fmt f =
1526 try Scanf.sscanf s fmt f
1527 with exn ->
1528 dolog "error processing '%S': %s" cmds @@ exntos exn;
1529 exit 1
1531 let addoutline outline =
1532 match state.currently with
1533 | Outlining outlines -> state.currently <- Outlining (outline :: outlines)
1534 | Idle -> state.currently <- Outlining [outline]
1535 | Loading _ | Tiling _ ->
1536 dolog "invalid outlining state";
1537 logcurrently state.currently
1539 match spl with
1540 | "clear", "" ->
1541 state.pdims <- [];
1542 state.uioh#infochanged Pdim;
1544 | "clearrects", "" ->
1545 state.rects <- state.rects1;
1546 G.postRedisplay "clearrects";
1548 | "continue", args ->
1549 let n = scan args "%u" (fun n -> n) in
1550 state.pagecount <- n;
1551 begin match state.currently with
1552 | Outlining l ->
1553 state.currently <- Idle;
1554 state.outlines <- Array.of_list (List.rev l)
1555 | Idle | Loading _ | Tiling _ -> ()
1556 end;
1558 let cur, cmds = state.geomcmds in
1559 if emptystr cur
1560 then failwith "umpossible";
1562 begin match List.rev cmds with
1563 | [] ->
1564 state.geomcmds <- E.s, [];
1565 state.throttle <- None;
1566 represent ();
1567 | (s, f) :: rest ->
1568 f ();
1569 state.geomcmds <- s, List.rev rest;
1570 end;
1571 if conf.maxwait = None && not !wtmode
1572 then G.postRedisplay "continue";
1574 | "msg", args ->
1575 showtext ' ' args
1577 | "vmsg", args ->
1578 if conf.verbose
1579 then showtext ' ' args
1581 | "emsg", args ->
1582 Buffer.add_string state.errmsgs args;
1583 state.newerrmsgs <- true;
1584 G.postRedisplay "error message"
1586 | "progress", args ->
1587 let progress, text =
1588 scan args "%f %n"
1589 (fun f pos ->
1590 f, String.sub args pos (String.length args - pos))
1592 state.text <- text;
1593 state.progress <- progress;
1594 G.postRedisplay "progress"
1596 | "firstmatch", args ->
1597 let pageno, c, x0, y0, x1, y1, x2, y2, x3, y3 =
1598 scan args "%u %d %f %f %f %f %f %f %f %f"
1599 (fun p c x0 y0 x1 y1 x2 y2 x3 y3 ->
1600 (p, c, x0, y0, x1, y1, x2, y2, x3, y3))
1602 let y = (getpagey pageno) + truncate y0 in
1603 let x =
1604 if conf.zoom > 1.0
1605 then state.winw/2
1606 else state.x
1608 addnav ();
1609 gotoxy x y;
1610 let color = (0.0, 0.0, 1.0 /. float c, 0.5) in
1611 state.rects1 <- [pageno, color, (x0, y0, x1, y1, x2, y2, x3, y3)]
1613 | "match", args ->
1614 let pageno, c, x0, y0, x1, y1, x2, y2, x3, y3 =
1615 scan args "%u %d %f %f %f %f %f %f %f %f"
1616 (fun p c x0 y0 x1 y1 x2 y2 x3 y3 ->
1617 (p, c, x0, y0, x1, y1, x2, y2, x3, y3))
1619 let color = (0.0, 0.0, 1.0 /. float c, 0.5) in
1620 state.rects1 <-
1621 (pageno, color, (x0, y0, x1, y1, x2, y2, x3, y3)) :: state.rects1
1623 | "page", args ->
1624 let pageopaques, t = scan args "%s %f" (fun p t -> p, t) in
1625 let pageopaque = ~< pageopaques in
1626 begin match state.currently with
1627 | Loading (l, gen) ->
1628 vlog "page %d took %f sec" l.pageno t;
1629 Hashtbl.replace state.pagemap (l.pageno, gen) pageopaque;
1630 begin match state.throttle with
1631 | None ->
1632 let preloadedpages =
1633 if conf.preload
1634 then preloadlayout state.x state.y state.winw state.winh
1635 else state.layout
1637 let evict () =
1638 let set =
1639 List.fold_left (fun s l -> IntSet.add l.pageno s)
1640 IntSet.empty preloadedpages
1642 let evictedpages =
1643 Hashtbl.fold (fun ((pageno, _) as key) opaque accu ->
1644 if not (IntSet.mem pageno set)
1645 then (
1646 wcmd "freepage %s" (~> opaque);
1647 key :: accu
1649 else accu
1650 ) state.pagemap []
1652 List.iter (Hashtbl.remove state.pagemap) evictedpages;
1654 evict ();
1655 state.currently <- Idle;
1656 if gen = state.gen
1657 then (
1658 tilepage l.pageno pageopaque state.layout;
1659 load state.layout;
1660 load preloadedpages;
1661 let visible = pagevisible state.layout l.pageno in
1662 if visible
1663 then (
1664 match state.mode with
1665 | LinkNav (Ltnotready (pageno, dir)) ->
1666 if pageno = l.pageno
1667 then (
1668 let link =
1669 let ld =
1670 if dir = 0
1671 then LDfirstvisible (l.pagex, l.pagey, dir)
1672 else (
1673 if dir > 0 then LDfirst else LDlast
1676 findlink pageopaque ld
1678 match link with
1679 | Lnotfound -> ()
1680 | Lfound n ->
1681 showlinktype (getlink pageopaque n);
1682 state.mode <- LinkNav (Ltexact (l.pageno, n))
1684 | LinkNav (Ltgendir _)
1685 | LinkNav (Ltexact _)
1686 | View
1687 | Birdseye _
1688 | Textentry _ -> ()
1691 if visible && layoutready state.layout
1692 then (
1693 G.postRedisplay "page";
1697 | Some (layout, _, _) ->
1698 state.currently <- Idle;
1699 tilepage l.pageno pageopaque layout;
1700 load state.layout
1701 end;
1703 | Idle | Tiling _ | Outlining _ ->
1704 dolog "Inconsistent loading state";
1705 logcurrently state.currently;
1706 exit 1
1709 | "tile" , args ->
1710 let (x, y, opaques, size, t) =
1711 scan args "%u %u %s %u %f"
1712 (fun x y p size t -> (x, y, p, size, t))
1714 let opaque = ~< opaques in
1715 begin match state.currently with
1716 | Tiling (l, pageopaque, cs, angle, gen, col, row, tilew, tileh) ->
1717 vlog "tile %d [%d,%d] took %f sec" l.pageno col row t;
1719 unmappbo opaque;
1720 if tilew != conf.tilew || tileh != conf.tileh
1721 then (
1722 wcmd "freetile %s" (~> opaque);
1723 state.currently <- Idle;
1724 load state.layout;
1726 else (
1727 puttileopaque l col row gen cs angle opaque size t;
1728 state.memused <- state.memused + size;
1729 state.uioh#infochanged Memused;
1730 gctiles ();
1731 Queue.push ((l.pageno, gen, cs, angle, l.pagew, l.pageh, col, row),
1732 opaque, size) state.tilelru;
1734 let layout =
1735 match state.throttle with
1736 | None -> state.layout
1737 | Some (layout, _, _) -> layout
1740 state.currently <- Idle;
1741 if gen = state.gen
1742 && conf.colorspace = cs
1743 && conf.angle = angle
1744 && tilevisible layout l.pageno x y
1745 then conttiling l.pageno pageopaque;
1747 begin match state.throttle with
1748 | None ->
1749 preload state.layout;
1750 if gen = state.gen
1751 && conf.colorspace = cs
1752 && conf.angle = angle
1753 && tilevisible state.layout l.pageno x y
1754 && (not !wtmode || layoutready state.layout)
1755 then G.postRedisplay "tile nothrottle";
1757 | Some (layout, y, _) ->
1758 let ready = layoutready layout in
1759 if ready
1760 then (
1761 state.y <- y;
1762 state.layout <- layout;
1763 state.throttle <- None;
1764 G.postRedisplay "throttle";
1766 else load layout;
1767 end;
1770 | Idle | Loading _ | Outlining _ ->
1771 dolog "Inconsistent tiling state";
1772 logcurrently state.currently;
1773 exit 1
1776 | "pdim", args ->
1777 let (n, w, h, _) as pdim =
1778 scan args "%u %u %u %u" (fun n w h x -> n, w, h, x)
1780 let pdim =
1781 match conf.fitmodel with
1782 | FitWidth -> pdim
1783 | FitPage | FitProportional ->
1784 match conf.columns with
1785 | Csplit _ -> (n, w, h, 0)
1786 | Csingle _ | Cmulti _ -> pdim
1788 state.pdims <- pdim :: state.pdims;
1789 state.uioh#infochanged Pdim
1791 | "o", args ->
1792 let (l, n, t, h, pos) =
1793 scan args "%u %u %d %u %n"
1794 (fun l n t h pos -> l, n, t, h, pos)
1796 let s = String.sub args pos (String.length args - pos) in
1797 addoutline (s, l, Oanchor (n, float t /. float h, 0.0))
1799 | "ou", args ->
1800 let (l, len, pos) = scan args "%u %u %n" (fun l len pos -> l, len, pos) in
1801 let s = String.sub args pos len in
1802 let pos2 = pos + len + 1 in
1803 let uri = String.sub args pos2 (String.length args - pos2) in
1804 addoutline (s, l, Ouri uri)
1806 | "on", args ->
1807 let (l, pos) = scan args "%u %n" (fun l pos -> l, pos) in
1808 let s = String.sub args pos (String.length args - pos) in
1809 addoutline (s, l, Onone)
1811 | "a", args ->
1812 let (n, l, t) =
1813 scan args "%u %d %d" (fun n l t -> n, l, t)
1815 state.reprf <- (fun () -> gotopagexy !wtmode n (float l) (float t))
1817 | "info", args ->
1818 let c, v = splitatchar args '\t' in
1819 let s =
1820 if nonemptystr v
1821 then
1822 if c = "Title"
1823 then (
1824 conf.title <- v;
1825 Wsi.settitle v;
1826 args
1828 else
1829 if let len = String.length c in
1830 len > 6 && ((String.sub c (len-4) 4) = "date")
1831 then (
1832 if String.length v >= 7 && v.[0] = 'D' && v.[1] = ':'
1833 then
1834 let b = Buffer.create 10 in
1835 Printf.bprintf b "%s\t" c;
1836 let sub p l c =
1838 Buffer.add_substring b v p l;
1839 Buffer.add_char b c;
1840 with exn -> Buffer.add_string b @@ exntos exn
1842 sub 2 4 '/';
1843 sub 6 2 '/';
1844 sub 8 2 ' ';
1845 sub 10 2 ':';
1846 sub 12 2 ':';
1847 sub 14 2 ' ';
1848 Buffer.add_char b '[';
1849 Buffer.add_string b v;
1850 Buffer.add_char b ']';
1851 Buffer.contents b
1852 else args
1854 else args
1855 else args
1857 state.docinfo <- (1, s) :: state.docinfo
1859 | "infoend", "" ->
1860 state.docinfo <- List.rev state.docinfo;
1861 state.uioh#infochanged Docinfo
1863 | "pass", args ->
1864 if args = "fail"
1865 then Wsi.settitle "Wrong password";
1866 let password = getpassword () in
1867 if emptystr password
1868 then error "document is password protected"
1869 else opendoc state.path password
1871 | _ ->
1872 error "unknown cmd `%S'" cmds
1875 let onhist cb =
1876 let rc = cb.rc in
1877 let action = function
1878 | HCprev -> cbget cb ~-1
1879 | HCnext -> cbget cb 1
1880 | HCfirst -> cbget cb ~-(cb.rc)
1881 | HClast -> cbget cb (cb.len - 1 - cb.rc)
1882 and cancel () = cb.rc <- rc
1883 in (action, cancel)
1886 let search pattern forward =
1887 match conf.columns with
1888 | Csplit _ -> impmsg "searching does not work properly in split columns mode"
1889 | Csingle _ | Cmulti _ ->
1890 if nonemptystr pattern
1891 then
1892 let pn, py =
1893 match state.layout with
1894 | [] -> 0, 0
1895 | l :: _ ->
1896 l.pageno, (l.pagey + if forward then 0 else 0*l.pagevh)
1898 wcmd "search %d %d %d %d,%s\000"
1899 (btod conf.icase) pn py (btod forward) pattern;
1902 let [@warning "-4"] intentry text key =
1903 let text =
1904 match key with
1905 | Keys.Ascii ('0'..'9' as c) -> addchar text c
1906 | _ ->
1907 state.text <- "invalid key";
1908 text
1910 TEcont text
1913 let linknact f s =
1914 if nonemptystr s
1915 then (
1916 let n =
1917 let l = String.length s in
1918 let rec loop pos n =
1919 if pos = l
1920 then n
1921 else
1922 let m = Char.code s.[pos] - (if pos = 0 && l > 1 then 96 else 97) in
1923 loop (pos+1) (n*26 + m)
1924 in loop 0 0
1926 let rec loop n = function
1927 | [] -> ()
1928 | l :: rest ->
1929 match getopaque l.pageno with
1930 | None -> loop n rest
1931 | Some opaque ->
1932 let m = getlinkcount opaque in
1933 if n < m
1934 then (
1935 let under = getlink opaque n in
1936 f under
1938 else loop (n-m) rest
1940 loop n state.layout;
1944 let [@warning "-4"] linknentry text = function
1945 | Keys.Ascii c ->
1946 let text = addchar text c in
1947 linknact (fun under -> state.text <- undertext under) text;
1948 TEcont text
1949 | _ ->
1950 state.text <- Printf.sprintf "invalid key";
1951 TEcont text
1954 let [@warning "-4"] textentry text = function
1955 | Keys.Ascii c -> TEcont (addchar text c)
1956 | Keys.Code c -> TEcont (text ^ toutf8 c)
1957 | _ -> TEcont text
1960 let reqlayout angle fitmodel =
1961 match state.throttle with
1962 | None ->
1963 if nogeomcmds state.geomcmds
1964 then state.anchor <- getanchor ();
1965 conf.angle <- angle mod 360;
1966 if conf.angle != 0
1967 then (
1968 match state.mode with
1969 | LinkNav _ -> state.mode <- View
1970 | Birdseye _ | Textentry _ | View -> ()
1972 conf.fitmodel <- fitmodel;
1973 invalidate
1974 "reqlayout"
1975 (fun () ->
1976 wcmd "reqlayout %d %d %d"
1977 conf.angle (FMTE.to_int conf.fitmodel) (stateh state.winh)
1979 | _ -> ()
1982 let settrim trimmargins trimfuzz =
1983 if nogeomcmds state.geomcmds
1984 then state.anchor <- getanchor ();
1985 conf.trimmargins <- trimmargins;
1986 conf.trimfuzz <- trimfuzz;
1987 let x0, y0, x1, y1 = trimfuzz in
1988 invalidate
1989 "settrim" (fun () ->
1990 wcmd "settrim %d %d %d %d %d" (btod conf.trimmargins) x0 y0 x1 y1);
1991 flushpages ();
1994 let setzoom zoom =
1995 match state.throttle with
1996 | None ->
1997 let zoom = max 0.0001 zoom in
1998 if zoom <> conf.zoom
1999 then (
2000 state.prevzoom <- (conf.zoom, state.x);
2001 conf.zoom <- zoom;
2002 reshape state.winw state.winh;
2003 state.text <- Printf.sprintf "zoom is now %-5.2f" (zoom *. 100.0);
2006 | Some (layout, y, started) ->
2007 let time =
2008 match conf.maxwait with
2009 | None -> 0.0
2010 | Some t -> t
2012 let dt = now () -. started in
2013 if dt > time
2014 then (
2015 state.y <- y;
2016 load layout;
2020 let pivotzoom ?(vw=min state.w state.winw)
2021 ?(vh=min (state.maxy-state.y) state.winh)
2022 ?(x=vw/2) ?(y=vh/2) zoom =
2023 let w = float state.w /. zoom in
2024 let hw = w /. 2.0 in
2025 let ratio = float vh /. float vw in
2026 let hh = hw *. ratio in
2027 let x0 = if zoom < 1.0 then 0.0 else float x -. hw in
2028 let y0 = float y -. hh in
2029 gotoxy (state.x - truncate x0) (state.y + truncate y0);
2030 setzoom zoom;
2033 let pivotzoom ?vw ?vh ?x ?y zoom =
2034 if nogeomcmds state.geomcmds then pivotzoom ?vw ?vh ?x ?y zoom
2037 let setcolumns mode columns coverA coverB =
2038 state.prevcolumns <- Some (conf.columns, conf.zoom);
2039 if columns < 0
2040 then (
2041 if isbirdseye mode
2042 then impmsg "split mode doesn't work in bird's eye"
2043 else (
2044 conf.columns <- Csplit (-columns, E.a);
2045 state.x <- 0;
2046 conf.zoom <- 1.0;
2049 else (
2050 if columns < 2
2051 then (
2052 conf.columns <- Csingle E.a;
2053 state.x <- 0;
2054 setzoom 1.0;
2056 else (
2057 conf.columns <- Cmulti ((columns, coverA, coverB), E.a);
2058 conf.zoom <- 1.0;
2061 reshape state.winw state.winh;
2064 let resetmstate () =
2065 state.mstate <- Mnone;
2066 Wsi.setcursor Wsi.CURSOR_INHERIT;
2069 let enterbirdseye () =
2070 let zoom = float conf.thumbw /. float state.winw in
2071 let birdseyepageno =
2072 let cy = state.winh / 2 in
2073 let fold = function
2074 | [] -> 0
2075 | l :: rest ->
2076 let rec fold best = function
2077 | [] -> best.pageno
2078 | l :: rest ->
2079 let d = cy - (l.pagedispy + l.pagevh/2)
2080 and dbest = cy - (best.pagedispy + best.pagevh/2) in
2081 if abs d < abs dbest
2082 then fold l rest
2083 else best.pageno
2084 in fold l rest
2086 fold state.layout
2088 state.mode <-
2089 Birdseye (
2090 { conf with zoom = conf.zoom },
2091 state.x, birdseyepageno, -1, getanchor ()
2093 resetmstate ();
2094 conf.zoom <- zoom;
2095 conf.presentation <- false;
2096 conf.interpagespace <- 10;
2097 conf.hlinks <- false;
2098 conf.fitmodel <- FitPage;
2099 state.x <- 0;
2100 conf.maxwait <- None;
2101 conf.columns <- (
2102 match conf.beyecolumns with
2103 | Some c ->
2104 conf.zoom <- 1.0;
2105 Cmulti ((c, 0, 0), E.a)
2106 | None -> Csingle E.a
2108 if conf.verbose
2109 then
2110 state.text <- Printf.sprintf "birds eye mode on (zoom %3.1f%%)"
2111 (100.0*.zoom)
2112 else
2113 state.text <- E.s
2115 reshape state.winw state.winh;
2118 let leavebirdseye (c, leftx, pageno, _, anchor) goback =
2119 state.mode <- View;
2120 conf.zoom <- c.zoom;
2121 conf.presentation <- c.presentation;
2122 conf.interpagespace <- c.interpagespace;
2123 conf.maxwait <- c.maxwait;
2124 conf.hlinks <- c.hlinks;
2125 conf.fitmodel <- c.fitmodel;
2126 conf.beyecolumns <- (
2127 match conf.columns with
2128 | Cmulti ((c, _, _), _) -> Some c
2129 | Csingle _ -> None
2130 | Csplit _ -> failwith "leaving bird's eye split mode"
2132 conf.columns <- (
2133 match c.columns with
2134 | Cmulti (c, _) -> Cmulti (c, E.a)
2135 | Csingle _ -> Csingle E.a
2136 | Csplit (c, _) -> Csplit (c, E.a)
2138 if conf.verbose
2139 then
2140 state.text <- Printf.sprintf "birds eye mode off (zoom %3.1f%%)"
2141 (100.0*.conf.zoom)
2143 reshape state.winw state.winh;
2144 state.anchor <- if goback then anchor else (pageno, 0.0, 1.0);
2145 state.x <- leftx;
2148 let togglebirdseye () =
2149 match state.mode with
2150 | Birdseye vals -> leavebirdseye vals true
2151 | View -> enterbirdseye ()
2152 | Textentry _ | LinkNav _ -> ()
2155 let upbirdseye incr (conf, leftx, pageno, hooverpageno, anchor) =
2156 let pageno = max 0 (pageno - incr) in
2157 let rec loop = function
2158 | [] -> gotopage1 pageno 0
2159 | l :: _ when l.pageno = pageno ->
2160 if l.pagedispy >= 0 && l.pagey = 0
2161 then G.postRedisplay "upbirdseye"
2162 else gotopage1 pageno 0
2163 | _ :: rest -> loop rest
2165 loop state.layout;
2166 state.text <- E.s;
2167 state.mode <- Birdseye (conf, leftx, pageno, hooverpageno, anchor)
2170 let downbirdseye incr (conf, leftx, pageno, hooverpageno, anchor) =
2171 let pageno = min (state.pagecount - 1) (pageno + incr) in
2172 state.mode <- Birdseye (conf, leftx, pageno, hooverpageno, anchor);
2173 let rec loop = function
2174 | [] ->
2175 let y, h = getpageyh pageno in
2176 let dy = (y - state.y) - (state.winh - h - conf.interpagespace) in
2177 gotoxy state.x (clamp dy)
2178 | l :: _ when l.pageno = pageno ->
2179 if l.pagevh != l.pageh
2180 then gotoxy state.x (clamp (l.pageh - l.pagevh + conf.interpagespace))
2181 else G.postRedisplay "downbirdseye"
2182 | _ :: rest -> loop rest
2184 loop state.layout;
2185 state.text <- E.s;
2188 let [@warning "-4"] optentry mode _ key =
2189 let btos b = if b then "on" else "off" in
2190 match key with
2191 | Keys.Ascii 's' ->
2192 let ondone s =
2193 try conf.scrollstep <- int_of_string s with exn ->
2194 state.text <- Printf.sprintf "bad integer `%s': %s" s @@ exntos exn
2196 TEswitch ("scroll step: ", E.s, None, intentry, ondone, true)
2198 | Keys.Ascii 'A' ->
2199 let ondone s =
2201 conf.autoscrollstep <- boundastep state.winh (int_of_string s);
2202 if state.autoscroll <> None
2203 then state.autoscroll <- Some conf.autoscrollstep
2204 with exn ->
2205 state.text <- Printf.sprintf "bad integer `%s': %s" s @@ exntos exn
2207 TEswitch ("auto scroll step: ", E.s, None, intentry, ondone, true)
2209 | Keys.Ascii 'C' ->
2210 let ondone s =
2212 let n, a, b = multicolumns_of_string s in
2213 setcolumns mode n a b;
2214 with exn ->
2215 state.text <- Printf.sprintf "bad columns `%s': %s" s @@ exntos exn
2217 TEswitch ("columns: ", E.s, None, textentry, ondone, true)
2219 | Keys.Ascii 'Z' ->
2220 let ondone s =
2222 let zoom = float (int_of_string s) /. 100.0 in
2223 pivotzoom zoom
2224 with exn ->
2225 state.text <- Printf.sprintf "bad integer `%s': %s" s @@ exntos exn
2227 TEswitch ("zoom: ", E.s, None, intentry, ondone, true)
2229 | Keys.Ascii 't' ->
2230 let ondone s =
2232 conf.thumbw <- bound (int_of_string s) 2 4096;
2233 state.text <-
2234 Printf.sprintf "thumbnail width is set to %d" conf.thumbw;
2235 begin match mode with
2236 | Birdseye beye ->
2237 leavebirdseye beye false;
2238 enterbirdseye ();
2239 | Textentry _ | View | LinkNav _ -> ();
2241 with exn ->
2242 state.text <- Printf.sprintf "bad integer `%s': %s" s @@ exntos exn
2244 TEswitch ("thumbnail width: ", E.s, None, intentry, ondone, true)
2246 | Keys.Ascii 'R' ->
2247 let ondone s =
2248 match int_of_string s with
2249 | angle -> reqlayout angle conf.fitmodel
2250 | exception exn ->
2251 state.text <- Printf.sprintf "bad integer `%s': %s" s @@ exntos exn
2253 TEswitch ("rotation: ", E.s, None, intentry, ondone, true)
2255 | Keys.Ascii 'i' ->
2256 conf.icase <- not conf.icase;
2257 TEdone ("case insensitive search " ^ (btos conf.icase))
2259 | Keys.Ascii 'p' ->
2260 conf.preload <- not conf.preload;
2261 gotoxy state.x state.y;
2262 TEdone ("preload " ^ (btos conf.preload))
2264 | Keys.Ascii 'v' ->
2265 conf.verbose <- not conf.verbose;
2266 TEdone ("verbose " ^ (btos conf.verbose))
2268 | Keys.Ascii 'd' ->
2269 conf.debug <- not conf.debug;
2270 TEdone ("debug " ^ (btos conf.debug))
2272 | Keys.Ascii 'h' ->
2273 conf.maxhfit <- not conf.maxhfit;
2274 state.maxy <- calcheight ();
2275 TEdone ("maxhfit " ^ (btos conf.maxhfit))
2277 | Keys.Ascii 'c' ->
2278 conf.crophack <- not conf.crophack;
2279 TEdone ("crophack " ^ btos conf.crophack)
2281 | Keys.Ascii 'a' ->
2282 let s =
2283 match conf.maxwait with
2284 | None ->
2285 conf.maxwait <- Some infinity;
2286 "always wait for page to complete"
2287 | Some _ ->
2288 conf.maxwait <- None;
2289 "show placeholder if page is not ready"
2291 TEdone s
2293 | Keys.Ascii 'f' ->
2294 conf.underinfo <- not conf.underinfo;
2295 TEdone ("underinfo " ^ btos conf.underinfo)
2297 | Keys.Ascii 'P' ->
2298 conf.savebmarks <- not conf.savebmarks;
2299 TEdone ("persistent bookmarks " ^ btos conf.savebmarks)
2301 | Keys.Ascii 'S' ->
2302 let ondone s =
2304 let pageno, py =
2305 match state.layout with
2306 | [] -> 0, 0
2307 | l :: _ ->
2308 l.pageno, l.pagey
2310 conf.interpagespace <- int_of_string s;
2311 docolumns conf.columns;
2312 state.maxy <- calcheight ();
2313 let y = getpagey pageno in
2314 gotoxy state.x (y + py)
2315 with exn ->
2316 state.text <- Printf.sprintf "bad integer `%s': %s" s @@ exntos exn
2318 TEswitch ("vertical margin: ", E.s, None, intentry, ondone, true)
2320 | Keys.Ascii 'l' ->
2321 let fm =
2322 match conf.fitmodel with
2323 | FitProportional -> FitWidth
2324 | FitWidth | FitPage -> FitProportional
2326 reqlayout conf.angle fm;
2327 TEdone ("proportional display " ^ btos (fm == FitProportional))
2329 | Keys.Ascii 'T' ->
2330 settrim (not conf.trimmargins) conf.trimfuzz;
2331 TEdone ("trim margins " ^ btos conf.trimmargins)
2333 | Keys.Ascii 'I' ->
2334 conf.invert <- not conf.invert;
2335 TEdone ("invert colors " ^ btos conf.invert)
2337 | Keys.Ascii 'x' ->
2338 let ondone s =
2339 cbput state.hists.sel s;
2340 conf.selcmd <- s;
2342 TEswitch ("selection command: ", E.s, Some (onhist state.hists.sel),
2343 textentry, ondone, true)
2345 | Keys.Ascii 'M' ->
2346 if conf.pax == None
2347 then conf.pax <- Some (ref (0.0, 0, 0))
2348 else conf.pax <- None;
2349 TEdone ("PAX " ^ btos (conf.pax != None))
2351 | (Keys.Ascii c) ->
2352 state.text <- Printf.sprintf "bad option %d `%c'"
2353 (Char.code c) c;
2354 TEstop
2356 | _ ->
2357 TEcont state.text
2360 class type lvsource =
2361 object
2362 method getitemcount : int
2363 method getitem : int -> (string * int)
2364 method hasaction : int -> bool
2365 method exit : uioh:uioh ->
2366 cancel:bool ->
2367 active:int ->
2368 first:int ->
2369 pan:int ->
2370 uioh option
2371 method getactive : int
2372 method getfirst : int
2373 method getpan : int
2374 method getminfo : (int * int) array
2375 end;;
2377 class virtual lvsourcebase = object
2378 val mutable m_active = 0
2379 val mutable m_first = 0
2380 val mutable m_pan = 0
2381 method getactive = m_active
2382 method getfirst = m_first
2383 method getpan = m_pan
2384 method getminfo : (int * int) array = E.a
2385 end;;
2387 let [@warning "-4"] textentrykeyboard
2388 key _mask ((c, text, opthist, onkey, ondone, cancelonempty), onleave) =
2389 state.text <- E.s;
2390 let enttext te =
2391 state.mode <- Textentry (te, onleave);
2392 enttext ();
2393 G.postRedisplay "textentrykeyboard enttext";
2395 let histaction cmd =
2396 match opthist with
2397 | None -> ()
2398 | Some (action, _) ->
2399 state.mode <-
2400 Textentry (
2401 (c, action cmd, opthist, onkey, ondone, cancelonempty), onleave
2403 G.postRedisplay "textentry histaction"
2405 let open Keys in let kt = Wsi.kc2kt key in
2406 match kt with
2407 | Backspace ->
2408 if emptystr text && cancelonempty
2409 then (
2410 onleave Cancel;
2411 G.postRedisplay "textentrykeyboard after cancel";
2413 else
2414 let s = withoutlastutf8 text in
2415 enttext (c, s, opthist, onkey, ondone, cancelonempty)
2417 | Enter ->
2418 ondone text;
2419 onleave Confirm;
2420 G.postRedisplay "textentrykeyboard after confirm"
2422 | Up -> histaction HCprev
2423 | Down -> histaction HCnext
2424 | Home -> histaction HCfirst
2425 | End -> histaction HClast
2427 | Escape ->
2428 if emptystr text
2429 then (
2430 begin match opthist with
2431 | None -> ()
2432 | Some (_, onhistcancel) -> onhistcancel ()
2433 end;
2434 onleave Cancel;
2435 state.text <- E.s;
2436 G.postRedisplay "textentrykeyboard after cancel2"
2438 else (
2439 enttext (c, E.s, opthist, onkey, ondone, cancelonempty)
2442 | Delete -> ()
2444 | Code _ | Ascii _ ->
2445 begin match onkey text kt with
2446 | TEdone text ->
2447 ondone text;
2448 onleave Confirm;
2449 G.postRedisplay "textentrykeyboard after confirm2";
2451 | TEcont text ->
2452 enttext (c, text, opthist, onkey, ondone, cancelonempty);
2454 | TEstop ->
2455 onleave Cancel;
2456 G.postRedisplay "textentrykeyboard after cancel3"
2458 | TEswitch te ->
2459 state.mode <- Textentry (te, onleave);
2460 G.postRedisplay "textentrykeyboard switch";
2462 | _ -> vlog "unhandled key"
2465 let firstof first active =
2466 if first > active || abs (first - active) > fstate.maxrows - 1
2467 then max 0 (active - (fstate.maxrows/2))
2468 else first
2471 let calcfirst first active =
2472 if active > first
2473 then
2474 let rows = active - first in
2475 if rows > fstate.maxrows then active - fstate.maxrows else first
2476 else active
2479 let scrollph y maxy =
2480 let sh = float (maxy + state.winh) /. float state.winh in
2481 let sh = float state.winh /. sh in
2482 let sh = max sh (float conf.scrollh) in
2484 let percent = float y /. float maxy in
2485 let position = (float state.winh -. sh) *. percent in
2487 let position =
2488 if position +. sh > float state.winh
2489 then float state.winh -. sh
2490 else position
2492 position, sh;
2495 let adderrmsg src msg =
2496 Buffer.add_string state.errmsgs msg;
2497 state.newerrmsgs <- true;
2498 G.postRedisplay src
2501 let adderrfmt src fmt =
2502 Format.ksprintf (fun s -> adderrmsg src s) fmt;
2505 let coe s = (s :> uioh);;
2507 class listview ~zebra ~helpmode ~(source:lvsource) ~trusted ~modehash =
2508 object (self)
2509 val m_pan = source#getpan
2510 val m_first = source#getfirst
2511 val m_active = source#getactive
2512 val m_qsearch = E.s
2513 val m_prev_uioh = state.uioh
2515 method private elemunder y =
2516 if y < 0
2517 then None
2518 else
2519 let n = y / (fstate.fontsize+1) in
2520 if m_first + n < source#getitemcount
2521 then (
2522 if source#hasaction (m_first + n)
2523 then Some (m_first + n)
2524 else None
2526 else None
2528 method display =
2529 Gl.enable `blend;
2530 GlFunc.blend_func ~src:`src_alpha ~dst:`one_minus_src_alpha;
2531 GlDraw.color (0., 0., 0.) ~alpha:0.85;
2532 filledrect 0. 0. (float state.winw) (float state.winh);
2533 GlDraw.color (1., 1., 1.);
2534 Gl.enable `texture_2d;
2535 let fs = fstate.fontsize in
2536 let nfs = fs + 1 in
2537 let hw = state.winw/3 in
2538 let ww = fstate.wwidth in
2539 let tabw = 17.0*.ww in
2540 let itemcount = source#getitemcount in
2541 let minfo = source#getminfo in
2542 if conf.leftscroll
2543 then (
2544 GlMat.push ();
2545 GlMat.translate ~x:(float conf.scrollbw) ();
2547 let x0 = 0.0 and x1 = float (state.winw - conf.scrollbw - 1) in
2548 let rec loop row =
2549 if (row - m_first) > fstate.maxrows
2550 then ()
2551 else (
2552 if row >= 0 && row < itemcount
2553 then (
2554 let (s, level) = source#getitem row in
2555 let y = (row - m_first) * nfs in
2556 let x = 5.0 +. (float (level + m_pan)) *. ww in
2557 if helpmode
2558 then GlDraw.color
2559 (let c = if row land 1 = 0 then 1.0 else 0.92 in (c,c,c));
2561 if row = m_active
2562 then (
2563 Gl.disable `texture_2d;
2564 let alpha = if source#hasaction row then 0.9 else 0.3 in
2565 GlDraw.color (1., 1., 1.) ~alpha;
2566 linerect (x0 +. 1.) (float (y + 1)) (x1) (float (y + fs + 3));
2567 Gl.enable `texture_2d;
2569 let c =
2570 if zebra && row land 1 = 1
2571 then 0.8
2572 else 1.0
2574 GlDraw.color (c,c,c);
2575 let drawtabularstring s =
2576 let drawstr x s =
2577 let x' = truncate (x0 +. x) in
2578 let s1, s2 = splitatchar s '\000' in
2579 if emptystr s2
2580 then drawstring1 fs x' (y+nfs) s
2581 else
2582 let rec e s =
2583 if emptystr s
2584 then s
2585 else
2586 let s' = withoutlastutf8 s in
2587 let s = s' ^ UniSyms.ellipsis in
2588 let w = measurestr fs s in
2589 if float x' +. w +. ww < float (hw + x')
2590 then s
2591 else e s'
2593 let s1 =
2594 if float x' +. ww +. measurestr fs s1 > float (hw + x')
2595 then e s1
2596 else s1
2598 ignore (drawstring1 fs x' (y+nfs) s1);
2599 drawstring1 fs (hw + x') (y+nfs) s2
2601 if trusted
2602 then
2603 let x = if helpmode && row > 0 then x +. ww else x in
2604 let s1, s2 = splitatchar s '\t' in
2605 if nonemptystr s2
2606 then
2607 let nx = drawstr x s1 in
2608 let sw = nx -. x in
2609 let x = x +. (max tabw sw) in
2610 drawstr x s2
2611 else
2612 let len = String.length s - 2 in
2613 if len > 0 && s.[0] = '\xc2' && s.[1] = '\xb7'
2614 then
2615 let s = String.sub s 2 len in
2616 let x = if not helpmode then x +. ww else x in
2617 GlDraw.color (1.2, 1.2, 1.2);
2618 let vinc = drawstring1 (fs+fs/4)
2619 (truncate (x -. ww)) (y+nfs) s in
2620 GlDraw.color (1., 1., 1.);
2621 vinc +. (float fs *. 0.8)
2622 else
2623 drawstr x s
2624 else
2625 drawstr x s
2627 ignore (drawtabularstring s);
2628 loop (row+1)
2632 loop m_first;
2633 GlDraw.color (1.0, 1.0, 1.0) ~alpha:0.5;
2634 let xadj = 5.0 in
2635 let rec loop row =
2636 if (row - m_first) <= fstate.maxrows
2637 then
2638 if row >= 0 && row < itemcount
2639 then (
2640 let (s, level) = source#getitem row in
2641 let pos0 = nindex s '\000' in
2642 let y = (row - m_first) * nfs in
2643 let x = float (level + m_pan) *. ww in
2644 let (first, last) = minfo.(row) in
2645 let prefix =
2646 if pos0 > 0 && first > pos0
2647 then String.sub s (pos0+1) (first-pos0-1)
2648 else String.sub s 0 first
2650 let suffix = String.sub s first (last - first) in
2651 let w1 = measurestr fstate.fontsize prefix in
2652 let w2 = measurestr fstate.fontsize suffix in
2653 let x = x +. if conf.leftscroll then xadj else 5.0 in
2654 let x = if pos0 > 0 && first > pos0 then x +. float hw else x in
2655 let x0 = x +. w1
2656 and y0 = float (y+2) in
2657 let x1 = x0 +. w2
2658 and y1 = float (y+fs+3) in
2659 filledrect x0 y0 x1 y1;
2660 loop (row+1)
2663 Gl.disable `texture_2d;
2664 if Array.length minfo > 0 then loop m_first;
2665 Gl.disable `blend;
2666 if conf.leftscroll
2667 then GlMat.pop ()
2669 method updownlevel incr =
2670 let len = source#getitemcount in
2671 let curlevel =
2672 if m_active >= 0 && m_active < len
2673 then snd (source#getitem m_active)
2674 else -1
2676 let rec flow i =
2677 if i = len then i-1 else if i = -1 then 0 else
2678 let _, l = source#getitem i in
2679 if l != curlevel then i else flow (i+incr)
2681 let active = flow m_active in
2682 let first = calcfirst m_first active in
2683 G.postRedisplay "outline updownlevel";
2684 {< m_active = active; m_first = first >}
2686 method private key1 key mask =
2687 let set1 active first qsearch =
2688 coe {< m_active = active; m_first = first; m_qsearch = qsearch >}
2690 let search active pattern incr =
2691 let active = if active = -1 then m_first else active in
2692 let dosearch re =
2693 let rec loop n =
2694 if n >= 0 && n < source#getitemcount
2695 then (
2696 let s, _ = source#getitem n in
2697 match Str.search_forward re s 0 with
2698 | exception Not_found -> loop (n + incr)
2699 | _ -> Some n
2701 else None
2703 loop active
2705 let qpat = Str.quote pattern in
2706 match Str.regexp_case_fold qpat with
2707 | s -> dosearch s
2708 | exception exn ->
2709 adderrfmt "listview key1" "regexp_case_fold for `%S' failed: %S\n"
2710 qpat @@ Printexc.to_string exn;
2711 None
2713 let itemcount = source#getitemcount in
2714 let find start incr =
2715 let rec find i =
2716 if i = -1 || i = itemcount
2717 then -1
2718 else (
2719 if source#hasaction i
2720 then i
2721 else find (i + incr)
2724 find start
2726 let set active first =
2727 let first = bound first 0 (itemcount - fstate.maxrows) in
2728 state.text <- E.s;
2729 coe {< m_active = active; m_first = first; m_qsearch = E.s >}
2731 let navigate incr =
2732 let isvisible first n = n >= first && n - first <= fstate.maxrows in
2733 let active, first =
2734 let incr1 = if incr > 0 then 1 else -1 in
2735 if isvisible m_first m_active
2736 then
2737 let next =
2738 let next = m_active + incr in
2739 let next =
2740 if next < 0 || next >= itemcount
2741 then -1
2742 else find next incr1
2744 if abs (m_active - next) > fstate.maxrows
2745 then -1
2746 else next
2748 if next = -1
2749 then
2750 let first = m_first + incr in
2751 let first = bound first 0 (itemcount - fstate.maxrows) in
2752 let next =
2753 let next = m_active + incr in
2754 let next = bound next 0 (itemcount - 1) in
2755 find next ~-incr1
2757 let active =
2758 if next = -1
2759 then m_active
2760 else (
2761 if isvisible first next
2762 then next
2763 else m_active
2766 active, first
2767 else
2768 let first = min next m_first in
2769 let first =
2770 if abs (next - first) > fstate.maxrows
2771 then first + incr
2772 else first
2774 next, first
2775 else
2776 let first = m_first + incr in
2777 let first = bound first 0 (itemcount - 1) in
2778 let active =
2779 let next = m_active + incr in
2780 let next = bound next 0 (itemcount - 1) in
2781 let next = find next incr1 in
2782 let active =
2783 if next = -1 || abs (m_active - first) > fstate.maxrows
2784 then (
2785 let active = if m_active = -1 then next else m_active in
2786 active
2788 else next
2790 if isvisible first active
2791 then active
2792 else -1
2794 active, first
2796 G.postRedisplay "listview navigate";
2797 set active first;
2799 let open Keys in
2800 let kt = Wsi.kc2kt key in
2801 match [@warning "-4"] kt with
2802 | Ascii (('r'|'s') as c) when Wsi.withctrl mask ->
2803 let incr = if c = 'r' then -1 else 1 in
2804 let active, first =
2805 match search (m_active + incr) m_qsearch incr with
2806 | None ->
2807 state.text <- m_qsearch ^ " [not found]";
2808 m_active, m_first
2809 | Some active ->
2810 state.text <- m_qsearch;
2811 active, firstof m_first active
2813 G.postRedisplay "listview ctrl-r/s";
2814 set1 active first m_qsearch;
2816 | Insert when Wsi.withctrl mask ->
2817 if m_active >= 0 && m_active < source#getitemcount
2818 then (
2819 let s, _ = source#getitem m_active in
2820 selstring s;
2822 coe self
2824 | Backspace ->
2825 if emptystr m_qsearch
2826 then coe self
2827 else (
2828 let qsearch = withoutlastutf8 m_qsearch in
2829 if emptystr qsearch
2830 then (
2831 state.text <- E.s;
2832 G.postRedisplay "listview empty qsearch";
2833 set1 m_active m_first E.s;
2835 else
2836 let active, first =
2837 match search m_active qsearch ~-1 with
2838 | None ->
2839 state.text <- qsearch ^ " [not found]";
2840 m_active, m_first
2841 | Some active ->
2842 state.text <- qsearch;
2843 active, firstof m_first active
2845 G.postRedisplay "listview backspace qsearch";
2846 set1 active first qsearch
2849 | Ascii _ | Code _ ->
2850 let utf8 =
2851 match [@warning "-4"] kt with
2852 | Ascii c -> String.make 1 c
2853 | Code code -> toutf8 code
2854 | _ -> assert false
2856 let pattern = m_qsearch ^ utf8 in
2857 let active, first =
2858 match search m_active pattern 1 with
2859 | None ->
2860 state.text <- pattern ^ " [not found]";
2861 m_active, m_first
2862 | Some active ->
2863 state.text <- pattern;
2864 active, firstof m_first active
2866 G.postRedisplay "listview qsearch add";
2867 set1 active first pattern;
2869 | Escape ->
2870 state.text <- E.s;
2871 if emptystr m_qsearch
2872 then (
2873 G.postRedisplay "list view escape";
2874 let mx, my = state.mpos in
2875 updateunder mx my;
2876 match source#exit ~uioh:(coe self) ~cancel:true ~active:m_active
2877 ~first:m_first ~pan:m_pan with
2878 | None -> m_prev_uioh
2879 | Some uioh -> uioh
2881 else (
2882 G.postRedisplay "list view kill qsearch";
2883 coe {< m_qsearch = E.s >}
2886 | Enter ->
2887 state.text <- E.s;
2888 let self = {< m_qsearch = E.s >} in
2889 let opt =
2890 G.postRedisplay "listview enter";
2891 let cancel = not (m_active >= 0 && m_active < source#getitemcount) in
2892 source#exit ~uioh:(coe self) ~cancel
2893 ~active:m_active ~first:m_first ~pan:m_pan;
2895 begin match opt with
2896 | None -> m_prev_uioh
2897 | Some uioh -> uioh
2900 | Delete ->
2901 coe self
2903 | Up -> navigate ~-1
2904 | Down -> navigate 1
2905 | Prior -> navigate ~-(fstate.maxrows)
2906 | Next -> navigate fstate.maxrows
2908 | Right ->
2909 state.text <- E.s;
2910 G.postRedisplay "listview right";
2911 coe {< m_pan = m_pan - 1 >}
2913 | Left ->
2914 state.text <- E.s;
2915 G.postRedisplay "listview left";
2916 coe {< m_pan = m_pan + 1 >}
2918 | Home ->
2919 let active = find 0 1 in
2920 G.postRedisplay "listview home";
2921 set active 0;
2923 | End ->
2924 let first = max 0 (itemcount - fstate.maxrows) in
2925 let active = find (itemcount - 1) ~-1 in
2926 G.postRedisplay "listview end";
2927 set active first;
2929 | _ -> coe self
2931 method key key mask =
2932 match state.mode with
2933 | Textentry te ->
2934 textentrykeyboard key mask te;
2935 coe self
2936 | Birdseye _ | View | LinkNav _ -> self#key1 key mask
2938 method button button down x y _ =
2939 let opt =
2940 match button with
2941 | 1 when vscrollhit x ->
2942 G.postRedisplay "listview scroll";
2943 if down
2944 then
2945 let _, position, sh = self#scrollph in
2946 if y > truncate position && y < truncate (position +. sh)
2947 then (
2948 state.mstate <- Mscrolly;
2949 Some (coe self)
2951 else
2952 let s = float (max 0 (y - conf.scrollh)) /. float state.winh in
2953 let first = truncate (s *. float source#getitemcount) in
2954 let first = min source#getitemcount first in
2955 Some (coe {< m_first = first; m_active = first >})
2956 else (
2957 state.mstate <- Mnone;
2958 Some (coe self);
2960 | 1 when down ->
2961 begin match self#elemunder y with
2962 | Some n ->
2963 G.postRedisplay "listview click";
2964 source#exit ~uioh:(coe {< m_active = n >})
2965 ~cancel:false ~active:n ~first:m_first ~pan:m_pan
2966 | _ ->
2967 Some (coe self)
2969 | n when (n == 4 || n == 5) && not down ->
2970 let len = source#getitemcount in
2971 let first =
2972 if n = 5 && m_first + fstate.maxrows >= len
2973 then
2974 m_first
2975 else
2976 let first = m_first + (if n == 4 then -1 else 1) in
2977 bound first 0 (len - 1)
2979 G.postRedisplay "listview wheel";
2980 Some (coe {< m_first = first >})
2981 | n when (n = 6 || n = 7) && not down ->
2982 let inc = if n = 7 then -1 else 1 in
2983 G.postRedisplay "listview hwheel";
2984 Some (coe {< m_pan = m_pan + inc >})
2985 | _ ->
2986 Some (coe self)
2988 match opt with
2989 | None -> m_prev_uioh
2990 | Some uioh -> uioh
2992 method multiclick _ x y = self#button 1 true x y
2994 method motion _ y =
2995 match state.mstate with
2996 | Mscrolly ->
2997 let s = float (max 0 (y - conf.scrollh)) /. float state.winh in
2998 let first = truncate (s *. float source#getitemcount) in
2999 let first = min source#getitemcount first in
3000 G.postRedisplay "listview motion";
3001 coe {< m_first = first; m_active = first >}
3002 | Msel _
3003 | Mpan _
3004 | Mscrollx
3005 | Mzoom _
3006 | Mzoomrect _
3007 | Mnone -> coe self
3009 method pmotion x y =
3010 if x < state.winw - conf.scrollbw
3011 then
3012 let n =
3013 match self#elemunder y with
3014 | None -> Wsi.setcursor Wsi.CURSOR_INHERIT; m_active
3015 | Some n -> Wsi.setcursor Wsi.CURSOR_INFO; n
3017 let o =
3018 if n != m_active
3019 then (G.postRedisplay "listview pmotion"; {< m_active = n >})
3020 else self
3022 coe o
3023 else (
3024 Wsi.setcursor Wsi.CURSOR_INHERIT;
3025 coe self
3028 method infochanged _ = ()
3030 method scrollpw = (0, 0.0, 0.0)
3031 method scrollph =
3032 let nfs = fstate.fontsize + 1 in
3033 let y = m_first * nfs in
3034 let itemcount = source#getitemcount in
3035 let maxi = max 0 (itemcount - fstate.maxrows) in
3036 let maxy = maxi * nfs in
3037 let p, h = scrollph y maxy in
3038 conf.scrollbw, p, h
3040 method modehash = modehash
3041 method eformsgs = false
3042 method alwaysscrolly = true
3043 end;;
3045 class outlinelistview ~zebra ~source =
3046 let settext autonarrow s =
3047 if autonarrow
3048 then
3049 let ss = source#statestr in
3050 state.text <-
3051 if emptystr ss
3052 then "[" ^ s ^ "]"
3053 else "{" ^ ss ^ "} [" ^ s ^ "]"
3054 else state.text <- s
3056 object (self)
3057 inherit listview
3058 ~zebra
3059 ~helpmode:false
3060 ~source:(source :> lvsource)
3061 ~trusted:false
3062 ~modehash:(findkeyhash conf "outline")
3063 as super
3065 val m_autonarrow = false
3067 method! key key mask =
3068 let maxrows =
3069 if emptystr state.text
3070 then fstate.maxrows
3071 else fstate.maxrows - 2
3073 let calcfirst first active =
3074 if active > first
3075 then
3076 let rows = active - first in
3077 if rows > maxrows then active - maxrows else first
3078 else active
3080 let navigate incr =
3081 let active = m_active + incr in
3082 let active = bound active 0 (source#getitemcount - 1) in
3083 let first = calcfirst m_first active in
3084 G.postRedisplay "outline navigate";
3085 coe {< m_active = active; m_first = first >}
3087 let navscroll first =
3088 let active =
3089 let dist = m_active - first in
3090 if dist < 0
3091 then first
3092 else (
3093 if dist < maxrows
3094 then m_active
3095 else first + maxrows
3098 G.postRedisplay "outline navscroll";
3099 coe {< m_first = first; m_active = active >}
3101 let ctrl = Wsi.withctrl mask in
3102 let open Keys in
3103 match Wsi.kc2kt key with
3104 | Ascii 'a' when ctrl ->
3105 let text =
3106 if m_autonarrow
3107 then (source#denarrow; E.s)
3108 else (
3109 let pattern = source#renarrow in
3110 if nonemptystr m_qsearch
3111 then (source#narrow m_qsearch; m_qsearch)
3112 else pattern
3115 settext (not m_autonarrow) text;
3116 G.postRedisplay "toggle auto narrowing";
3117 coe {< m_first = 0; m_active = 0; m_autonarrow = not m_autonarrow >}
3119 | Ascii '/' when emptystr m_qsearch && not m_autonarrow ->
3120 settext true E.s;
3121 G.postRedisplay "toggle auto narrowing";
3122 coe {< m_first = 0; m_active = 0; m_autonarrow = true >}
3124 | Ascii 'n' when ctrl ->
3125 source#narrow m_qsearch;
3126 if not m_autonarrow
3127 then source#add_narrow_pattern m_qsearch;
3128 G.postRedisplay "outline ctrl-n";
3129 coe {< m_first = 0; m_active = 0 >}
3131 | Ascii 'S' when ctrl ->
3132 let active = source#calcactive (getanchor ()) in
3133 let first = firstof m_first active in
3134 G.postRedisplay "outline ctrl-s";
3135 coe {< m_first = first; m_active = active >}
3137 | Ascii 'u' when ctrl ->
3138 G.postRedisplay "outline ctrl-u";
3139 if m_autonarrow && nonemptystr m_qsearch
3140 then (
3141 ignore (source#renarrow);
3142 settext m_autonarrow E.s;
3143 coe {< m_first = 0; m_active = 0; m_qsearch = E.s >}
3145 else (
3146 source#del_narrow_pattern;
3147 let pattern = source#renarrow in
3148 let text =
3149 if emptystr pattern then E.s else "Narrowed to " ^ pattern
3151 settext m_autonarrow text;
3152 coe {< m_first = 0; m_active = 0; m_qsearch = E.s >}
3155 | Ascii 'l' when ctrl ->
3156 let first = max 0 (m_active - (fstate.maxrows / 2)) in
3157 G.postRedisplay "outline ctrl-l";
3158 coe {< m_first = first >}
3160 | Ascii '\t' when m_autonarrow ->
3161 if nonemptystr m_qsearch
3162 then (
3163 G.postRedisplay "outline list view tab";
3164 source#add_narrow_pattern m_qsearch;
3165 settext true E.s;
3166 coe {< m_qsearch = E.s >}
3168 else coe self
3170 | Escape when m_autonarrow ->
3171 if nonemptystr m_qsearch
3172 then source#add_narrow_pattern m_qsearch;
3173 super#key key mask
3175 | Enter when m_autonarrow ->
3176 if nonemptystr m_qsearch
3177 then source#add_narrow_pattern m_qsearch;
3178 super#key key mask
3180 | _ when m_autonarrow ->
3181 let pattern = m_qsearch ^ toutf8 key in
3182 G.postRedisplay "outlinelistview autonarrow add";
3183 source#narrow pattern;
3184 settext true pattern;
3185 coe {< m_first = 0; m_active = 0; m_qsearch = pattern >}
3187 | key when m_autonarrow && key = Backspace ->
3188 if emptystr m_qsearch
3189 then coe self
3190 else
3191 let pattern = withoutlastutf8 m_qsearch in
3192 G.postRedisplay "outlinelistview autonarrow backspace";
3193 ignore (source#renarrow);
3194 source#narrow pattern;
3195 settext true pattern;
3196 coe {< m_first = 0; m_active = 0; m_qsearch = pattern >}
3198 | Up when ctrl ->
3199 navscroll (max 0 (m_first - 1))
3201 | Down when ctrl ->
3202 navscroll (min (source#getitemcount - 1) (m_first + 1))
3204 | Up -> navigate ~-1
3205 | Down -> navigate 1
3206 | Prior -> navigate ~-(fstate.maxrows)
3207 | Next -> navigate fstate.maxrows
3209 | Right ->
3210 let o =
3211 if ctrl
3212 then (
3213 G.postRedisplay "outline ctrl right";
3214 {< m_pan = m_pan + 1 >}
3216 else self#updownlevel 1
3218 coe o
3220 | Left ->
3221 let o =
3222 if ctrl
3223 then (
3224 G.postRedisplay "outline ctrl left";
3225 {< m_pan = m_pan - 1 >}
3227 else self#updownlevel ~-1
3229 coe o
3231 | Home ->
3232 G.postRedisplay "outline home";
3233 coe {< m_first = 0; m_active = 0 >}
3235 | End ->
3236 let active = source#getitemcount - 1 in
3237 let first = max 0 (active - fstate.maxrows) in
3238 G.postRedisplay "outline end";
3239 coe {< m_active = active; m_first = first >}
3241 | Delete|Escape|Insert|Enter|Ascii _|Code _|Backspace|Fn _ ->
3242 super#key key mask
3243 end;;
3245 let genhistoutlines () =
3246 Config.gethist ()
3247 |> List.sort (fun (_, c1, _, _, _, _) (_, c2, _, _, _, _) ->
3248 compare c2.lastvisit c1.lastvisit)
3249 |> List.map (fun ((path, c, _, _, _, origin) as hist) ->
3250 let path = if nonemptystr origin then origin else path in
3251 let base = mbtoutf8 @@ Filename.basename path in
3252 (base ^ "\000" ^ c.title, 1, Ohistory hist)
3256 let gotohist (path, c, bookmarks, x, anchor, origin) =
3257 Config.save leavebirdseye;
3258 state.anchor <- anchor;
3259 state.bookmarks <- bookmarks;
3260 state.origin <- origin;
3261 state.x <- x;
3262 setconf conf c;
3263 let x0, y0, x1, y1 = conf.trimfuzz in
3264 wcmd "trimset %d %d %d %d %d" (btod conf.trimmargins) x0 y0 x1 y1;
3265 reshape ~firsttime:true state.winw state.winh;
3266 opendoc path origin;
3267 setzoom c.zoom;
3270 let makecheckers () =
3271 (* Based on lablGL-1.04/LablGlut/examples/lablGL/checker.ml which had
3272 following to say:
3273 converted by Issac Trotts. July 25, 2002 *)
3274 let image = GlPix.create `ubyte ~format:`luminance ~width:2 ~height:2 in
3275 Raw.sets_string (GlPix.to_raw image) ~pos:0 "\255\200\200\255";
3276 let id = GlTex.gen_texture () in
3277 GlTex.bind_texture ~target:`texture_2d id;
3278 GlPix.store (`unpack_alignment 1);
3279 GlTex.image2d image;
3280 List.iter (GlTex.parameter ~target:`texture_2d)
3281 [ `mag_filter `nearest; `min_filter `nearest ];
3285 let setcheckers enabled =
3286 match state.checkerstexid with
3287 | None ->
3288 if enabled then state.checkerstexid <- Some (makecheckers ())
3290 | Some checkerstexid ->
3291 if not enabled
3292 then (
3293 GlTex.delete_texture checkerstexid;
3294 state.checkerstexid <- None;
3298 let describe_location () =
3299 let fn = page_of_y state.y in
3300 let ln = page_of_y (state.y + state.winh - 1) in
3301 let maxy = maxy () in
3302 let percent =
3303 if maxy <= 0
3304 then 100.
3305 else 100. *. (float state.y /. float maxy)
3307 if fn = ln
3308 then
3309 Printf.sprintf "page %d of %d [%.2f%%]"
3310 (fn+1) state.pagecount percent
3311 else
3312 Printf.sprintf
3313 "pages %d-%d of %d [%.2f%%]"
3314 (fn+1) (ln+1) state.pagecount percent
3317 let setpresentationmode v =
3318 let n = page_of_y state.y in
3319 state.anchor <- (n, 0.0, 1.0);
3320 conf.presentation <- v;
3321 if conf.fitmodel = FitPage
3322 then reqlayout conf.angle conf.fitmodel;
3323 represent ();
3326 let setbgcol (r, g, b) =
3327 let col =
3328 let r = r *. 255.0 |> truncate
3329 and g = g *. 255.0 |> truncate
3330 and b = b *. 255.0 |> truncate in
3331 r lsl 16 |> (lor) (g lsl 8) |> (lor) b
3333 Wsi.setwinbgcol col;
3336 let enterinfomode =
3337 let btos b = if b then UniSyms.radical else E.s in
3338 let showextended = ref false in
3339 let leave mode _ = state.mode <- mode in
3340 let src =
3341 (object
3342 val mutable m_l = []
3343 val mutable m_a = E.a
3344 val mutable m_prev_uioh = nouioh
3345 val mutable m_prev_mode = View
3347 inherit lvsourcebase
3349 method reset prev_mode prev_uioh =
3350 m_a <- Array.of_list (List.rev m_l);
3351 m_l <- [];
3352 m_prev_mode <- prev_mode;
3353 m_prev_uioh <- prev_uioh;
3355 method int name get set =
3356 m_l <-
3357 (name, `int get, 1,
3358 Action (
3359 fun u ->
3360 let ondone s =
3361 try set (int_of_string s)
3362 with exn ->
3363 state.text <- Printf.sprintf "bad integer `%s': %s"
3364 s @@ exntos exn
3366 state.text <- E.s;
3367 let te = name ^ ": ", E.s, None, intentry, ondone, true in
3368 state.mode <- Textentry (te, leave m_prev_mode);
3370 )) :: m_l
3372 method int_with_suffix name get set =
3373 m_l <-
3374 (name, `intws get, 1,
3375 Action (
3376 fun u ->
3377 let ondone s =
3378 try set (int_of_string_with_suffix s)
3379 with exn ->
3380 state.text <- Printf.sprintf "bad integer `%s': %s"
3381 s @@ exntos exn
3383 state.text <- E.s;
3384 let te =
3385 name ^ ": ", E.s, None, intentry_with_suffix, ondone, true
3387 state.mode <- Textentry (te, leave m_prev_mode);
3389 )) :: m_l
3391 method bool ?(offset=1) ?(btos=btos) name get set =
3392 m_l <-
3393 (name, `bool (btos, get), offset, Action (
3394 fun u ->
3395 let v = get () in
3396 set (not v);
3398 )) :: m_l
3400 method color name get set =
3401 m_l <-
3402 (name, `color get, 1,
3403 Action (
3404 fun u ->
3405 let invalid = (nan, nan, nan) in
3406 let ondone s =
3407 let c =
3408 try color_of_string s
3409 with exn ->
3410 state.text <- Printf.sprintf "bad color `%s': %s"
3411 s @@ exntos exn;
3412 invalid
3414 if c <> invalid
3415 then set c;
3417 let te = name ^ ": ", E.s, None, textentry, ondone, true in
3418 state.text <- color_to_string (get ());
3419 state.mode <- Textentry (te, leave m_prev_mode);
3421 )) :: m_l
3423 method string name get set =
3424 m_l <-
3425 (name, `string get, 1,
3426 Action (
3427 fun u ->
3428 let ondone s = set s in
3429 let te = name ^ ": ", E.s, None, textentry, ondone, true in
3430 state.mode <- Textentry (te, leave m_prev_mode);
3432 )) :: m_l
3434 method colorspace name get set =
3435 m_l <-
3436 (name, `string get, 1,
3437 Action (
3438 fun _ ->
3439 let source =
3440 (object
3441 inherit lvsourcebase
3443 initializer
3444 m_active <- CSTE.to_int conf.colorspace;
3445 m_first <- 0;
3447 method getitemcount =
3448 Array.length CSTE.names
3449 method getitem n =
3450 (CSTE.names.(n), 0)
3451 method exit ~uioh ~cancel ~active ~first ~pan =
3452 ignore (uioh, first, pan);
3453 if not cancel then set active;
3454 None
3455 method hasaction _ = true
3456 end)
3458 state.text <- E.s;
3459 let modehash = findkeyhash conf "info" in
3460 coe (new listview ~zebra:false ~helpmode:false
3461 ~source ~trusted:true ~modehash)
3462 )) :: m_l
3464 method paxmark name get set =
3465 m_l <-
3466 (name, `string get, 1,
3467 Action (
3468 fun _ ->
3469 let source =
3470 (object
3471 inherit lvsourcebase
3473 initializer
3474 m_active <- MTE.to_int conf.paxmark;
3475 m_first <- 0;
3477 method getitemcount = Array.length MTE.names
3478 method getitem n = (MTE.names.(n), 0)
3479 method exit ~uioh ~cancel ~active ~first ~pan =
3480 ignore (uioh, first, pan);
3481 if not cancel then set active;
3482 None
3483 method hasaction _ = true
3484 end)
3486 state.text <- E.s;
3487 let modehash = findkeyhash conf "info" in
3488 coe (new listview ~zebra:false ~helpmode:false
3489 ~source ~trusted:true ~modehash)
3490 )) :: m_l
3492 method fitmodel name get set =
3493 m_l <-
3494 (name, `string get, 1,
3495 Action (
3496 fun _ ->
3497 let source =
3498 (object
3499 inherit lvsourcebase
3501 initializer
3502 m_active <- FMTE.to_int conf.fitmodel;
3503 m_first <- 0;
3505 method getitemcount = Array.length FMTE.names
3506 method getitem n = (FMTE.names.(n), 0)
3507 method exit ~uioh ~cancel ~active ~first ~pan =
3508 ignore (uioh, first, pan);
3509 if not cancel then set active;
3510 None
3511 method hasaction _ = true
3512 end)
3514 state.text <- E.s;
3515 let modehash = findkeyhash conf "info" in
3516 coe (new listview ~zebra:false ~helpmode:false
3517 ~source ~trusted:true ~modehash)
3518 )) :: m_l
3520 method caption s offset =
3521 m_l <- (s, `empty, offset, Noaction) :: m_l
3523 method caption2 s f offset =
3524 m_l <- (s, `string f, offset, Noaction) :: m_l
3526 method getitemcount = Array.length m_a
3528 method getitem n =
3529 let tostr = function
3530 | `int f -> string_of_int (f ())
3531 | `intws f -> string_with_suffix_of_int (f ())
3532 | `string f -> f ()
3533 | `color f -> color_to_string (f ())
3534 | `bool (btos, f) -> btos (f ())
3535 | `empty -> E.s
3537 let name, t, offset, _ = m_a.(n) in
3538 ((let s = tostr t in
3539 if nonemptystr s
3540 then Printf.sprintf "%s\t%s" name s
3541 else name),
3542 offset)
3544 method exit ~uioh ~cancel ~active ~first ~pan =
3545 let uiohopt =
3546 if not cancel
3547 then (
3548 let uioh =
3549 match m_a.(active) with
3550 | _, _, _, Action f -> f uioh
3551 | _, _, _, Noaction -> uioh
3553 Some uioh
3555 else None
3557 m_active <- active;
3558 m_first <- first;
3559 m_pan <- pan;
3560 uiohopt
3562 method hasaction n =
3563 match m_a.(n) with
3564 | _, _, _, Action _ -> true
3565 | _, _, _, Noaction -> false
3567 initializer m_active <- 1
3568 end)
3570 let rec fillsrc prevmode prevuioh =
3571 let sep () = src#caption E.s 0 in
3572 let colorp name get set =
3573 src#string name
3574 (fun () -> color_to_string (get ()))
3575 (fun v ->
3577 let c = color_of_string v in
3578 set c
3579 with exn ->
3580 state.text <-
3581 Printf.sprintf "bad color `%s': %s" v @@ exntos exn
3584 let oldmode = state.mode in
3585 let birdseye = isbirdseye state.mode in
3587 src#caption (if birdseye then "Setup (Bird's eye)" else "Setup") 0;
3589 src#bool "presentation mode"
3590 (fun () -> conf.presentation)
3591 (fun v -> setpresentationmode v);
3593 src#bool "ignore case in searches"
3594 (fun () -> conf.icase)
3595 (fun v -> conf.icase <- v);
3597 src#bool "preload"
3598 (fun () -> conf.preload)
3599 (fun v -> conf.preload <- v);
3601 src#bool "highlight links"
3602 (fun () -> conf.hlinks)
3603 (fun v -> conf.hlinks <- v);
3605 src#bool "under info"
3606 (fun () -> conf.underinfo)
3607 (fun v -> conf.underinfo <- v);
3609 src#bool "persistent bookmarks"
3610 (fun () -> conf.savebmarks)
3611 (fun v -> conf.savebmarks <- v);
3613 src#fitmodel "fit model"
3614 (fun () -> FMTE.to_string conf.fitmodel)
3615 (fun v -> reqlayout conf.angle (FMTE.of_int v));
3617 src#bool "trim margins"
3618 (fun () -> conf.trimmargins)
3619 (fun v -> settrim v conf.trimfuzz; fillsrc prevmode prevuioh);
3621 src#bool "persistent location"
3622 (fun () -> conf.jumpback)
3623 (fun v -> conf.jumpback <- v);
3625 sep ();
3626 src#int "inter-page space"
3627 (fun () -> conf.interpagespace)
3628 (fun n ->
3629 conf.interpagespace <- n;
3630 docolumns conf.columns;
3631 let pageno, py =
3632 match state.layout with
3633 | [] -> 0, 0
3634 | l :: _ ->
3635 l.pageno, l.pagey
3637 state.maxy <- calcheight ();
3638 let y = getpagey pageno in
3639 gotoxy state.x (y + py)
3642 src#int "page bias"
3643 (fun () -> conf.pagebias)
3644 (fun v -> conf.pagebias <- v);
3646 src#int "scroll step"
3647 (fun () -> conf.scrollstep)
3648 (fun n -> conf.scrollstep <- n);
3650 src#int "horizontal scroll step"
3651 (fun () -> conf.hscrollstep)
3652 (fun v -> conf.hscrollstep <- v);
3654 src#int "auto scroll step"
3655 (fun () ->
3656 match state.autoscroll with
3657 | Some step -> step
3658 | _ -> conf.autoscrollstep)
3659 (fun n ->
3660 let n = boundastep state.winh n in
3661 if state.autoscroll <> None
3662 then state.autoscroll <- Some n;
3663 conf.autoscrollstep <- n);
3665 src#int "zoom"
3666 (fun () -> truncate (conf.zoom *. 100.))
3667 (fun v -> pivotzoom ((float v) /. 100.));
3669 src#int "rotation"
3670 (fun () -> conf.angle)
3671 (fun v -> reqlayout v conf.fitmodel);
3673 src#int "scroll bar width"
3674 (fun () -> conf.scrollbw)
3675 (fun v ->
3676 conf.scrollbw <- v;
3677 reshape state.winw state.winh;
3680 src#int "scroll handle height"
3681 (fun () -> conf.scrollh)
3682 (fun v -> conf.scrollh <- v;);
3684 src#int "thumbnail width"
3685 (fun () -> conf.thumbw)
3686 (fun v ->
3687 conf.thumbw <- min 4096 v;
3688 match oldmode with
3689 | Birdseye beye ->
3690 leavebirdseye beye false;
3691 enterbirdseye ()
3692 | Textentry _
3693 | View
3694 | LinkNav _ -> ()
3697 let mode = state.mode in
3698 src#string "columns"
3699 (fun () ->
3700 match conf.columns with
3701 | Csingle _ -> "1"
3702 | Cmulti (multi, _) -> multicolumns_to_string multi
3703 | Csplit (count, _) -> "-" ^ string_of_int count
3705 (fun v ->
3706 let n, a, b = multicolumns_of_string v in
3707 setcolumns mode n a b);
3709 sep ();
3710 src#caption "Pixmap cache" 0;
3711 src#int_with_suffix "size (advisory)"
3712 (fun () -> conf.memlimit)
3713 (fun v -> conf.memlimit <- v);
3715 src#caption2 "used"
3716 (fun () ->
3717 Printf.sprintf "%s bytes, %d tiles"
3718 (string_with_suffix_of_int state.memused)
3719 (Hashtbl.length state.tilemap)) 1;
3721 sep ();
3722 src#caption "Layout" 0;
3723 src#caption2 "Dimension"
3724 (fun () ->
3725 Printf.sprintf "%dx%d (virtual %dx%d)"
3726 state.winw state.winh
3727 state.w state.maxy)
3729 if conf.debug
3730 then
3731 src#caption2 "Position" (fun () ->
3732 Printf.sprintf "%dx%d" state.x state.y
3734 else
3735 src#caption2 "Position" (fun () -> describe_location ()) 1
3738 sep ();
3739 src#bool ~offset:0 ~btos:(fun v -> if v then "(on)" else "(off)")
3740 "Save these parameters as global defaults at exit"
3741 (fun () -> conf.bedefault)
3742 (fun v -> conf.bedefault <- v)
3745 sep ();
3746 let btos b = if b then UniSyms.lguillemet else UniSyms.rguillemet in
3747 src#bool ~offset:0 ~btos "Extended parameters"
3748 (fun () -> !showextended)
3749 (fun v -> showextended := v; fillsrc prevmode prevuioh);
3750 if !showextended
3751 then (
3752 src#bool "checkers"
3753 (fun () -> conf.checkers)
3754 (fun v -> conf.checkers <- v; setcheckers v);
3755 src#bool "update cursor"
3756 (fun () -> conf.updatecurs)
3757 (fun v -> conf.updatecurs <- v);
3758 src#bool "scroll-bar on the left"
3759 (fun () -> conf.leftscroll)
3760 (fun v -> conf.leftscroll <- v);
3761 src#bool "verbose"
3762 (fun () -> conf.verbose)
3763 (fun v -> conf.verbose <- v);
3764 src#bool "invert colors"
3765 (fun () -> conf.invert)
3766 (fun v -> conf.invert <- v);
3767 src#bool "max fit"
3768 (fun () -> conf.maxhfit)
3769 (fun v -> conf.maxhfit <- v);
3770 src#bool "pax mode"
3771 (fun () -> conf.pax != None)
3772 (fun v ->
3773 if v
3774 then conf.pax <- Some (ref (now (), 0, 0))
3775 else conf.pax <- None);
3776 src#string "uri launcher"
3777 (fun () -> conf.urilauncher)
3778 (fun v -> conf.urilauncher <- v);
3779 src#string "path launcher"
3780 (fun () -> conf.pathlauncher)
3781 (fun v -> conf.pathlauncher <- v);
3782 src#string "tile size"
3783 (fun () -> Printf.sprintf "%dx%d" conf.tilew conf.tileh)
3784 (fun v ->
3786 let w, h = Scanf.sscanf v "%dx%d" (fun w h -> w, h) in
3787 conf.tilew <- max 64 w;
3788 conf.tileh <- max 64 h;
3789 flushtiles ();
3790 with exn ->
3791 state.text <- Printf.sprintf "bad tile size `%s': %s"
3792 v @@ exntos exn
3794 src#int "texture count"
3795 (fun () -> conf.texcount)
3796 (fun v ->
3797 if realloctexts v
3798 then conf.texcount <- v
3799 else impmsg "failed to set texture count please retry later"
3801 src#int "slice height"
3802 (fun () -> conf.sliceheight)
3803 (fun v ->
3804 conf.sliceheight <- v;
3805 wcmd "sliceh %d" conf.sliceheight;
3807 src#int "anti-aliasing level"
3808 (fun () -> conf.aalevel)
3809 (fun v ->
3810 conf.aalevel <- bound v 0 8;
3811 state.anchor <- getanchor ();
3812 opendoc state.path state.password;
3814 src#string "page scroll scaling factor"
3815 (fun () -> string_of_float conf.pgscale)
3816 (fun v ->
3818 let s = float_of_string v in
3819 conf.pgscale <- s
3820 with exn ->
3821 state.text <- Printf.sprintf
3822 "bad page scroll scaling factor `%s': %s" v
3823 @@ exntos exn
3826 src#int "ui font size"
3827 (fun () -> fstate.fontsize)
3828 (fun v -> setfontsize (bound v 5 100));
3829 src#int "hint font size"
3830 (fun () -> conf.hfsize)
3831 (fun v -> conf.hfsize <- bound v 5 100);
3832 colorp "background color"
3833 (fun () -> conf.bgcolor)
3834 (fun v -> conf.bgcolor <- v; setbgcol v);
3835 src#bool "crop hack"
3836 (fun () -> conf.crophack)
3837 (fun v -> conf.crophack <- v);
3838 src#string "trim fuzz"
3839 (fun () -> irect_to_string conf.trimfuzz)
3840 (fun v ->
3842 conf.trimfuzz <- irect_of_string v;
3843 if conf.trimmargins
3844 then settrim true conf.trimfuzz;
3845 with exn ->
3846 state.text <- Printf.sprintf "bad irect `%s': %s" v
3847 @@ exntos exn
3849 src#string "throttle"
3850 (fun () ->
3851 match conf.maxwait with
3852 | None -> "show place holder if page is not ready"
3853 | Some time ->
3854 if time = infinity
3855 then "wait for page to fully render"
3856 else
3857 "wait " ^ string_of_float time
3858 ^ " seconds before showing placeholder"
3860 (fun v ->
3862 let f = float_of_string v in
3863 if f <= 0.0
3864 then conf.maxwait <- None
3865 else conf.maxwait <- Some f
3866 with exn ->
3867 state.text <- Printf.sprintf "bad time `%s': %s" v
3868 @@ exntos exn
3870 src#string "ghyll scroll"
3871 (fun () ->
3872 match conf.ghyllscroll with
3873 | None -> E.s
3874 | Some nab -> ghyllscroll_to_string nab
3876 (fun v ->
3877 try conf.ghyllscroll <- ghyllscroll_of_string v
3878 with
3879 | Failure msg ->
3880 state.text <- Printf.sprintf "bad ghyll `%s': %s" v msg
3881 | exn ->
3882 state.text <- Printf.sprintf "bad ghyll `%s': %s" v
3883 @@ exntos exn
3885 src#string "selection command"
3886 (fun () -> conf.selcmd)
3887 (fun v -> conf.selcmd <- v);
3888 src#string "synctex command"
3889 (fun () -> conf.stcmd)
3890 (fun v -> conf.stcmd <- v);
3891 src#string "pax command"
3892 (fun () -> conf.paxcmd)
3893 (fun v -> conf.paxcmd <- v);
3894 src#string "ask password command"
3895 (fun () -> conf.passcmd)
3896 (fun v -> conf.passcmd <- v);
3897 src#string "save path command"
3898 (fun () -> conf.savecmd)
3899 (fun v -> conf.savecmd <- v);
3900 src#colorspace "color space"
3901 (fun () -> CSTE.to_string conf.colorspace)
3902 (fun v ->
3903 conf.colorspace <- CSTE.of_int v;
3904 wcmd "cs %d" v;
3905 load state.layout;
3907 src#paxmark "pax mark method"
3908 (fun () -> MTE.to_string conf.paxmark)
3909 (fun v -> conf.paxmark <- MTE.of_int v);
3910 if bousable () && !opengl_has_pbo
3911 then
3912 src#bool "use PBO"
3913 (fun () -> conf.usepbo)
3914 (fun v -> conf.usepbo <- v);
3915 src#bool "mouse wheel scrolls pages"
3916 (fun () -> conf.wheelbypage)
3917 (fun v -> conf.wheelbypage <- v);
3918 src#bool "open remote links in a new instance"
3919 (fun () -> conf.riani)
3920 (fun v -> conf.riani <- v);
3921 src#bool "edit annotations inline"
3922 (fun () -> conf.annotinline)
3923 (fun v -> conf.annotinline <- v);
3924 src#bool "coarse positioning in presentation mode"
3925 (fun () -> conf.coarseprespos)
3926 (fun v -> conf.coarseprespos <- v);
3927 src#bool "use document CSS"
3928 (fun () -> conf.usedoccss)
3929 (fun v ->
3930 conf.usedoccss <- v;
3931 state.anchor <- getanchor ();
3932 opendoc state.path state.password;
3936 sep ();
3937 src#caption "Document" 0;
3938 List.iter (fun (_, s) -> src#caption s 1) state.docinfo;
3939 src#caption2 "Pages"
3940 (fun () -> string_of_int state.pagecount) 1;
3941 src#caption2 "Dimensions"
3942 (fun () -> string_of_int (List.length state.pdims)) 1;
3943 if nonemptystr conf.css
3944 then src#caption2 "CSS" (fun () -> conf.css) 1;
3945 if conf.trimmargins
3946 then (
3947 sep ();
3948 src#caption "Trimmed margins" 0;
3949 src#caption2 "Dimensions"
3950 (fun () -> string_of_int (List.length state.pdims)) 1;
3953 sep ();
3954 src#caption "OpenGL" 0;
3955 src#caption (Printf.sprintf "Vendor\t%s" (GlMisc.get_string `vendor)) 1;
3956 src#caption (Printf.sprintf "Renderer\t%s" (GlMisc.get_string `renderer)) 1;
3958 sep ();
3959 src#caption "Location" 0;
3960 if nonemptystr state.origin
3961 then src#caption ("Orign\t" ^ mbtoutf8 state.origin) 1;
3962 src#caption ("Path\t" ^ mbtoutf8 state.path) 1;
3964 src#reset prevmode prevuioh;
3966 fun () ->
3967 state.text <- E.s;
3968 resetmstate ();
3969 let prevmode = state.mode
3970 and prevuioh = state.uioh in
3971 fillsrc prevmode prevuioh;
3972 let source = (src :> lvsource) in
3973 let modehash = findkeyhash conf "info" in
3974 state.uioh <-
3975 coe (object (self)
3976 inherit listview ~zebra:false ~helpmode:false
3977 ~source ~trusted:true ~modehash as super
3978 val mutable m_prevmemused = 0
3979 method! infochanged = function
3980 | Memused ->
3981 if m_prevmemused != state.memused
3982 then (
3983 m_prevmemused <- state.memused;
3984 G.postRedisplay "memusedchanged";
3986 | Pdim -> G.postRedisplay "pdimchanged"
3987 | Docinfo -> fillsrc prevmode prevuioh
3989 method! key key mask =
3990 if not (Wsi.withctrl mask)
3991 then
3992 match [@warning "-4"] Wsi.kc2kt key with
3993 | Keys.Left -> coe (self#updownlevel ~-1)
3994 | Keys.Right -> coe (self#updownlevel 1)
3995 | _ -> super#key key mask
3996 else super#key key mask
3997 end);
3998 G.postRedisplay "info";
4001 let enterhelpmode =
4002 let source =
4003 (object
4004 inherit lvsourcebase
4005 method getitemcount = Array.length state.help
4006 method getitem n =
4007 let s, l, _ = state.help.(n) in
4008 (s, l)
4010 method exit ~uioh ~cancel ~active ~first ~pan =
4011 let optuioh =
4012 if not cancel
4013 then (
4014 match state.help.(active) with
4015 | _, _, Action f -> Some (f uioh)
4016 | _, _, Noaction -> Some uioh
4018 else None
4020 m_active <- active;
4021 m_first <- first;
4022 m_pan <- pan;
4023 optuioh
4025 method hasaction n =
4026 match state.help.(n) with
4027 | _, _, Action _ -> true
4028 | _, _, Noaction -> false
4030 initializer
4031 m_active <- -1
4032 end)
4033 in fun () ->
4034 let modehash = findkeyhash conf "help" in
4035 resetmstate ();
4036 state.uioh <- coe (new listview
4037 ~zebra:false ~helpmode:true
4038 ~source ~trusted:true ~modehash);
4039 G.postRedisplay "help";
4042 let entermsgsmode =
4043 let msgsource =
4044 (object
4045 inherit lvsourcebase
4046 val mutable m_items = E.a
4048 method getitemcount = 1 + Array.length m_items
4050 method getitem n =
4051 if n = 0
4052 then "[Clear]", 0
4053 else m_items.(n-1), 0
4055 method exit ~uioh ~cancel ~active ~first ~pan =
4056 ignore uioh;
4057 if not cancel
4058 then (
4059 if active = 0
4060 then Buffer.clear state.errmsgs;
4062 m_active <- active;
4063 m_first <- first;
4064 m_pan <- pan;
4065 None
4067 method hasaction n =
4068 n = 0
4070 method reset =
4071 state.newerrmsgs <- false;
4072 let l = Str.split newlinere (Buffer.contents state.errmsgs) in
4073 m_items <- Array.of_list l
4075 initializer
4076 m_active <- 0
4077 end)
4078 in fun () ->
4079 state.text <- E.s;
4080 resetmstate ();
4081 msgsource#reset;
4082 let source = (msgsource :> lvsource) in
4083 let modehash = findkeyhash conf "listview" in
4084 state.uioh <-
4085 coe (object
4086 inherit listview ~zebra:false ~helpmode:false
4087 ~source ~trusted:false ~modehash as super
4088 method! display =
4089 if state.newerrmsgs
4090 then msgsource#reset;
4091 super#display
4092 end);
4093 G.postRedisplay "msgs";
4096 let getusertext s =
4097 let editor = getenvwithdef "EDITOR" E.s in
4098 if emptystr editor
4099 then E.s
4100 else
4101 let tmppath = Filename.temp_file "llpp" "note" in
4102 if nonemptystr s
4103 then (
4104 let oc = open_out tmppath in
4105 output_string oc s;
4106 close_out oc;
4108 let execstr = editor ^ " " ^ tmppath in
4109 let s =
4110 match spawn execstr [] with
4111 | exception exn ->
4112 impmsg "spawn(%S) failed: %s" execstr @@ exntos exn;
4114 | pid ->
4115 match Unix.waitpid [] pid with
4116 | exception exn ->
4117 impmsg "waitpid(%d) failed: %s" pid @@ exntos exn;
4119 | (_pid, status) ->
4120 match status with
4121 | Unix.WEXITED 0 -> filecontents tmppath
4122 | Unix.WEXITED n ->
4123 impmsg "editor process(%s) exited abnormally: %d" execstr n;
4125 | Unix.WSIGNALED n ->
4126 impmsg "editor process(%s) was killed by signal %d" execstr n;
4128 | Unix.WSTOPPED n ->
4129 impmsg "editor(%s) process was stopped by signal %d" execstr n;
4132 match Unix.unlink tmppath with
4133 | exception exn ->
4134 impmsg "failed to ulink %S: %s" tmppath @@ exntos exn;
4136 | () -> s
4139 let enterannotmode opaque slinkindex =
4140 let msgsource =
4141 (object
4142 inherit lvsourcebase
4143 val mutable m_text = E.s
4144 val mutable m_items = E.a
4146 method getitemcount = Array.length m_items
4148 method getitem n =
4149 let label, _func = m_items.(n) in
4150 label, 0
4152 method exit ~uioh ~cancel ~active ~first ~pan =
4153 ignore (uioh, first, pan);
4154 if not cancel
4155 then (
4156 let _label, func = m_items.(active) in
4157 func ()
4159 None
4161 method hasaction n = nonemptystr @@ fst m_items.(n)
4163 method reset s =
4164 let rec split accu b i =
4165 let p = b+i in
4166 if p = String.length s
4167 then (String.sub s b (p-b), unit) :: accu
4168 else
4169 if (i > 70 && s.[p] = ' ') || s.[p] = '\r' || s.[p] = '\n'
4170 then
4171 let ss = if i = 0 then E.s else String.sub s b i in
4172 split ((ss, unit)::accu) (p+1) 0
4173 else
4174 split accu b (i+1)
4176 let cleanup () =
4177 wcmd "freepage %s" (~> opaque);
4178 let keys =
4179 Hashtbl.fold (fun key opaque' accu ->
4180 if opaque' = opaque'
4181 then key :: accu else accu) state.pagemap []
4183 List.iter (Hashtbl.remove state.pagemap) keys;
4184 flushtiles ();
4185 gotoxy state.x state.y
4187 let dele () =
4188 delannot opaque slinkindex;
4189 cleanup ();
4191 let edit inline () =
4192 let update s =
4193 if emptystr s
4194 then dele ()
4195 else (
4196 modannot opaque slinkindex s;
4197 cleanup ();
4200 if inline
4201 then
4202 let mode = state.mode in
4203 state.mode <-
4204 Textentry (
4205 ("annotation: ", m_text, None, textentry, update, true),
4206 fun _ -> state.mode <- mode);
4207 state.text <- E.s;
4208 enttext ();
4209 else
4210 let s = getusertext m_text in
4211 update s
4213 m_text <- s;
4214 m_items <-
4215 ( "[Copy]", fun () -> selstring m_text)
4216 :: ("[Delete]", dele)
4217 :: ("[Edit]", edit conf.annotinline)
4218 :: (E.s, unit)
4219 :: split [] 0 0 |> List.rev |> Array.of_list
4221 initializer
4222 m_active <- 0
4223 end)
4225 state.text <- E.s;
4226 let s = getannotcontents opaque slinkindex in
4227 resetmstate ();
4228 msgsource#reset s;
4229 let source = (msgsource :> lvsource) in
4230 let modehash = findkeyhash conf "listview" in
4231 state.uioh <- coe (object
4232 inherit listview ~zebra:false ~helpmode:false
4233 ~source ~trusted:false ~modehash
4234 end);
4235 G.postRedisplay "enterannotmode";
4238 let gotoremote spec =
4239 let filename, dest = splitatchar spec '#' in
4240 let getpath filename =
4241 let path =
4242 if nonemptystr filename
4243 then
4244 if Filename.is_relative filename
4245 then
4246 let dir = Filename.dirname state.path in
4247 let dir =
4248 if Filename.is_implicit dir
4249 then Filename.concat (Sys.getcwd ()) dir
4250 else dir
4252 Filename.concat dir filename
4253 else filename
4254 else E.s
4256 if Sys.file_exists path
4257 then path
4258 else E.s
4260 let path = getpath filename in
4261 let dospawn lcmd =
4262 if conf.riani
4263 then
4264 let cmd = Lazy.force_val lcmd in
4265 match spawn cmd with
4266 | _pid -> ()
4267 | exception exn -> dolog "failed to execute `%s': %s" cmd @@ exntos exn
4268 else
4269 let anchor = getanchor () in
4270 let ranchor = state.path, state.password, anchor, state.origin in
4271 state.origin <- E.s;
4272 state.ranchors <- ranchor :: state.ranchors;
4273 opendoc path E.s;
4275 if substratis spec 0 "page="
4276 then
4277 match Scanf.sscanf spec "page=%d" (fun n -> n) with
4278 | pageno ->
4279 state.anchor <- (pageno, 0.0, 0.0);
4280 dospawn @@ lazy (Printf.sprintf "%s -page %d %S" !selfexec pageno path);
4281 | exception exn ->
4282 adderrfmt "error parsing remote destination" "page: %s" @@ exntos exn
4283 else (
4284 state.nameddest <- dest;
4285 dospawn @@ lazy (!selfexec ^ " " ^ path ^ " -dest " ^ dest)
4289 let gotounder = function
4290 | Ulinkuri s when isexternallink s ->
4291 if substratis s 0 "file://"
4292 then gotoremote @@ String.sub s 7 (String.length s - 7)
4293 else gotouri s
4294 | Ulinkuri s ->
4295 let pageno, x, y = uritolocation s in
4296 addnav ();
4297 gotopagexy !wtmode pageno x y
4298 | Utext _ | Unone -> ()
4299 | Uannotation (opaque, slinkindex) -> enterannotmode opaque slinkindex
4302 let gotooutline (_, _, kind) =
4303 match kind with
4304 | Onone -> ()
4305 | Oanchor anchor ->
4306 let (pageno, y, _) = anchor in
4307 let y = getanchory
4308 (if conf.presentation then (pageno, y, 1.0) else anchor)
4310 addnav ();
4311 gotoghyll y
4312 | Ouri uri -> gotounder (Ulinkuri uri)
4313 | Olaunch _cmd -> failwith "gotounder (Ulaunch cmd)"
4314 | Oremote _remote -> failwith "gotounder (Uremote remote)"
4315 | Ohistory hist -> gotohist hist
4316 | Oremotedest _remotedest -> failwith "gotounder (Uremotedest remotedest)"
4319 class outlinesoucebase fetchoutlines = object (self)
4320 inherit lvsourcebase
4321 val mutable m_items = E.a
4322 val mutable m_minfo = E.a
4323 val mutable m_orig_items = E.a
4324 val mutable m_orig_minfo = E.a
4325 val mutable m_narrow_patterns = []
4326 val mutable m_gen = -1
4328 method getitemcount = Array.length m_items
4330 method getitem n =
4331 let s, n, _ = m_items.(n) in
4332 (s, n+0)
4334 method exit ~(uioh:uioh) ~cancel ~active ~(first:int) ~pan : uioh option =
4335 ignore (uioh, first);
4336 let items, minfo =
4337 if m_narrow_patterns = []
4338 then m_orig_items, m_orig_minfo
4339 else m_items, m_minfo
4341 m_pan <- pan;
4342 if not cancel
4343 then (
4344 m_items <- items;
4345 m_minfo <- minfo;
4346 gotooutline m_items.(active);
4348 else (
4349 m_items <- items;
4350 m_minfo <- minfo;
4352 None
4354 method hasaction (_:int) = true
4356 method greetmsg =
4357 if Array.length m_items != Array.length m_orig_items
4358 then
4359 let s =
4360 match m_narrow_patterns with
4361 | one :: [] -> one
4362 | many -> String.concat UniSyms.ellipsis (List.rev many)
4364 "Narrowed to " ^ s ^ " (ctrl-u to restore)"
4365 else E.s
4367 method statestr =
4368 match m_narrow_patterns with
4369 | [] -> E.s
4370 | one :: [] -> one
4371 | head :: _ -> UniSyms.ellipsis ^ head
4373 method narrow pattern =
4374 match Str.regexp_case_fold pattern with
4375 | exception _ -> ()
4376 | re ->
4377 let rec loop accu minfo n =
4378 if n = -1
4379 then (
4380 m_items <- Array.of_list accu;
4381 m_minfo <- Array.of_list minfo;
4383 else
4384 let (s, _, _) as o = m_items.(n) in
4385 let accu, minfo =
4386 match Str.search_forward re s 0 with
4387 | exception Not_found -> accu, minfo
4388 | first -> o :: accu, (first, Str.match_end ()) :: minfo
4390 loop accu minfo (n-1)
4392 loop [] [] (Array.length m_items - 1)
4394 method! getminfo = m_minfo
4396 method denarrow =
4397 m_orig_items <- fetchoutlines ();
4398 m_minfo <- m_orig_minfo;
4399 m_items <- m_orig_items
4401 method add_narrow_pattern pattern =
4402 m_narrow_patterns <- pattern :: m_narrow_patterns
4404 method del_narrow_pattern =
4405 match m_narrow_patterns with
4406 | _ :: rest -> m_narrow_patterns <- rest
4407 | [] -> ()
4409 method renarrow =
4410 self#denarrow;
4411 match m_narrow_patterns with
4412 | pattern :: [] -> self#narrow pattern; pattern
4413 | list ->
4414 List.fold_left (fun accu pattern ->
4415 self#narrow pattern;
4416 pattern ^ UniSyms.ellipsis ^ accu) E.s list
4418 method calcactive (_:anchor) = 0
4420 method reset anchor items =
4421 if state.gen != m_gen
4422 then (
4423 m_orig_items <- items;
4424 m_items <- items;
4425 m_narrow_patterns <- [];
4426 m_minfo <- E.a;
4427 m_orig_minfo <- E.a;
4428 m_gen <- state.gen;
4430 else (
4431 if items != m_orig_items
4432 then (
4433 m_orig_items <- items;
4434 if m_narrow_patterns == []
4435 then m_items <- items;
4438 let active = self#calcactive anchor in
4439 m_active <- active;
4440 m_first <- firstof m_first active
4444 let outlinesource fetchoutlines =
4445 (object
4446 inherit outlinesoucebase fetchoutlines
4447 method! calcactive anchor =
4448 let rely = getanchory anchor in
4449 let rec loop n best bestd =
4450 if n = Array.length m_items
4451 then best
4452 else
4453 let _, _, kind = m_items.(n) in
4454 match kind with
4455 | Oanchor anchor ->
4456 let orely = getanchory anchor in
4457 let d = abs (orely - rely) in
4458 if d < bestd
4459 then loop (n+1) n d
4460 else loop (n+1) best bestd
4461 | Onone | Oremote _ | Olaunch _
4462 | Oremotedest _ | Ouri _ | Ohistory _ ->
4463 loop (n+1) best bestd
4465 loop 0 ~-1 max_int
4466 end)
4469 let enteroutlinemode, enterbookmarkmode, enterhistmode =
4470 let mkselector sourcetype =
4471 let fetchoutlines () =
4472 match sourcetype with
4473 | `bookmarks -> Array.of_list state.bookmarks
4474 | `outlines -> state.outlines
4475 | `history -> genhistoutlines () |> Array.of_list
4477 let source =
4478 if sourcetype = `history
4479 then new outlinesoucebase fetchoutlines
4480 else outlinesource fetchoutlines
4482 (fun errmsg ->
4483 let outlines = fetchoutlines () in
4484 if Array.length outlines = 0
4485 then showtext ' ' errmsg
4486 else (
4487 resetmstate ();
4488 Wsi.setcursor Wsi.CURSOR_INHERIT;
4489 let anchor = getanchor () in
4490 source#reset anchor outlines;
4491 state.text <- source#greetmsg;
4492 state.uioh <-
4493 coe (new outlinelistview ~zebra:(sourcetype=`history) ~source);
4494 G.postRedisplay "enter selector";
4498 let mkenter sourcetype errmsg =
4499 let enter = mkselector sourcetype in
4500 fun () -> enter errmsg
4502 ( mkenter `outlines "document has no outline"
4503 , mkenter `bookmarks "document has no bookmarks (yet)"
4504 , mkenter `history "history is empty" )
4507 let quickbookmark ?title () =
4508 match state.layout with
4509 | [] -> ()
4510 | l :: _ ->
4511 let title =
4512 match title with
4513 | None ->
4514 Unix.(
4515 let tm = localtime (now ()) in
4516 Printf.sprintf
4517 "Quick (page %d) (bookmarked on %02d/%02d/%d at %02d:%02d)"
4518 (l.pageno+1)
4519 tm.tm_mday (tm.tm_mon+1) (tm.tm_year+1900) tm.tm_hour tm.tm_min
4521 | Some title -> title
4523 state.bookmarks <- (title, 0, Oanchor (getanchor1 l)) :: state.bookmarks
4526 let setautoscrollspeed step goingdown =
4527 let incr = max 1 ((abs step) / 2) in
4528 let incr = if goingdown then incr else -incr in
4529 let astep = boundastep state.winh (step + incr) in
4530 state.autoscroll <- Some astep;
4533 let canpan () =
4534 match conf.columns with
4535 | Csplit _ -> true
4536 | Csingle _ | Cmulti _ -> state.x != 0 || conf.zoom > 1.0
4539 let panbound x = bound x (-state.w) state.winw;;
4541 let existsinrow pageno (columns, coverA, coverB) p =
4542 let last = ((pageno - coverA) mod columns) + columns in
4543 let rec any = function
4544 | [] -> false
4545 | l :: rest ->
4546 if l.pageno = coverA - 1 || l.pageno = state.pagecount - coverB
4547 then p l
4548 else (
4549 if not (p l)
4550 then (if l.pageno = last then false else any rest)
4551 else true
4554 any state.layout
4557 let nextpage () =
4558 match state.layout with
4559 | [] ->
4560 let pageno = page_of_y state.y in
4561 gotoghyll (getpagey (pageno+1))
4562 | l :: rest ->
4563 match conf.columns with
4564 | Csingle _ ->
4565 if conf.presentation && rest == [] && l.pageh > l.pagey + l.pagevh
4566 then
4567 let y = clamp (pgscale state.winh) in
4568 gotoghyll y
4569 else
4570 let pageno = min (l.pageno+1) (state.pagecount-1) in
4571 gotoghyll (getpagey pageno)
4572 | Cmulti ((c, _, _) as cl, _) ->
4573 if conf.presentation
4574 && (existsinrow l.pageno cl
4575 (fun l -> l.pageh > l.pagey + l.pagevh))
4576 then
4577 let y = clamp (pgscale state.winh) in
4578 gotoghyll y
4579 else
4580 let pageno = min (l.pageno+c) (state.pagecount-1) in
4581 gotoghyll (getpagey pageno)
4582 | Csplit (n, _) ->
4583 if l.pageno < state.pagecount - 1 || l.pagecol < n - 1
4584 then
4585 let pagey, pageh = getpageyh l.pageno in
4586 let pagey = pagey + pageh * l.pagecol in
4587 let ips = if l.pagecol = 0 then 0 else conf.interpagespace in
4588 gotoghyll (pagey + pageh + ips)
4591 let prevpage () =
4592 match state.layout with
4593 | [] ->
4594 let pageno = page_of_y state.y in
4595 gotoghyll (getpagey (pageno-1))
4596 | l :: _ ->
4597 match conf.columns with
4598 | Csingle _ ->
4599 if conf.presentation && l.pagey != 0
4600 then
4601 gotoghyll (clamp (pgscale ~-(state.winh)))
4602 else
4603 let pageno = max 0 (l.pageno-1) in
4604 gotoghyll (getpagey pageno)
4605 | Cmulti ((c, _, coverB) as cl, _) ->
4606 if conf.presentation &&
4607 (existsinrow l.pageno cl (fun l -> l.pagey != 0))
4608 then
4609 gotoghyll (clamp (pgscale ~-(state.winh)))
4610 else
4611 let decr =
4612 if l.pageno = state.pagecount - coverB
4613 then 1
4614 else c
4616 let pageno = max 0 (l.pageno-decr) in
4617 gotoghyll (getpagey pageno)
4618 | Csplit (n, _) ->
4619 let y =
4620 if l.pagecol = 0
4621 then
4622 if l.pageno = 0
4623 then l.pagey
4624 else
4625 let pageno = max 0 (l.pageno-1) in
4626 let pagey, pageh = getpageyh pageno in
4627 pagey + (n-1)*pageh
4628 else
4629 let pagey, pageh = getpageyh l.pageno in
4630 pagey + pageh * (l.pagecol-1) - conf.interpagespace
4632 gotoghyll y
4635 let save () =
4636 if emptystr conf.savecmd
4637 then error "don't know where to save modified document"
4638 else
4639 let savecmd = Str.global_replace percentsre state.path conf.savecmd in
4640 let path =
4641 getcmdoutput
4642 (fun s -> error "failed to obtain path to the saved copy: %s" s)
4643 savecmd
4645 if nonemptystr path
4646 then
4647 let tmp = path ^ ".tmp" in
4648 savedoc tmp;
4649 Unix.rename tmp path;
4652 let viewkeyboard key mask =
4653 let enttext te =
4654 let mode = state.mode in
4655 state.mode <- Textentry (te, fun _ -> state.mode <- mode);
4656 state.text <- E.s;
4657 enttext ();
4658 G.postRedisplay "view:enttext"
4660 let ctrl = Wsi.withctrl mask in
4661 let open Keys in
4662 match Wsi.kc2kt key with
4663 | Ascii 'Q' -> exit 0
4665 | Ascii 'W' ->
4666 if hasunsavedchanges ()
4667 then save ()
4669 | Insert ->
4670 if conf.angle mod 360 = 0 && not (isbirdseye state.mode)
4671 then (
4672 state.mode <- (
4673 match state.lnava with
4674 | None -> LinkNav (Ltgendir 0)
4675 | Some pn -> LinkNav (Ltexact pn)
4677 gotoxy state.x state.y;
4679 else impmsg "keyboard link navigation does not work under rotation"
4681 | Escape | Ascii 'q' ->
4682 begin match state.mstate with
4683 | Mzoomrect _ ->
4684 resetmstate ();
4685 G.postRedisplay "kill rect";
4686 | Msel _
4687 | Mpan _
4688 | Mscrolly | Mscrollx
4689 | Mzoom _
4690 | Mnone ->
4691 begin match state.mode with
4692 | LinkNav ln ->
4693 begin match ln with
4694 | Ltexact pl -> state.lnava <- Some pl
4695 | Ltgendir _ | Ltnotready _ -> state.lnava <- None
4696 end;
4697 state.mode <- View;
4698 G.postRedisplay "esc leave linknav"
4699 | Birdseye _ | Textentry _ | View ->
4700 match state.ranchors with
4701 | [] -> raise Quit
4702 | (path, password, anchor, origin) :: rest ->
4703 state.ranchors <- rest;
4704 state.anchor <- anchor;
4705 state.origin <- origin;
4706 state.nameddest <- E.s;
4707 opendoc path password
4708 end;
4709 end;
4711 | Backspace ->
4712 gotoghyll (getnav ~-1)
4714 | Ascii 'o' ->
4715 enteroutlinemode ()
4717 | Ascii 'H' ->
4718 enterhistmode ()
4720 | Ascii 'u' ->
4721 state.rects <- [];
4722 state.text <- E.s;
4723 Hashtbl.iter (fun _ opaque ->
4724 clearmark opaque;
4725 Hashtbl.clear state.prects) state.pagemap;
4726 G.postRedisplay "dehighlight";
4728 | (Ascii '/' | Ascii '?') as pv ->
4729 let ondone isforw s =
4730 cbput state.hists.pat s;
4731 state.searchpattern <- s;
4732 search s isforw
4734 let s = String.make 1 (Char.chr key) in
4735 enttext (s, E.s, Some (onhist state.hists.pat),
4736 textentry, ondone (pv = Ascii '/'), true)
4738 | Ascii '+' | Ascii '=' when ctrl ->
4739 let incr = if conf.zoom +. 0.01 > 0.1 then 0.1 else 0.01 in
4740 pivotzoom (conf.zoom +. incr)
4742 | Ascii '+' ->
4743 let ondone s =
4744 let n =
4745 try int_of_string s with exn ->
4746 state.text <- Printf.sprintf "bad integer `%s': %s" s @@ exntos exn;
4747 max_int
4749 if n != max_int
4750 then (
4751 conf.pagebias <- n;
4752 state.text <- "page bias is now " ^ string_of_int n;
4755 enttext ("page bias: ", E.s, None, intentry, ondone, true)
4757 | Ascii '-' when ctrl ->
4758 let decr = if conf.zoom -. 0.1 < 0.1 then 0.01 else 0.1 in
4759 pivotzoom (max 0.01 (conf.zoom -. decr))
4761 | Ascii '-' ->
4762 let ondone msg = state.text <- msg in
4763 enttext (
4764 "option [acfhilpstvxACFPRSZTISM]: ", E.s, None,
4765 optentry state.mode, ondone, true
4768 | Ascii '0' when ctrl ->
4769 if conf.zoom = 1.0
4770 then gotoxy 0 state.y
4771 else setzoom 1.0
4773 | Ascii ('1'|'2' as c)
4774 when ctrl && conf.fitmodel != FitPage ->
4775 let cols =
4776 match conf.columns with
4777 | Csingle _ | Cmulti _ -> 1
4778 | Csplit (n, _) -> n
4780 let h = state.winh -
4781 conf.interpagespace lsl (if conf.presentation then 1 else 0)
4783 let zoom = zoomforh state.winw h 0 cols in
4784 if zoom > 0.0 && (c = '2' || zoom < 1.0)
4785 then setzoom zoom
4787 | Ascii '3' when ctrl ->
4788 let fm =
4789 match conf.fitmodel with
4790 | FitWidth -> FitProportional
4791 | FitProportional -> FitPage
4792 | FitPage -> FitWidth
4794 state.text <- "fit model: " ^ FMTE.to_string fm;
4795 reqlayout conf.angle fm
4797 | Ascii '4' when ctrl ->
4798 let zoom = getmaxw () /. float state.winw in
4799 if zoom > 0.0 then setzoom zoom
4801 | Fn 9 ->
4802 togglebirdseye ()
4804 | Ascii '9' when ctrl ->
4805 togglebirdseye ()
4807 | Ascii ('0'..'9')
4808 when not ctrl ->
4809 let ondone s =
4810 let n =
4811 try int_of_string s with exn ->
4812 state.text <- Printf.sprintf "bad integer `%s': %s" s @@ exntos exn;
4815 if n >= 0
4816 then (
4817 addnav ();
4818 cbput state.hists.pag (string_of_int n);
4819 gotopage1 (n + conf.pagebias - 1) 0;
4822 let [@warning "-4"] pageentry text = function
4823 | Keys.Ascii 'g' -> TEdone text
4824 | key -> intentry text key
4826 let text = String.make 1 (Char.chr key) in
4827 enttext (":", text, Some (onhist state.hists.pag),
4828 pageentry, ondone, true)
4830 | Ascii 'b' ->
4831 conf.scrollb <- if conf.scrollb = 0 then (scrollbvv lor scrollbhv) else 0;
4832 G.postRedisplay "toggle scrollbar";
4834 | Ascii 'B' ->
4835 state.bzoom <- not state.bzoom;
4836 state.rects <- [];
4837 showtext ' ' ("block zoom " ^ if state.bzoom then "on" else "off")
4839 | Ascii 'l' ->
4840 conf.hlinks <- not conf.hlinks;
4841 state.text <- "highlightlinks " ^ if conf.hlinks then "on" else "off";
4842 G.postRedisplay "toggle highlightlinks";
4844 | Ascii 'F' ->
4845 if conf.angle mod 360 = 0
4846 then (
4847 state.glinks <- true;
4848 let mode = state.mode in
4849 state.mode <-
4850 Textentry (
4851 (":", E.s, None, linknentry, linknact gotounder, false),
4852 (fun _ ->
4853 state.glinks <- false;
4854 state.mode <- mode)
4856 state.text <- E.s;
4857 G.postRedisplay "view:linkent(F)"
4859 else impmsg "hint mode does not work under rotation"
4861 | Ascii 'y' ->
4862 state.glinks <- true;
4863 let mode = state.mode in
4864 state.mode <-
4865 Textentry (
4867 ":", E.s, None, linknentry, linknact (fun under ->
4868 selstring (undertext under);
4869 ), false
4871 fun _ ->
4872 state.glinks <- false;
4873 state.mode <- mode
4875 state.text <- E.s;
4876 G.postRedisplay "view:linkent"
4878 | Ascii 'a' ->
4879 begin match state.autoscroll with
4880 | Some step ->
4881 conf.autoscrollstep <- step;
4882 state.autoscroll <- None
4883 | None ->
4884 if conf.autoscrollstep = 0
4885 then state.autoscroll <- Some 1
4886 else state.autoscroll <- Some conf.autoscrollstep
4889 | Ascii 'p' when ctrl ->
4890 launchpath () (* XXX where do error messages go? *)
4892 | Ascii 'P' ->
4893 setpresentationmode (not conf.presentation);
4894 showtext ' ' ("presentation mode " ^
4895 if conf.presentation then "on" else "off");
4897 | Ascii 'f' ->
4898 if List.mem Wsi.Fullscreen state.winstate
4899 then Wsi.reshape conf.cwinw conf.cwinh
4900 else Wsi.fullscreen ()
4902 | Ascii ('p'|'N') ->
4903 search state.searchpattern false
4905 | Ascii 'n' | Fn 3 ->
4906 search state.searchpattern true
4908 | Ascii 't' ->
4909 begin match state.layout with
4910 | [] -> ()
4911 | l :: _ ->
4912 gotoghyll (getpagey l.pageno)
4915 | Ascii ' ' ->
4916 nextpage ()
4918 | Delete ->
4919 prevpage ()
4921 | Ascii '=' ->
4922 showtext ' ' (describe_location ());
4924 | Ascii 'w' ->
4925 begin match state.layout with
4926 | [] -> ()
4927 | l :: _ ->
4928 Wsi.reshape l.pagew l.pageh;
4929 G.postRedisplay "w"
4932 | Ascii '\'' ->
4933 enterbookmarkmode ()
4935 | Ascii 'h' | Fn 1 ->
4936 enterhelpmode ()
4938 | Ascii 'i' ->
4939 enterinfomode ()
4941 | Ascii 'e' when Buffer.length state.errmsgs > 0 ->
4942 entermsgsmode ()
4944 | Ascii 'm' ->
4945 let ondone s =
4946 match state.layout with
4947 | l :: _ ->
4948 if nonemptystr s
4949 then
4950 state.bookmarks <-
4951 (s, 0, Oanchor (getanchor1 l)) :: state.bookmarks
4952 | _ -> ()
4954 enttext ("bookmark: ", E.s, None, textentry, ondone, true)
4956 | Ascii '~' ->
4957 quickbookmark ();
4958 showtext ' ' "Quick bookmark added";
4960 | Ascii 'z' ->
4961 begin match state.layout with
4962 | l :: _ ->
4963 let rect = getpdimrect l.pagedimno in
4964 let w, h =
4965 if conf.crophack
4966 then
4967 (truncate (1.8 *. (rect.(1) -. rect.(0))),
4968 truncate (1.2 *. (rect.(3) -. rect.(0))))
4969 else
4970 (truncate (rect.(1) -. rect.(0)),
4971 truncate (rect.(3) -. rect.(0)))
4973 let w = truncate ((float w)*.conf.zoom)
4974 and h = truncate ((float h)*.conf.zoom) in
4975 if w != 0 && h != 0
4976 then (
4977 state.anchor <- getanchor ();
4978 Wsi.reshape w (h + conf.interpagespace)
4980 G.postRedisplay "z";
4982 | [] -> ()
4985 | Ascii 'x' -> state.roam ()
4987 | Ascii ('<'|'>' as c) ->
4988 reqlayout
4989 (conf.angle + (if c = '>' then 30 else -30)) conf.fitmodel
4991 | Ascii ('['|']' as c) ->
4992 conf.colorscale <-
4993 bound (conf.colorscale +. (if c = '>' then 0.1 else -0.1)) 0.0 1.0;
4994 G.postRedisplay "brightness";
4996 | Ascii 'c' when state.mode = View ->
4997 if Wsi.withalt mask
4998 then (
4999 if conf.zoom > 1.0
5000 then
5001 let m = (state.winw - state.w) / 2 in
5002 gotoxy_and_clear_text m state.y
5004 else
5005 let (c, a, b), z =
5006 match state.prevcolumns with
5007 | None -> (1, 0, 0), 1.0
5008 | Some (columns, z) ->
5009 let cab =
5010 match columns with
5011 | Csplit (c, _) -> -c, 0, 0
5012 | Cmulti ((c, a, b), _) -> c, a, b
5013 | Csingle _ -> 1, 0, 0
5015 cab, z
5017 setcolumns View c a b;
5018 setzoom z
5020 | Down | Up when ctrl && Wsi.withshift mask ->
5021 let zoom, x = state.prevzoom in
5022 setzoom zoom;
5023 state.x <- x;
5025 | Ascii 'k' | Up ->
5026 begin match state.autoscroll with
5027 | None ->
5028 begin match state.mode with
5029 | Birdseye beye -> upbirdseye 1 beye
5030 | Textentry _ | View | LinkNav _ ->
5031 if ctrl
5032 then gotoxy_and_clear_text state.x (clamp ~-(state.winh/2))
5033 else (
5034 if not (Wsi.withshift mask) && conf.presentation
5035 then prevpage ()
5036 else gotoghyll1 true (clamp (-conf.scrollstep))
5039 | Some n ->
5040 setautoscrollspeed n false
5043 | Ascii 'j' | Down ->
5044 begin match state.autoscroll with
5045 | None ->
5046 begin match state.mode with
5047 | Birdseye beye -> downbirdseye 1 beye
5048 | Textentry _ | View | LinkNav _ ->
5049 if ctrl
5050 then gotoxy_and_clear_text state.x (clamp (state.winh/2))
5051 else (
5052 if not (Wsi.withshift mask) && conf.presentation
5053 then nextpage ()
5054 else gotoghyll1 true (clamp (conf.scrollstep))
5057 | Some n ->
5058 setautoscrollspeed n true
5061 | Left | Right when not (Wsi.withalt mask) ->
5062 if canpan ()
5063 then
5064 let dx =
5065 if ctrl
5066 then state.winw / 2
5067 else conf.hscrollstep
5069 let dx =
5070 let pv = Wsi.kc2kt key in
5071 if pv = Keys.Left then dx else -dx
5073 gotoxy_and_clear_text (panbound (state.x + dx)) state.y
5074 else (
5075 state.text <- E.s;
5076 G.postRedisplay "left/right"
5079 | Prior ->
5080 let y =
5081 if ctrl
5082 then
5083 match state.layout with
5084 | [] -> state.y
5085 | l :: _ -> state.y - l.pagey
5086 else
5087 clamp (pgscale (-state.winh))
5089 gotoghyll y
5091 | Next ->
5092 let y =
5093 if ctrl
5094 then
5095 match List.rev state.layout with
5096 | [] -> state.y
5097 | l :: _ -> getpagey l.pageno
5098 else
5099 clamp (pgscale state.winh)
5101 gotoghyll y
5103 | Ascii 'g' | Home ->
5104 addnav ();
5105 gotoghyll 0
5106 | Ascii 'G' | End ->
5107 addnav ();
5108 gotoghyll (clamp state.maxy)
5110 | Right when Wsi.withalt mask ->
5111 gotoghyll (getnav 1)
5112 | Left when Wsi.withalt mask ->
5113 gotoghyll (getnav ~-1)
5115 | Ascii 'r' ->
5116 reload ()
5118 | Ascii 'v' when conf.debug ->
5119 state.rects <- [];
5120 List.iter (fun l ->
5121 match getopaque l.pageno with
5122 | None -> ()
5123 | Some opaque ->
5124 let x0, y0, x1, y1 = pagebbox opaque in
5125 let rect = (float x0, float y0,
5126 float x1, float y0,
5127 float x1, float y1,
5128 float x0, float y1) in
5129 debugrect rect;
5130 let color = (0.0, 0.0, 1.0 /. (l.pageno mod 3 |> float), 0.5) in
5131 state.rects <- (l.pageno, color, rect) :: state.rects;
5132 ) state.layout;
5133 G.postRedisplay "v";
5135 | Ascii '|' ->
5136 let mode = state.mode in
5137 let cmd = ref E.s in
5138 let onleave = function
5139 | Cancel -> state.mode <- mode
5140 | Confirm ->
5141 List.iter (fun l ->
5142 match getopaque l.pageno with
5143 | Some opaque -> pipesel opaque !cmd
5144 | None -> ()) state.layout;
5145 state.mode <- mode
5147 let ondone s =
5148 cbput state.hists.sel s;
5149 cmd := s
5151 let te =
5152 "| ", !cmd, Some (onhist state.hists.sel), textentry, ondone, true
5154 G.postRedisplay "|";
5155 state.mode <- Textentry (te, onleave);
5157 | (Ascii _|Fn _|Enter|Left|Right|Code _) ->
5158 vlog "huh? %s" (Wsi.keyname key)
5161 let linknavkeyboard key mask linknav =
5162 let pv = Wsi.kc2kt key in
5163 let getpage pageno =
5164 let rec loop = function
5165 | [] -> None
5166 | l :: _ when l.pageno = pageno -> Some l
5167 | _ :: rest -> loop rest
5168 in loop state.layout
5170 let doexact (pageno, n) =
5171 match getopaque pageno, getpage pageno with
5172 | Some opaque, Some l ->
5173 if pv = Keys.Enter
5174 then
5175 let under = getlink opaque n in
5176 G.postRedisplay "link gotounder";
5177 gotounder under;
5178 state.mode <- View;
5179 else
5180 let opt, dir =
5181 let open Keys in
5182 match pv with
5183 | Home ->
5184 Some (findlink opaque LDfirst), -1
5186 | End ->
5187 Some (findlink opaque LDlast), 1
5189 | Left ->
5190 Some (findlink opaque (LDleft n)), -1
5192 | Right ->
5193 Some (findlink opaque (LDright n)), 1
5195 | Up ->
5196 Some (findlink opaque (LDup n)), -1
5198 | Down ->
5199 Some (findlink opaque (LDdown n)), 1
5201 | Delete|Escape|Insert|Enter|Next|Prior|Ascii _
5202 | Code _|Fn _|Backspace -> None, 0
5204 let pwl l dir =
5205 begin match findpwl l.pageno dir with
5206 | Pwlnotfound -> ()
5207 | Pwl pageno ->
5208 let notfound dir =
5209 state.mode <- LinkNav (Ltgendir dir);
5210 let y, h = getpageyh pageno in
5211 let y =
5212 if dir < 0
5213 then y + h - state.winh
5214 else y
5216 gotoxy state.x y
5218 begin match getopaque pageno, getpage pageno with
5219 | Some opaque, Some _ ->
5220 let link =
5221 let ld = if dir > 0 then LDfirst else LDlast in
5222 findlink opaque ld
5224 begin match link with
5225 | Lfound m ->
5226 showlinktype (getlink opaque m);
5227 state.mode <- LinkNav (Ltexact (pageno, m));
5228 G.postRedisplay "linknav jpage";
5229 | Lnotfound -> notfound dir
5230 end;
5231 | _ -> notfound dir
5232 end;
5233 end;
5235 begin match opt with
5236 | Some Lnotfound -> pwl l dir;
5237 | Some (Lfound m) ->
5238 if m = n
5239 then pwl l dir
5240 else (
5241 let _, y0, _, y1 = getlinkrect opaque m in
5242 if y0 < l.pagey
5243 then gotopage1 l.pageno y0
5244 else (
5245 let d = fstate.fontsize + 1 in
5246 if y1 - l.pagey > l.pagevh - d
5247 then gotopage1 l.pageno (y1 - state.winh + d)
5248 else G.postRedisplay "linknav";
5250 showlinktype (getlink opaque m);
5251 state.mode <- LinkNav (Ltexact (l.pageno, m));
5254 | None -> viewkeyboard key mask
5255 end;
5256 | _ -> viewkeyboard key mask
5258 if pv = Keys.Insert
5259 then (
5260 begin match linknav with
5261 | Ltexact pa -> state.lnava <- Some pa
5262 | Ltgendir _ | Ltnotready _ -> ()
5263 end;
5264 state.mode <- View;
5265 G.postRedisplay "leave linknav"
5267 else
5268 match linknav with
5269 | Ltgendir _ | Ltnotready _ -> viewkeyboard key mask
5270 | Ltexact exact -> doexact exact
5273 let keyboard key mask =
5274 if (key = Char.code 'g' && Wsi.withctrl mask) && not (istextentry state.mode)
5275 then wcmd "interrupt"
5276 else state.uioh <- state.uioh#key key mask
5279 let birdseyekeyboard key mask
5280 ((oconf, leftx, pageno, hooverpageno, anchor) as beye) =
5281 let incr =
5282 match conf.columns with
5283 | Csingle _ -> 1
5284 | Cmulti ((c, _, _), _) -> c
5285 | Csplit _ -> failwith "bird's eye split mode"
5287 let pgh layout = List.fold_left
5288 (fun m l -> max l.pageh m) state.winh layout in
5289 let open Keys in
5290 match Wsi.kc2kt key with
5291 | Ascii 'l' when Wsi.withctrl mask ->
5292 let y, h = getpageyh pageno in
5293 let top = (state.winh - h) / 2 in
5294 gotoxy state.x (max 0 (y - top))
5295 | Enter -> leavebirdseye beye false
5296 | Escape -> leavebirdseye beye true
5297 | Up -> upbirdseye incr beye
5298 | Down -> downbirdseye incr beye
5299 | Left -> upbirdseye 1 beye
5300 | Right -> downbirdseye 1 beye
5302 | Prior ->
5303 begin match state.layout with
5304 | l :: _ ->
5305 if l.pagey != 0
5306 then (
5307 state.mode <- Birdseye (
5308 oconf, leftx, l.pageno, hooverpageno, anchor
5310 gotopage1 l.pageno 0;
5312 else (
5313 let layout = layout state.x (state.y-state.winh)
5314 state.winw
5315 (pgh state.layout) in
5316 match layout with
5317 | [] -> gotoxy state.x (clamp (-state.winh))
5318 | l :: _ ->
5319 state.mode <- Birdseye (
5320 oconf, leftx, l.pageno, hooverpageno, anchor
5322 gotopage1 l.pageno 0
5325 | [] -> gotoxy state.x (clamp (-state.winh))
5326 end;
5328 | Next ->
5329 begin match List.rev state.layout with
5330 | l :: _ ->
5331 let layout = layout state.x
5332 (state.y + (pgh state.layout))
5333 state.winw state.winh in
5334 begin match layout with
5335 | [] ->
5336 let incr = l.pageh - l.pagevh in
5337 if incr = 0
5338 then (
5339 state.mode <-
5340 Birdseye (
5341 oconf, leftx, state.pagecount - 1, hooverpageno, anchor
5343 G.postRedisplay "birdseye pagedown";
5345 else gotoxy state.x (clamp (incr + conf.interpagespace*2));
5347 | l :: _ ->
5348 state.mode <-
5349 Birdseye (oconf, leftx, l.pageno, hooverpageno, anchor);
5350 gotopage1 l.pageno 0;
5353 | [] -> gotoxy state.x (clamp state.winh)
5354 end;
5356 | Home ->
5357 state.mode <- Birdseye (oconf, leftx, 0, hooverpageno, anchor);
5358 gotopage1 0 0
5360 | End ->
5361 let pageno = state.pagecount - 1 in
5362 state.mode <- Birdseye (oconf, leftx, pageno, hooverpageno, anchor);
5363 if not (pagevisible state.layout pageno)
5364 then
5365 let h =
5366 match List.rev state.pdims with
5367 | [] -> state.winh
5368 | (_, _, h, _) :: _ -> h
5370 gotoxy
5371 state.x
5372 (max 0 (getpagey pageno - (state.winh - h - conf.interpagespace)))
5373 else G.postRedisplay "birdseye end";
5375 | Delete|Insert|Ascii _|Code _|Fn _|Backspace -> viewkeyboard key mask
5378 let drawpage l =
5379 let color =
5380 match state.mode with
5381 | Textentry _ -> scalecolor 0.4
5382 | LinkNav _ | View -> scalecolor 1.0
5383 | Birdseye (_, _, pageno, hooverpageno, _) ->
5384 if l.pageno = hooverpageno
5385 then scalecolor 0.9
5386 else (
5387 if l.pageno = pageno
5388 then (
5389 let c = scalecolor 1.0 in
5390 GlDraw.color c;
5391 GlDraw.line_width 3.0;
5392 let dispx = l.pagedispx in
5393 linerect
5394 (float (dispx-1)) (float (l.pagedispy-1))
5395 (float (dispx+l.pagevw+1))
5396 (float (l.pagedispy+l.pagevh+1))
5398 GlDraw.line_width 1.0;
5401 else scalecolor 0.8
5404 drawtiles l color;
5407 let postdrawpage l linkindexbase =
5408 match getopaque l.pageno with
5409 | Some opaque ->
5410 if tileready l l.pagex l.pagey
5411 then
5412 let x = l.pagedispx - l.pagex
5413 and y = l.pagedispy - l.pagey in
5414 let hlmask =
5415 match conf.columns with
5416 | Csingle _ | Cmulti _ ->
5417 (if conf.hlinks then 1 else 0)
5418 + (if state.glinks
5419 && not (isbirdseye state.mode) then 2 else 0)
5420 | Csplit _ -> 0
5422 let s =
5423 match state.mode with
5424 | Textentry ((_, s, _, _, _, _), _) when state.glinks -> s
5425 | Textentry _
5426 | Birdseye _
5427 | View
5428 | LinkNav _ -> E.s
5430 Hashtbl.find_all state.prects l.pageno |>
5431 List.iter (fun vals -> drawprect opaque x y vals);
5432 let n = postprocess opaque hlmask x y (linkindexbase, s, conf.hfsize) in
5433 if n < 0
5434 then (state.redisplay <- true; 0)
5435 else n
5436 else 0
5437 | _ -> 0
5440 let scrollindicator () =
5441 let sbw, ph, sh = state.uioh#scrollph in
5442 let sbh, pw, sw = state.uioh#scrollpw in
5444 let x0,x1,hx0 =
5445 if conf.leftscroll
5446 then (0, sbw, sbw)
5447 else ((state.winw - sbw), state.winw, 0)
5450 Gl.enable `blend;
5451 GlFunc.blend_func ~src:`src_alpha ~dst:`one_minus_src_alpha;
5452 GlDraw.color (0.64, 0.64, 0.64) ~alpha:0.7;
5453 filledrect (float x0) 0. (float x1) (float state.winh);
5454 filledrect
5455 (float hx0) (float (state.winh - sbh))
5456 (float (hx0 + state.winw)) (float state.winh)
5458 GlDraw.color (0.0, 0.0, 0.0) ~alpha:0.7;
5460 filledrect (float x0) ph (float x1) (ph +. sh);
5461 let pw = pw +. float hx0 in
5462 filledrect pw (float (state.winh - sbh)) (pw +. sw) (float state.winh);
5463 Gl.disable `blend;
5466 let showsel () =
5467 match state.mstate with
5468 | Mnone | Mscrolly | Mscrollx | Mpan _ | Mzoom _ | Mzoomrect _ ->
5471 | Msel ((x0, y0), (x1, y1)) ->
5472 let identify opaque l px py = Some (opaque, l.pageno, px, py) in
5473 let o0,n0,px0,py0 = onppundermouse identify x0 y0 (~< E.s, -1, 0, 0) in
5474 let _o1,n1,px1,py1 = onppundermouse identify x1 y1 (~< E.s, -1, 0, 0) in
5475 if n0 != -1 && n0 = n1 then seltext o0 (px0, py0, px1, py1);
5478 let showrects =
5479 function [] -> ()
5480 | rects ->
5481 Gl.enable `blend;
5482 GlDraw.color (0.0, 0.0, 1.0) ~alpha:0.5;
5483 GlFunc.blend_func ~src:`src_alpha ~dst:`one_minus_src_alpha;
5484 List.iter
5485 (fun (pageno, c, (x0, y0, x1, y1, x2, y2, x3, y3)) ->
5486 List.iter (fun l ->
5487 if l.pageno = pageno
5488 then (
5489 let dx = float (l.pagedispx - l.pagex) in
5490 let dy = float (l.pagedispy - l.pagey) in
5491 let r, g, b, alpha = c in
5492 GlDraw.color (r, g, b) ~alpha;
5493 filledrect2 (x0+.dx) (y0+.dy)
5494 (x1+.dx) (y1+.dy)
5495 (x3+.dx) (y3+.dy)
5496 (x2+.dx) (y2+.dy);
5498 ) state.layout
5499 ) rects
5501 Gl.disable `blend;
5504 let display () =
5505 begin match conf.columns, state.layout with
5506 | Csingle _, _ :: _ ->
5507 GlDraw.color (scalecolor2 conf.bgcolor);
5508 let y =
5509 List.fold_left (fun y l ->
5510 let x0 = 0 in
5511 let y0 = y in
5512 let x1 = l.pagedispx in
5513 let y1 = (l.pagedispy + l.pagevh) in
5514 filledrect (float x0) (float y0) (float x1) (float y1);
5515 let x0 = x1 + l.pagevw in
5516 let x1 = state.winw in
5517 filledrect1 (float x0) (float y0) (float x1) (float y1);
5518 if y != l.pagedispy
5519 then (
5520 let x0 = 0
5521 and x1 = state.winw in
5522 let y0 = y
5523 and y1 = l.pagedispy in
5524 filledrect1 (float x0) (float y0) (float x1) (float y1);
5526 l.pagedispy + l.pagevh) 0 state.layout
5528 let x0 = 0
5529 and x1 = state.winw in
5530 let y0 = y
5531 and y1 = state.winh in
5532 filledrect1 (float x0) (float y0) (float x1) (float y1)
5533 | (Cmulti _ | Csplit _), _ | Csingle _, [] ->
5534 GlClear.color (scalecolor2 conf.bgcolor);
5535 GlClear.clear [`color];
5536 end;
5537 List.iter drawpage state.layout;
5538 let rects =
5539 match state.mode with
5540 | LinkNav (Ltexact (pageno, linkno)) ->
5541 begin match getopaque pageno with
5542 | Some opaque ->
5543 let x0, y0, x1, y1 = getlinkrect opaque linkno in
5544 let color = (0.0, 0.0, 0.5, 0.5) in
5545 (pageno, color, (
5546 float x0, float y0,
5547 float x1, float y0,
5548 float x1, float y1,
5549 float x0, float y1)
5550 ) :: state.rects
5551 | None -> state.rects
5553 | LinkNav (Ltgendir _) | LinkNav (Ltnotready _)
5554 | Birdseye _
5555 | Textentry _
5556 | View -> state.rects
5558 showrects rects;
5559 let rec postloop linkindexbase = function
5560 | l :: rest ->
5561 let linkindexbase = linkindexbase + postdrawpage l linkindexbase in
5562 postloop linkindexbase rest
5563 | [] -> ()
5565 showsel ();
5566 postloop 0 state.layout;
5567 state.uioh#display;
5568 begin match state.mstate with
5569 | Mzoomrect ((x0, y0), (x1, y1)) ->
5570 Gl.enable `blend;
5571 GlDraw.color (0.3, 0.3, 0.3) ~alpha:0.5;
5572 GlFunc.blend_func ~src:`src_alpha ~dst:`one_minus_src_alpha;
5573 filledrect (float x0) (float y0) (float x1) (float y1);
5574 Gl.disable `blend;
5575 | Msel _
5576 | Mpan _
5577 | Mscrolly | Mscrollx
5578 | Mzoom _
5579 | Mnone -> ()
5580 end;
5581 enttext ();
5582 scrollindicator ();
5583 Wsi.swapb ();
5586 let zoomrect x y x1 y1 =
5587 let x0 = min x x1
5588 and x1 = max x x1
5589 and y0 = min y y1 in
5590 let zoom = (float state.w) /. float (x1 - x0) in
5591 let margin =
5592 let simple () =
5593 if state.w < state.winw
5594 then (state.winw - state.w) / 2
5595 else 0
5597 match conf.fitmodel with
5598 | FitWidth | FitProportional -> simple ()
5599 | FitPage ->
5600 match conf.columns with
5601 | Csplit _ ->
5602 onppundermouse (fun _ l _ _ -> Some l.pagedispx) x0 y0 x0
5603 | Cmulti _ | Csingle _ -> simple ()
5605 gotoxy ((state.x + margin) - x0) (state.y + y0);
5606 state.anchor <- getanchor ();
5607 setzoom zoom;
5608 resetmstate ();
5611 let annot inline x y =
5612 match unproject x y with
5613 | Some (opaque, n, ux, uy) ->
5614 let add text =
5615 addannot opaque ux uy text;
5616 wcmd "freepage %s" (~> opaque);
5617 Hashtbl.remove state.pagemap (n, state.gen);
5618 flushtiles ();
5619 gotoxy state.x state.y
5621 if inline
5622 then
5623 let ondone s = add s in
5624 let mode = state.mode in
5625 state.mode <- Textentry (
5626 ("annotation: ", E.s, None, textentry, ondone, true),
5627 fun _ -> state.mode <- mode);
5628 state.text <- E.s;
5629 enttext ();
5630 G.postRedisplay "annot"
5631 else
5632 add @@ getusertext E.s
5633 | _ -> ()
5636 let zoomblock x y =
5637 let g opaque l px py =
5638 match rectofblock opaque px py with
5639 | Some a ->
5640 let x0 = a.(0) -. 20. in
5641 let x1 = a.(1) +. 20. in
5642 let y0 = a.(2) -. 20. in
5643 let zoom = (float state.w) /. (x1 -. x0) in
5644 let pagey = getpagey l.pageno in
5645 let margin = (state.w - l.pagew)/2 in
5646 let nx = -truncate x0 - margin in
5647 gotoxy_and_clear_text nx (pagey + truncate y0);
5648 state.anchor <- getanchor ();
5649 setzoom zoom;
5650 None
5651 | None -> None
5653 match conf.columns with
5654 | Csplit _ ->
5655 impmsg "block zooming does not work properly in split columns mode"
5656 | Cmulti _ | Csingle _ -> onppundermouse g x y ()
5659 let scrollx x =
5660 let winw = state.winw - 1 in
5661 let s = float x /. float winw in
5662 let destx = truncate (float (state.w + winw) *. s) in
5663 gotoxy_and_clear_text (winw - destx) state.y;
5664 state.mstate <- Mscrollx;
5667 let scrolly y =
5668 let s = float y /. float state.winh in
5669 let desty = truncate (s *. float (maxy ())) in
5670 gotoxy_and_clear_text state.x desty;
5671 state.mstate <- Mscrolly;
5674 let viewmulticlick clicks x y mask =
5675 let g opaque l px py =
5676 let mark =
5677 match clicks with
5678 | 2 -> Mark_word
5679 | 3 -> Mark_line
5680 | 4 -> Mark_block
5681 | _ -> Mark_page
5683 if markunder opaque px py mark
5684 then (
5685 Some (fun () ->
5686 let dopipe cmd =
5687 match getopaque l.pageno with
5688 | None -> ()
5689 | Some opaque -> pipesel opaque cmd
5691 state.roam <- (fun () -> dopipe conf.paxcmd);
5692 if not (Wsi.withctrl mask) then dopipe conf.selcmd;
5695 else None
5697 G.postRedisplay "viewmulticlick";
5698 onppundermouse g x y (fun () -> impmsg "nothing to select") ();
5701 let canselect () =
5702 match conf.columns with
5703 | Csplit _ -> false
5704 | Csingle _ | Cmulti _ -> conf.angle mod 360 = 0
5707 let viewmouse button down x y mask =
5708 match button with
5709 | n when (n == 4 || n == 5) && not down ->
5710 if Wsi.withctrl mask
5711 then (
5712 match state.mstate with
5713 | Mzoom (oldn, i, (ftx, fty)) ->
5714 let recenter =
5715 if false
5716 then abs (ftx - x) > 5 || abs (fty - y) > 5
5717 else false
5719 if oldn = n
5720 then (
5721 if i = 2
5722 then
5723 let incr =
5724 match n with
5725 | 5 ->
5726 if conf.zoom +. 0.01 > 0.1 then 0.1 else 0.01
5727 | _ ->
5728 if conf.zoom -. 0.1 < 0.1 then -0.01 else -0.1
5730 let zoom = conf.zoom -. incr in
5731 if recenter
5732 then pivotzoom ~x ~y zoom
5733 else pivotzoom zoom;
5734 state.mstate <- Mzoom (n, 0, (x, y));
5735 else
5736 state.mstate <- Mzoom (n, i+1, (ftx, fty));
5738 else state.mstate <- Mzoom (n, 0, (ftx, fty))
5740 | Msel _
5741 | Mpan _
5742 | Mscrolly | Mscrollx
5743 | Mzoomrect _
5744 | Mnone -> state.mstate <- Mzoom (n, 0, (0, 0))
5746 else (
5747 match state.autoscroll with
5748 | Some step -> setautoscrollspeed step (n=4)
5749 | None ->
5750 if conf.wheelbypage || conf.presentation
5751 then (
5752 if n = 4
5753 then prevpage ()
5754 else nextpage ()
5756 else
5757 let incr =
5758 if n = 4
5759 then -conf.scrollstep
5760 else conf.scrollstep
5762 let incr = incr * 2 in
5763 let y = clamp incr in
5764 gotoxy_and_clear_text state.x y
5767 | n when (n = 6 || n = 7) && not down && canpan () ->
5768 let x =
5769 panbound (state.x + (if n = 7 then -2 else 2) * conf.hscrollstep) in
5770 gotoxy_and_clear_text x state.y
5772 | 1 when Wsi.withshift mask ->
5773 state.mstate <- Mnone;
5774 if not down
5775 then (
5776 match unproject x y with
5777 | None -> ()
5778 | Some (_, pageno, ux, uy) ->
5779 let cmd = Printf.sprintf
5780 "%s %s %d %d %d"
5781 conf.stcmd state.path pageno ux uy
5783 match spawn cmd [] with
5784 | exception exn ->
5785 impmsg "execution of synctex command(%S) failed: %S"
5786 conf.stcmd @@ exntos exn
5787 | _pid -> ()
5790 | 1 when Wsi.withctrl mask ->
5791 if down
5792 then (
5793 Wsi.setcursor Wsi.CURSOR_FLEUR;
5794 state.mstate <- Mpan (x, y)
5796 else
5797 state.mstate <- Mnone
5799 | 3 ->
5800 if down
5801 then (
5802 if Wsi.withshift mask
5803 then (
5804 annot conf.annotinline x y;
5805 G.postRedisplay "addannot"
5807 else
5808 let p = (x, y) in
5809 Wsi.setcursor Wsi.CURSOR_CYCLE;
5810 state.mstate <- Mzoomrect (p, p)
5812 else (
5813 match state.mstate with
5814 | Mzoomrect ((x0, y0), _) ->
5815 if abs (x-x0) > 10 && abs (y - y0) > 10
5816 then zoomrect x0 y0 x y
5817 else (
5818 resetmstate ();
5819 G.postRedisplay "kill accidental zoom rect";
5821 | Msel _
5822 | Mpan _
5823 | Mscrolly | Mscrollx
5824 | Mzoom _
5825 | Mnone -> resetmstate ()
5828 | 1 when vscrollhit x ->
5829 if down
5830 then
5831 let _, position, sh = state.uioh#scrollph in
5832 if y > truncate position && y < truncate (position +. sh)
5833 then state.mstate <- Mscrolly
5834 else scrolly y
5835 else
5836 state.mstate <- Mnone
5838 | 1 when y > state.winh - hscrollh () ->
5839 if down
5840 then
5841 let _, position, sw = state.uioh#scrollpw in
5842 if x > truncate position && x < truncate (position +. sw)
5843 then state.mstate <- Mscrollx
5844 else scrollx x
5845 else
5846 state.mstate <- Mnone
5848 | 1 when state.bzoom -> if not down then zoomblock x y
5850 | 1 ->
5851 let dest = if down then getunder x y else Unone in
5852 begin match dest with
5853 | Ulinkuri _ ->
5854 gotounder dest
5856 | Unone when down ->
5857 Wsi.setcursor Wsi.CURSOR_FLEUR;
5858 state.mstate <- Mpan (x, y);
5860 | Uannotation (opaque, slinkindex) -> enterannotmode opaque slinkindex
5862 | Unone | Utext _ ->
5863 if down
5864 then (
5865 if canselect ()
5866 then (
5867 state.mstate <- Msel ((x, y), (x, y));
5868 G.postRedisplay "mouse select";
5871 else (
5872 match state.mstate with
5873 | Mnone -> ()
5875 | Mzoom _ | Mscrollx | Mscrolly ->
5876 state.mstate <- Mnone
5878 | Mzoomrect ((x0, y0), _) ->
5879 zoomrect x0 y0 x y
5881 | Mpan _ ->
5882 Wsi.setcursor Wsi.CURSOR_INHERIT;
5883 state.mstate <- Mnone
5885 | Msel ((x0, y0), (x1, y1)) ->
5886 let rec loop = function
5887 | [] -> ()
5888 | l :: rest ->
5889 let inside =
5890 let a0 = l.pagedispy in
5891 let a1 = a0 + l.pagevh in
5892 let b0 = l.pagedispx in
5893 let b1 = b0 + l.pagevw in
5894 ((y0 >= a0 && y0 <= a1) || (y1 >= a0 && y1 <= a1))
5895 && ((x0 >= b0 && x0 <= b1) || (x1 >= b0 && x1 <= b1))
5897 if inside
5898 then
5899 match getopaque l.pageno with
5900 | Some opaque ->
5901 let dosel cmd () =
5902 match Unix.pipe () with
5903 | exception exn ->
5904 impmsg "cannot create sel pipe: %s" @@
5905 exntos exn;
5906 | (r, w) ->
5907 let clo what fd =
5908 Ne.clo fd (fun msg ->
5909 dolog "%s close failed: %s" what msg)
5911 begin match spawn cmd [r, 0; w, -1] with
5912 | exception exn ->
5913 clo "Msel pipe/w" w;
5914 dolog "cannot execute %S: %s" cmd @@ exntos exn
5915 | _pid ->
5916 copysel w opaque;
5917 G.postRedisplay "copysel";
5918 end;
5919 clo "Msel pipe/r" r;
5921 dosel conf.selcmd ();
5922 state.roam <- dosel conf.paxcmd;
5923 | None -> ()
5924 else loop rest
5926 loop state.layout;
5927 resetmstate ();
5931 | _ -> ()
5934 let birdseyemouse button down x y mask
5935 (conf, leftx, _, hooverpageno, anchor) =
5936 match button with
5937 | 1 when down ->
5938 let rec loop = function
5939 | [] -> ()
5940 | l :: rest ->
5941 if y > l.pagedispy && y < l.pagedispy + l.pagevh
5942 && x > l.pagedispx && x < l.pagedispx + l.pagevw
5943 then (
5944 leavebirdseye (conf, leftx, l.pageno, hooverpageno, anchor) false;
5946 else loop rest
5948 loop state.layout
5949 | 3 -> ()
5950 | _ -> viewmouse button down x y mask
5953 let uioh = object
5954 method display = ()
5956 method key key mask =
5957 begin match state.mode with
5958 | Textentry textentry -> textentrykeyboard key mask textentry
5959 | Birdseye birdseye -> birdseyekeyboard key mask birdseye
5960 | View -> viewkeyboard key mask
5961 | LinkNav linknav -> linknavkeyboard key mask linknav
5962 end;
5963 state.uioh
5965 method button button bstate x y mask =
5966 begin match state.mode with
5967 | LinkNav _ | View -> viewmouse button bstate x y mask
5968 | Birdseye beye -> birdseyemouse button bstate x y mask beye
5969 | Textentry _ -> ()
5970 end;
5971 state.uioh
5973 method multiclick clicks x y mask =
5974 begin match state.mode with
5975 | LinkNav _ | View -> viewmulticlick clicks x y mask
5976 | Birdseye _ | Textentry _ -> ()
5977 end;
5978 state.uioh
5980 method motion x y =
5981 begin match state.mode with
5982 | Textentry _ -> ()
5983 | View | Birdseye _ | LinkNav _ ->
5984 match state.mstate with
5985 | Mzoom _ | Mnone -> ()
5987 | Mpan (x0, y0) ->
5988 let dx = x - x0
5989 and dy = y0 - y in
5990 state.mstate <- Mpan (x, y);
5991 let x = if canpan () then panbound (state.x + dx) else state.x in
5992 let y = clamp dy in
5993 gotoxy_and_clear_text x y
5995 | Msel (a, _) ->
5996 state.mstate <- Msel (a, (x, y));
5997 G.postRedisplay "motion select";
5999 | Mscrolly ->
6000 let y = min state.winh (max 0 y) in
6001 scrolly y
6003 | Mscrollx ->
6004 let x = min state.winw (max 0 x) in
6005 scrollx x
6007 | Mzoomrect (p0, _) ->
6008 state.mstate <- Mzoomrect (p0, (x, y));
6009 G.postRedisplay "motion zoomrect";
6010 end;
6011 state.uioh
6013 method pmotion x y =
6014 begin match state.mode with
6015 | Birdseye (conf, leftx, pageno, hooverpageno, anchor) ->
6016 let rec loop = function
6017 | [] ->
6018 if hooverpageno != -1
6019 then (
6020 state.mode <- Birdseye (conf, leftx, pageno, -1, anchor);
6021 G.postRedisplay "pmotion birdseye no hoover";
6023 | l :: rest ->
6024 if y > l.pagedispy && y < l.pagedispy + l.pagevh
6025 && x > l.pagedispx && x < l.pagedispx + l.pagevw
6026 then (
6027 state.mode <- Birdseye (conf, leftx, pageno, l.pageno, anchor);
6028 G.postRedisplay "pmotion birdseye hoover";
6030 else loop rest
6032 loop state.layout
6034 | Textentry _ -> ()
6036 | LinkNav _ | View ->
6037 match state.mstate with
6038 | Mpan _ | Msel _ | Mzoom _ | Mscrolly | Mscrollx | Mzoomrect _ -> ()
6039 | Mnone ->
6040 updateunder x y;
6041 if canselect ()
6042 then
6043 match conf.pax with
6044 | None -> ()
6045 | Some r ->
6046 let past, _, _ = !r in
6047 let now = now () in
6048 let delta = now -. past in
6049 if delta > 0.01
6050 then paxunder x y
6051 else r := (now, x, y)
6052 end;
6053 state.uioh
6055 method infochanged _ = ()
6057 method scrollph =
6058 let maxy = maxy () in
6059 let p, h =
6060 if maxy = 0
6061 then 0.0, float state.winh
6062 else scrollph state.y maxy
6064 vscrollw (), p, h
6066 method scrollpw =
6067 let fwinw = float (state.winw - vscrollw ()) in
6068 let sw =
6069 let sw = fwinw /. float state.w in
6070 let sw = fwinw *. sw in
6071 max sw (float conf.scrollh)
6073 let position =
6074 let maxx = state.w + state.winw in
6075 let x = state.winw - state.x in
6076 let percent = float x /. float maxx in
6077 (fwinw -. sw) *. percent
6079 hscrollh (), position, sw
6081 method modehash =
6082 let modename =
6083 match state.mode with
6084 | LinkNav _ -> "links"
6085 | Textentry _ -> "textentry"
6086 | Birdseye _ -> "birdseye"
6087 | View -> "view"
6089 findkeyhash conf modename
6091 method eformsgs = true
6092 method alwaysscrolly = false
6093 end;;
6095 let addrect pageno r g b a x0 y0 x1 y1 =
6096 Hashtbl.add state.prects pageno [|r; g; b; a; x0; y0; x1; y1|];
6099 let ract cmds =
6100 let cl = splitatchar cmds ' ' in
6101 let scan s fmt f =
6102 try Scanf.sscanf s fmt f
6103 with exn -> adderrfmt "remote exec" "error processing '%S': %s\n"
6104 cmds @@ exntos exn
6106 let rectx s pageno (r, g, b, a) x0 y0 x1 y1 =
6107 vlog "%s page %d color (%f %f %f %f) x0,y0,x1,y1 = %f %f %f %f"
6108 s pageno r g b a x0 y0 x1 y1;
6109 onpagerect
6110 pageno
6111 (fun w h ->
6112 let _,w1,h1,_ = getpagedim pageno in
6113 let sw = float w1 /. float w
6114 and sh = float h1 /. float h in
6115 let x0s = x0 *. sw
6116 and x1s = x1 *. sw
6117 and y0s = y0 *. sh
6118 and y1s = y1 *. sh in
6119 let rect = (x0s,y0s,x1s,y0s,x1s,y1s,x0s,y1s) in
6120 let color = (r, g, b, a) in
6121 if conf.verbose then debugrect rect;
6122 state.rects <- (pageno, color, rect) :: state.rects;
6123 G.postRedisplay s;
6126 match cl with
6127 | "reload", "" -> reload ()
6128 | "goto", args ->
6129 scan args "%u %f %f"
6130 (fun pageno x y ->
6131 let cmd, _ = state.geomcmds in
6132 if emptystr cmd
6133 then gotopagexy !wtmode pageno x y
6134 else
6135 let f prevf () =
6136 gotopagexy !wtmode pageno x y;
6137 prevf ()
6139 state.reprf <- f state.reprf
6141 | "goto1", args -> scan args "%u %f" gotopage
6142 | "gotor", args ->
6143 scan args "%S %u"
6144 (fun _filename _pageno ->
6145 failwith "gotounder (Uremote (filename, pageno))")
6146 | "gotord", args ->
6147 scan args "%S %S"
6148 (fun _filename _dest ->
6149 failwith "gotounder (Uremotedest (filename, dest))")
6150 | "rect", args ->
6151 scan args "%u %u %f %f %f %f"
6152 (fun pageno c x0 y0 x1 y1 ->
6153 let color = (0.0, 0.0, 1.0 /. float c, 0.5) in
6154 rectx "rect" pageno color x0 y0 x1 y1;
6156 | "prect", args ->
6157 scan args "%u %f %f %f %f %f %f %f %f"
6158 (fun pageno r g b alpha x0 y0 x1 y1 ->
6159 addrect pageno r g b alpha x0 y0 x1 y1;
6160 G.postRedisplay "prect"
6162 | "pgoto", args ->
6163 scan args "%u %f %f"
6164 (fun pageno x y ->
6165 let optopaque =
6166 match getopaque pageno with
6167 | Some opaque -> opaque
6168 | None -> ~< E.s
6170 pgoto optopaque pageno x y;
6171 let rec fixx = function
6172 | [] -> ()
6173 | l :: rest ->
6174 if l.pageno = pageno
6175 then gotoxy (state.x - l.pagedispx) state.y
6176 else fixx rest
6178 let layout =
6179 let mult =
6180 match conf.columns with
6181 | Csingle _ | Csplit _ -> 1
6182 | Cmulti ((n, _, _), _) -> n
6184 layout 0 state.y (state.winw * mult) state.winh
6186 fixx layout
6188 | "activatewin", "" -> Wsi.activatewin ()
6189 | "quit", "" -> raise Quit
6190 | "keys", keys ->
6191 begin try
6192 let l = Config.keys_of_string keys in
6193 List.iter (fun (k, m) -> keyboard k m) l
6194 with exn -> adderrfmt "error processing keys" "`%S': %s\n"
6195 cmds @@ exntos exn
6197 | "clearrects", "" ->
6198 Hashtbl.clear state.prects;
6199 G.postRedisplay "clearrects"
6200 | _ ->
6201 adderrfmt "remote command"
6202 "error processing remote command: %S\n" cmds;
6205 let remote =
6206 let scratch = Bytes.create 80 in
6207 let buf = Buffer.create 80 in
6208 fun fd ->
6209 match tempfailureretry (Unix.read fd scratch 0) 80 with
6210 | exception Unix.Unix_error (Unix.EAGAIN, _, _) -> None
6211 | 0 ->
6212 Unix.close fd;
6213 if Buffer.length buf > 0
6214 then (
6215 let s = Buffer.contents buf in
6216 Buffer.clear buf;
6217 ract s;
6219 None
6220 | n ->
6221 let rec eat ppos =
6222 let nlpos =
6223 match Bytes.index_from scratch ppos '\n' with
6224 | pos -> if pos >= n then -1 else pos
6225 | exception Not_found -> -1
6227 if nlpos >= 0
6228 then (
6229 Buffer.add_subbytes buf scratch ppos (nlpos-ppos);
6230 let s = Buffer.contents buf in
6231 Buffer.clear buf;
6232 ract s;
6233 eat (nlpos+1);
6235 else (
6236 Buffer.add_subbytes buf scratch ppos (n-ppos);
6237 Some fd
6239 in eat 0
6242 let remoteopen path =
6243 try Some (Unix.openfile path [Unix.O_NONBLOCK; Unix.O_RDONLY] 0o0)
6244 with exn ->
6245 adderrfmt "remoteopen" "error opening %S: %s" path @@ exntos exn;
6246 None
6249 let () =
6250 let gcconfig = ref E.s in
6251 let trimcachepath = ref E.s in
6252 let rcmdpath = ref E.s in
6253 let pageno = ref None in
6254 let rootwid = ref 0 in
6255 let openlast = ref false in
6256 let nofc = ref false in
6257 let doreap = ref false in
6258 let csspath = ref None in
6259 selfexec := Sys.executable_name;
6260 Arg.parse
6261 (Arg.align
6262 [("-p", Arg.String (fun s -> state.password <- s),
6263 "<password> Set password");
6265 ("-f", Arg.String
6266 (fun s ->
6267 Config.fontpath := s;
6268 selfexec := !selfexec ^ " -f " ^ Filename.quote s;
6270 "<path> Set path to the user interface font");
6272 ("-c", Arg.String
6273 (fun s ->
6274 selfexec := !selfexec ^ " -c " ^ Filename.quote s;
6275 Config.confpath := s),
6276 "<path> Set path to the configuration file");
6278 ("-last", Arg.Set openlast, " Open last document");
6280 ("-page", Arg.Int (fun pageno1 -> pageno := Some (pageno1-1)),
6281 "<page-number> Jump to page");
6283 ("-tcf", Arg.String (fun s -> trimcachepath := s),
6284 "<path> Set path to the trim cache file");
6286 ("-dest", Arg.String (fun s -> state.nameddest <- s),
6287 "<named-destination> Set named destination");
6289 ("-wtmode", Arg.Set wtmode, " Operate in wt mode");
6290 ("-cxack", Arg.Set cxack, " Cut corners");
6292 ("-remote", Arg.String (fun s -> rcmdpath := s),
6293 "<path> Set path to the source of remote commands");
6295 ("-gc", Arg.Set_string gcconfig,
6296 "<path> Collect garbage with the help of a script");
6298 ("-nofc", Arg.Set nofc, " Do not use fontconfig");
6300 ("-v", Arg.Unit (fun () ->
6301 Printf.printf
6302 "%s\nconfiguration path: %s\n"
6303 (version ())
6304 Config.defconfpath;
6305 exit 0), " Print version and exit");
6307 ("-css", Arg.String (fun s -> csspath := Some s),
6308 "<path> Set path to the style sheet to use with EPUB/HTML");
6310 ("-embed", Arg.Set_int rootwid, "<window-id> Embed into window");
6312 ("-origin", Arg.String (fun s -> state.origin <- s),
6313 "<origin> <undocumented>");
6316 (fun s -> state.path <- s)
6317 ("Usage: " ^ Sys.argv.(0) ^ " [options] some.pdf\nOptions:");
6319 if !wtmode
6320 then selfexec := !selfexec ^ " -wtmode";
6322 let histmode = emptystr state.path && not !openlast in
6324 if not (Config.load !openlast)
6325 then dolog "failed to load configuration";
6327 begin match !pageno with
6328 | Some pageno -> state.anchor <- (pageno, 0.0, 0.0)
6329 | None -> ()
6330 end;
6332 if nonemptystr !gcconfig
6333 then (
6334 let (c, s) =
6335 match Unix.socketpair Unix.PF_UNIX Unix.SOCK_STREAM 0 with
6336 | exception exn -> error "socketpair for gc failed: %s" @@ exntos exn
6337 | fds -> fds
6339 match spawn !gcconfig [(c, 0); (c, 1); (s, -1)] with
6340 | exception exn -> error "failed to execute gc script: %s" @@ exntos exn
6341 | _pid ->
6342 Ne.clo c @@ (fun s -> error "failed to close gc fd %s" s);
6343 Config.gc s;
6344 exit 0
6347 let mu =
6348 object (self)
6349 val mutable m_clicks = 0
6350 val mutable m_click_x = 0
6351 val mutable m_click_y = 0
6352 val mutable m_lastclicktime = infinity
6354 method private cleanup =
6355 state.roam <- noroam;
6356 Hashtbl.iter (fun _ opaque -> clearmark opaque) state.pagemap
6357 method expose = G.postRedisplay "expose"
6358 method visible v =
6359 let name =
6360 match v with
6361 | Wsi.Unobscured -> "unobscured"
6362 | Wsi.PartiallyObscured -> "partiallyobscured"
6363 | Wsi.FullyObscured -> "fullyobscured"
6365 vlog "visibility change %s" name
6366 method display = display ()
6367 method map mapped = vlog "mapped %b" mapped
6368 method reshape w h =
6369 self#cleanup;
6370 reshape w h
6371 method mouse b d x y m =
6372 if d && canselect ()
6373 then (
6375 * http://blogs.msdn.com/b/oldnewthing/archive/2004/10/18/243925.aspx
6377 m_click_x <- x;
6378 m_click_y <- y;
6379 if b = 1
6380 then (
6381 let t = now () in
6382 if abs x - m_click_x > 10
6383 || abs y - m_click_y > 10
6384 || abs_float (t -. m_lastclicktime) > 0.3
6385 then m_clicks <- 0;
6386 m_clicks <- m_clicks + 1;
6387 m_lastclicktime <- t;
6388 if m_clicks = 1
6389 then (
6390 self#cleanup;
6391 G.postRedisplay "cleanup";
6392 state.uioh <- state.uioh#button b d x y m;
6394 else state.uioh <- state.uioh#multiclick m_clicks x y m
6396 else (
6397 self#cleanup;
6398 m_clicks <- 0;
6399 m_lastclicktime <- infinity;
6400 state.uioh <- state.uioh#button b d x y m
6403 else (
6404 state.uioh <- state.uioh#button b d x y m
6406 method motion x y =
6407 state.mpos <- (x, y);
6408 state.uioh <- state.uioh#motion x y
6409 method pmotion x y =
6410 state.mpos <- (x, y);
6411 state.uioh <- state.uioh#pmotion x y
6412 method key k m =
6413 let mascm = m land (
6414 Wsi.altmask + Wsi.shiftmask + Wsi.ctrlmask + Wsi.metamask
6415 ) in
6416 let keyboard k m =
6417 let x = state.x and y = state.y in
6418 keyboard k m;
6419 if x != state.x || y != state.y then self#cleanup
6421 match state.keystate with
6422 | KSnone ->
6423 let km = k, mascm in
6424 begin
6425 match
6426 let modehash = state.uioh#modehash in
6427 try Hashtbl.find modehash km
6428 with Not_found ->
6429 try Hashtbl.find (findkeyhash conf "global") km
6430 with Not_found -> KMinsrt (k, m)
6431 with
6432 | KMinsrt (k, m) -> keyboard k m
6433 | KMinsrl l -> List.iter (fun (k, m) -> keyboard k m) l
6434 | KMmulti (l, r) -> state.keystate <- KSinto (l, r)
6436 | KSinto ((k', m') :: [], insrt) when k'=k && m' land mascm = m' ->
6437 List.iter (fun (k, m) -> keyboard k m) insrt;
6438 state.keystate <- KSnone
6439 | KSinto ((k', m') :: keys, insrt) when k'=k && m' land mascm = m' ->
6440 state.keystate <- KSinto (keys, insrt)
6441 | KSinto _ -> state.keystate <- KSnone
6443 method enter x y =
6444 state.mpos <- (x, y);
6445 state.uioh <- state.uioh#pmotion x y
6446 method leave = state.mpos <- (-1, -1)
6447 method winstate wsl = state.winstate <- wsl
6448 method quit = raise Quit
6451 let wsfd, winw, winh = Wsi.init mu !rootwid conf.cwinw conf.cwinh platform in
6453 setbgcol conf.bgcolor;
6454 state.wsfd <- wsfd;
6456 if not @@ List.exists GlMisc.check_extension
6457 [ "GL_ARB_texture_rectangle"
6458 ; "GL_EXT_texture_recangle"
6459 ; "GL_NV_texture_rectangle" ]
6460 then (dolog "OpenGL does not suppport rectangular textures"; exit 1);
6462 if substratis (GlMisc.get_string `renderer) 0 "Mesa DRI Intel("
6463 then (
6464 defconf.sliceheight <- 1024;
6465 defconf.texcount <- 32;
6466 defconf.usepbo <- true;
6469 let cs, ss =
6470 match Unix.socketpair Unix.PF_UNIX Unix.SOCK_STREAM 0 with
6471 | exception exn ->
6472 dolog "socketpair failed: %s" @@ exntos exn;
6473 exit 1
6474 | (r, w) ->
6475 cloexec r;
6476 cloexec w;
6477 r, w
6480 setcheckers conf.checkers;
6482 opengl_has_pbo := GlMisc.check_extension "GL_ARB_pixel_buffer_object";
6484 begin match !csspath with
6485 | None -> ()
6486 | Some "" -> conf.css <- E.s
6487 | Some path ->
6488 let css = filecontents path in
6489 let l = String.length css in
6490 conf.css <-
6491 if substratis css (l-2) "\r\n"
6492 then String.sub css 0 (l-2)
6493 else (if css.[l-1] = '\n'
6494 then String.sub css 0 (l-1)
6495 else css);
6496 end;
6497 init cs (
6498 conf.angle, conf.fitmodel, (conf.trimmargins, conf.trimfuzz),
6499 conf.texcount, conf.sliceheight, conf.mustoresize, conf.colorspace,
6500 !Config.fontpath, !trimcachepath, !opengl_has_pbo, not !nofc
6502 List.iter GlArray.enable [`texture_coord; `vertex];
6503 state.ss <- ss;
6504 reshape ~firsttime:true winw winh;
6505 state.uioh <- uioh;
6506 if histmode
6507 then (
6508 Wsi.settitle "llpp (history)";
6509 enterhistmode ();
6511 else (
6512 state.text <- "Opening " ^ (mbtoutf8 state.path);
6513 opendoc state.path state.password;
6515 display ();
6516 Wsi.mapwin ();
6517 Wsi.setcursor Wsi.CURSOR_INHERIT;
6518 Sys.set_signal Sys.sighup (Sys.Signal_handle (fun _ -> reload ()));
6520 let rec reap () =
6521 match Unix.waitpid [Unix.WNOHANG] ~-1 with
6522 | exception (Unix.Unix_error (Unix.ECHILD, _, _)) -> ()
6523 | exception exn -> dolog "Unix.waitpid: %s" @@ exntos exn
6524 | 0, _ -> ()
6525 | _pid, _status -> reap ()
6527 Sys.set_signal Sys.sigchld (Sys.Signal_handle (fun _ -> doreap := true));
6529 let optrfd =
6530 ref (
6531 if nonemptystr !rcmdpath
6532 then remoteopen !rcmdpath
6533 else None
6537 let rec loop deadline =
6538 if !doreap
6539 then (
6540 doreap := false;
6541 reap ()
6543 let r = [state.ss; state.wsfd] in
6544 let r =
6545 match !optrfd with
6546 | None -> r
6547 | Some fd -> fd :: r
6549 if state.redisplay
6550 then (
6551 state.redisplay <- false;
6552 display ();
6554 let timeout =
6555 let now = now () in
6556 if deadline > now
6557 then (
6558 if deadline = infinity
6559 then ~-.1.0
6560 else max 0.0 (deadline -. now)
6562 else 0.0
6564 let r, _, _ =
6565 try Unix.select r [] [] timeout
6566 with Unix.Unix_error (Unix.EINTR, _, _) -> [], [], []
6568 begin match r with
6569 | [] ->
6570 state.ghyll None;
6571 let newdeadline =
6572 if state.ghyll == noghyll
6573 then
6574 match state.autoscroll with
6575 | Some step when step != 0 ->
6576 let y = state.y + step in
6577 let fy = maxy () in
6578 let y =
6579 if y < 0
6580 then state.maxy - fy
6581 else if y >= state.maxy - fy then 0 else y
6583 if state.mode = View
6584 then gotoxy_and_clear_text state.x y
6585 else gotoxy state.x y;
6586 deadline +. 0.01
6587 | _ -> infinity
6588 else deadline +. 0.01
6590 loop newdeadline
6592 | l ->
6593 let rec checkfds = function
6594 | [] -> ()
6595 | fd :: rest when fd = state.ss ->
6596 let cmd = rcmd state.ss in
6597 act cmd;
6598 checkfds rest
6600 | fd :: rest when fd = state.wsfd ->
6601 Wsi.readresp fd;
6602 checkfds rest
6604 | fd :: rest when Some fd = !optrfd ->
6605 begin match remote fd with
6606 | None -> optrfd := remoteopen !rcmdpath;
6607 | opt -> optrfd := opt
6608 end;
6609 checkfds rest
6611 | _ :: rest ->
6612 dolog "select returned unknown descriptor";
6613 checkfds rest
6615 checkfds l;
6616 let newdeadline =
6617 let deadline1 =
6618 if deadline = infinity
6619 then now () +. 0.01
6620 else deadline
6622 match state.autoscroll with
6623 | Some step when step != 0 -> deadline1
6624 | _ -> if state.ghyll == noghyll then infinity else deadline1
6626 loop newdeadline
6627 end;
6629 match loop infinity with
6630 | exception Quit ->
6631 Config.save leavebirdseye;
6632 if hasunsavedchanges ()
6633 then save ()
6634 | _ -> error "umpossible - infinity reached"