Hide veritcal scroll bar when not needed
[llpp.git] / main.ml
blob1be78fb322160e4fa115bd97f0f91a02ebfd9355
1 open Utils;;
2 open Config;;
4 exception Quit;;
6 external init : Unix.file_descr -> params -> 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";;
54 let selfexec = ref E.s;;
55 let opengl_has_pbo = ref false;;
57 let drawstring size x y s =
58 Gl.enable `blend;
59 Gl.enable `texture_2d;
60 GlFunc.blend_func ~src:`src_alpha ~dst:`one_minus_src_alpha;
61 ignore (drawstr size x y s);
62 Gl.disable `blend;
63 Gl.disable `texture_2d;
66 let drawstring1 size x y s =
67 drawstr size x y s;
70 let drawstring2 size x y fmt =
71 Printf.kprintf (drawstring size (x+1) (y+size+1)) fmt
74 let _debugl l =
75 dolog "l %d dim=%d {" l.pageno l.pagedimno;
76 dolog " WxH %dx%d" l.pagew l.pageh;
77 dolog " vWxH %dx%d" l.pagevw l.pagevh;
78 dolog " pagex,y %d,%d" l.pagex l.pagey;
79 dolog " dispx,y %d,%d" l.pagedispx l.pagedispy;
80 dolog " column %d" l.pagecol;
81 dolog "}";
84 let debugrect (x0, y0, x1, y1, x2, y2, x3, y3) =
85 dolog "rect {";
86 dolog " x0,y0=(% f, % f)" x0 y0;
87 dolog " x1,y1=(% f, % f)" x1 y1;
88 dolog " x2,y2=(% f, % f)" x2 y2;
89 dolog " x3,y3=(% f, % f)" x3 y3;
90 dolog "}";
93 let isbirdseye = function
94 | Birdseye _ -> true
95 | Textentry _
96 | View
97 | LinkNav _ -> false
100 let istextentry = function
101 | Textentry _ -> true
102 | Birdseye _
103 | View
104 | LinkNav _ -> false
107 let wtmode = ref false;;
108 let cxack = ref false;;
110 let pgscale h = truncate (float h *. conf.pgscale);;
112 let hscrollh () =
113 if not state.uioh#alwaysscrolly && (conf.scrollb land scrollbhv = 0)
114 || (state.x = 0 && state.w <= state.winw)
115 then 0
116 else conf.scrollbw
119 let vscrollw () =
120 if not state.uioh#alwaysscrolly && (conf.scrollb land scrollbvv = 0)
121 || (state.maxy < state.winh)
122 then 0
123 else conf.scrollbw
126 let vscrollhit x =
127 if conf.leftscroll
128 then x < vscrollw ()
129 else x > state.winw - vscrollw ()
132 let setfontsize n =
133 fstate.fontsize <- n;
134 fstate.wwidth <- measurestr fstate.fontsize "w";
135 fstate.maxrows <- (state.winh - fstate.fontsize - 1) / (fstate.fontsize + 1);
138 let vlog fmt =
139 if conf.verbose
140 then dolog fmt
141 else Printf.kprintf ignore fmt
144 let launchpath () =
145 if emptystr conf.pathlauncher
146 then dolog "%s" state.path
147 else (
148 let command = Str.global_replace percentsre state.path conf.pathlauncher in
149 match spawn command [] with
150 | _pid -> ()
151 | (exception exn) ->
152 dolog "failed to execute `%s': %s" command @@ exntos exn
156 module G =
157 struct
158 let postRedisplay who =
159 vlog "redisplay for [%S]" who;
160 state.redisplay <- true;
162 end;;
164 let getopaque pageno =
165 try Some (Hashtbl.find state.pagemap (pageno, state.gen))
166 with Not_found -> None
169 let pagetranslatepoint l x y =
170 let dy = y - l.pagedispy in
171 let y = dy + l.pagey in
172 let dx = x - l.pagedispx in
173 let x = dx + l.pagex in
174 (x, y);
177 let onppundermouse g x y d =
178 let rec f = function
179 | l :: rest ->
180 begin match getopaque l.pageno with
181 | Some opaque ->
182 let x0 = l.pagedispx in
183 let x1 = x0 + l.pagevw in
184 let y0 = l.pagedispy in
185 let y1 = y0 + l.pagevh in
186 if y >= y0 && y <= y1 && x >= x0 && x <= x1
187 then
188 let px, py = pagetranslatepoint l x y in
189 match g opaque l px py with
190 | Some res -> res
191 | None -> f rest
192 else f rest
193 | _ ->
194 f rest
196 | [] -> d
198 f state.layout
201 let getunder x y =
202 let g opaque l px py =
203 if state.bzoom
204 then (
205 match rectofblock opaque px py with
206 | Some [|x0;x1;y0;y1|] ->
207 let rect = (x0, y0, x1, y0, x1, y1, x0, y1) in
208 let color = (0.0, 0.0, 1.0 /. (l.pageno mod 3 |> float), 0.5) in
209 state.rects <- [l.pageno, color, rect];
210 G.postRedisplay "getunder";
211 | _otherwise -> ()
213 let under = whatsunder opaque px py in
214 if under = Unone then None else Some under
216 onppundermouse g x y Unone
219 let unproject x y =
220 let g opaque l x y =
221 match unproject opaque x y with
222 | Some (x, y) -> Some (Some (opaque, l.pageno, x, y))
223 | None -> None
225 onppundermouse g x y None;
228 let showtext c s =
229 state.text <- Printf.sprintf "%c%s" c s;
230 G.postRedisplay "showtext";
233 let impmsg fmt =
234 Format.ksprintf (fun s -> showtext '!' s) fmt;
237 let pipesel opaque cmd =
238 if hassel opaque
239 then
240 match Unix.pipe () with
241 | (exception exn) -> dolog "pipesel cannot create pipe: %S" @@ exntos exn;
242 | (r, w) ->
243 let doclose what fd =
244 Ne.clo fd (fun msg -> dolog "%s close failed: %s" what msg)
246 let pid =
247 try spawn cmd [r, 0; w, -1]
248 with exn ->
249 dolog "cannot execute %S: %s" cmd @@ exntos exn;
252 if pid > 0
253 then (
254 copysel w opaque;
255 G.postRedisplay "pipesel";
257 else doclose "pipesel pipe/w" w;
258 doclose "pipesel pipe/r" r;
261 let paxunder x y =
262 let g opaque l px py =
263 if markunder opaque px py conf.paxmark
264 then (
265 Some (fun () ->
266 match getopaque l.pageno with
267 | None -> ()
268 | Some opaque -> pipesel opaque conf.paxcmd
271 else None
273 G.postRedisplay "paxunder";
274 if conf.paxmark = Mark_page
275 then
276 List.iter (fun l ->
277 match getopaque l.pageno with
278 | None -> ()
279 | Some opaque -> clearmark opaque) state.layout;
280 state.roam <- onppundermouse g x y (fun () -> impmsg "whoopsie daisy");
283 let selstring s =
284 match Unix.pipe () with
285 | (exception exn) -> impmsg "pipe failed: %s" @@ exntos exn
286 | (r, w) ->
287 let clo cap fd =
288 Ne.clo fd (fun msg -> impmsg "failed to close %s: %s" cap msg)
290 let pid =
291 try spawn conf.selcmd [r, 0; w, -1]
292 with exn ->
293 impmsg "failed to execute %s: %s" conf.selcmd @@ exntos exn;
296 if pid > 0
297 then (
299 let l = String.length s in
300 let bytes = Bytes.unsafe_of_string s in
301 let n = tempfailureretry (Unix.write w bytes 0) l in
302 if n != l
303 then impmsg "failed to write %d characters to sel pipe, wrote %d"
305 with exn ->
306 impmsg "failed to write to sel pipe: %s" @@ exntos exn
308 else dolog "%s" s;
309 clo "selstring pipe/r" r;
310 clo "selstring pipe/w" w;
313 let undertext ?(nopath=false) = function
314 | Unone -> "none"
315 | Ulinkuri s -> s
316 | Ulinkgoto (pageno, _) ->
317 if nopath
318 then "page " ^ string_of_int (pageno+1)
319 else Printf.sprintf "%s: page %d" state.path (pageno+1)
320 | Utext s -> "font: " ^ s
321 | Uunexpected s -> "unexpected: " ^ s
322 | Ulaunch s -> "launch: " ^ s
323 | Unamed s -> "named: " ^ s
324 | Uremote (filename, pageno) ->
325 Printf.sprintf "%s: page %d" filename (pageno+1)
326 | Uremotedest (filename, destname) ->
327 Printf.sprintf "%s: destination %S" filename destname
328 | Uannotation (opaque, slinkindex) ->
329 "annotation: " ^ getannotcontents opaque slinkindex
332 let updateunder x y =
333 match getunder x y with
334 | Unone -> Wsi.setcursor Wsi.CURSOR_INHERIT
335 | Ulinkuri uri ->
336 if conf.underinfo then showtext 'u' ("ri: " ^ uri);
337 Wsi.setcursor Wsi.CURSOR_INFO
338 | Ulinkgoto (pageno, _) ->
339 if conf.underinfo
340 then showtext 'p' ("age: " ^ string_of_int (pageno+1));
341 Wsi.setcursor Wsi.CURSOR_INFO
342 | Utext s ->
343 if conf.underinfo then showtext 'f' ("ont: " ^ s);
344 Wsi.setcursor Wsi.CURSOR_TEXT
345 | Uunexpected s ->
346 if conf.underinfo then showtext 'u' ("nexpected: " ^ s);
347 Wsi.setcursor Wsi.CURSOR_INHERIT
348 | Ulaunch s ->
349 if conf.underinfo then showtext 'l' ("aunch: " ^ s);
350 Wsi.setcursor Wsi.CURSOR_INHERIT
351 | Unamed s ->
352 if conf.underinfo then showtext 'n' ("amed: " ^ s);
353 Wsi.setcursor Wsi.CURSOR_INHERIT
354 | Uremote (filename, pageno) ->
355 if conf.underinfo then showtext 'r'
356 (Printf.sprintf "emote: %s (%d)" filename (pageno+1));
357 Wsi.setcursor Wsi.CURSOR_INFO
358 | Uremotedest (filename, destname) ->
359 if conf.underinfo then showtext 'r'
360 (Printf.sprintf "emote destination: %s (%S)" filename destname);
361 Wsi.setcursor Wsi.CURSOR_INFO
362 | Uannotation _ ->
363 if conf.underinfo then showtext 'a' "nnotation";
364 Wsi.setcursor Wsi.CURSOR_INFO
367 let showlinktype under =
368 if conf.underinfo && under != Unone
369 then showtext ' ' @@ undertext under
372 let intentry_with_suffix text key =
373 let text =
374 if key >= 32 && key < 127
375 then
376 let c = Char.chr key in
377 match c with
378 | '0' .. '9' ->
379 addchar text c
381 | 'k' | 'm' | 'g' | 'K' | 'M' | 'G' ->
382 addchar text @@ asciilower c
383 | _ ->
384 state.text <- Printf.sprintf "invalid key (%d, `%c')" key c;
385 text
386 else (
387 state.text <- Printf.sprintf "invalid key %d" key;
388 text
391 TEcont text
394 let wcmd fmt =
395 let b = Buffer.create 16 in
396 Buffer.add_string b "llll";
397 Printf.kbprintf
398 (fun b ->
399 let b = Buffer.to_bytes b in
400 wcmd state.ss b @@ Bytes.length b
401 ) b fmt
404 let nogeomcmds cmds =
405 match cmds with
406 | s, [] -> emptystr s
407 | _ -> false
410 let layoutN ((columns, coverA, coverB), b) x y sw sh =
411 let rec fold accu n =
412 if n = Array.length b
413 then accu
414 else
415 let pdimno, dx, vy, (_, w, h, xoff) = b.(n) in
416 if (vy - y) > sh &&
417 (n = coverA - 1
418 || n = state.pagecount - coverB
419 || (n - coverA) mod columns = columns - 1)
420 then accu
421 else
422 let accu =
423 if vy + h > y
424 then
425 let pagey = max 0 (y - vy) in
426 let pagedispy = if pagey > 0 then 0 else vy - y in
427 let pagedispx, pagex =
428 let pdx =
429 if n = coverA - 1 || n = state.pagecount - coverB
430 then x + (sw - w) / 2
431 else dx + xoff + x
433 if pdx < 0
434 then 0, -pdx
435 else pdx, 0
437 let pagevw =
438 let vw = sw - pagedispx in
439 let pw = w - pagex in
440 min vw pw
442 let pagevh = min (h - pagey) (sh - pagedispy) in
443 if pagevw > 0 && pagevh > 0
444 then
445 let e =
446 { pageno = n
447 ; pagedimno = pdimno
448 ; pagew = w
449 ; pageh = h
450 ; pagex = pagex
451 ; pagey = pagey
452 ; pagevw = pagevw
453 ; pagevh = pagevh
454 ; pagedispx = pagedispx
455 ; pagedispy = pagedispy
456 ; pagecol = 0
459 e :: accu
460 else
461 accu
462 else
463 accu
465 fold accu (n+1)
467 if Array.length b = 0
468 then []
469 else List.rev (fold [] (page_of_y y))
472 let layoutS (columns, b) x y sw sh =
473 let rec fold accu n =
474 if n = Array.length b
475 then accu
476 else
477 let pdimno, px, vy, (_, pagew, pageh, xoff) = b.(n) in
478 if (vy - y) > sh
479 then accu
480 else
481 let accu =
482 if vy + pageh > y
483 then
484 let x = xoff + x in
485 let pagey = max 0 (y - vy) in
486 let pagedispy = if pagey > 0 then 0 else vy - y in
487 let pagedispx, pagex =
488 if px = 0
489 then (
490 if x < 0
491 then 0, -x
492 else x, 0
494 else (
495 let px = px - x in
496 if px < 0
497 then -px, 0
498 else 0, px
501 let pagecolw = pagew/columns in
502 let pagedispx =
503 if pagecolw < sw
504 then pagedispx + ((sw - pagecolw) / 2)
505 else pagedispx
507 let pagevw =
508 let vw = sw - pagedispx in
509 let pw = pagew - pagex in
510 min vw pw
512 let pagevw = min pagevw pagecolw in
513 let pagevh = min (pageh - pagey) (sh - pagedispy) in
514 if pagevw > 0 && pagevh > 0
515 then
516 let e =
517 { pageno = n/columns
518 ; pagedimno = pdimno
519 ; pagew = pagew
520 ; pageh = pageh
521 ; pagex = pagex
522 ; pagey = pagey
523 ; pagevw = pagevw
524 ; pagevh = pagevh
525 ; pagedispx = pagedispx
526 ; pagedispy = pagedispy
527 ; pagecol = n mod columns
530 e :: accu
531 else
532 accu
533 else
534 accu
536 fold accu (n+1)
538 List.rev (fold [] 0)
541 let layout x y sw sh =
542 if nogeomcmds state.geomcmds
543 then
544 match conf.columns with
545 | Csingle b -> layoutN ((1, 0, 0), b) x y sw sh
546 | Cmulti c -> layoutN c x y sw sh
547 | Csplit s -> layoutS s x y sw sh
548 else []
551 let clamp incr =
552 let y = state.y + incr in
553 let y = max 0 y in
554 let y = min y (state.maxy - (if conf.maxhfit then state.winh else 0)) in
558 let itertiles l f =
559 let tilex = l.pagex mod conf.tilew in
560 let tiley = l.pagey mod conf.tileh in
562 let col = l.pagex / conf.tilew in
563 let row = l.pagey / conf.tileh in
565 let rec rowloop row y0 dispy h =
566 if h = 0
567 then ()
568 else (
569 let dh = conf.tileh - y0 in
570 let dh = min h dh in
571 let rec colloop col x0 dispx w =
572 if w = 0
573 then ()
574 else (
575 let dw = conf.tilew - x0 in
576 let dw = min w dw in
577 f col row dispx dispy x0 y0 dw dh;
578 colloop (col+1) 0 (dispx+dw) (w-dw)
581 colloop col tilex l.pagedispx l.pagevw;
582 rowloop (row+1) 0 (dispy+dh) (h-dh)
585 if l.pagevw > 0 && l.pagevh > 0
586 then rowloop row tiley l.pagedispy l.pagevh;
589 let gettileopaque l col row =
590 let key =
591 l.pageno, state.gen, conf.colorspace, conf.angle, l.pagew, l.pageh, col, row
593 try Some (Hashtbl.find state.tilemap key)
594 with Not_found -> None
597 let puttileopaque l col row gen colorspace angle opaque size elapsed =
598 let key = l.pageno, gen, colorspace, angle, l.pagew, l.pageh, col, row in
599 Hashtbl.add state.tilemap key (opaque, size, elapsed)
602 let filledrect2 x0 y0 x1 y1 x2 y2 x3 y3 =
603 Raw.sets_float state.vraw ~pos:0 [| x0; y0; x1; y1; x2; y2; x3; y3 |];
604 GlArray.vertex `two state.vraw;
605 GlArray.draw_arrays `triangle_strip ~first:0 ~count:4;
608 let filledrect1 x0 y0 x1 y1 = filledrect2 x0 y0 x0 y1 x1 y0 x1 y1;;
610 let filledrect x0 y0 x1 y1 =
611 GlArray.disable `texture_coord;
612 filledrect1 x0 y0 x1 y1;
613 GlArray.enable `texture_coord;
616 let linerect x0 y0 x1 y1 =
617 GlArray.disable `texture_coord;
618 Raw.sets_float state.vraw ~pos:0 [| x0; y0; x0; y1; x1; y1; x1; y0 |];
619 GlArray.vertex `two state.vraw;
620 GlArray.draw_arrays `line_loop ~first:0 ~count:4;
621 GlArray.enable `texture_coord;
624 let drawtiles l color =
625 GlDraw.color color;
626 begintiles ();
627 let f col row x y tilex tiley w h =
628 match gettileopaque l col row with
629 | Some (opaque, _, t) ->
630 let params = x, y, w, h, tilex, tiley in
631 if conf.invert
632 then GlTex.env (`mode `blend);
633 drawtile params opaque;
634 if conf.invert
635 then GlTex.env (`mode `modulate);
636 if conf.debug
637 then (
638 endtiles ();
639 let s = Printf.sprintf
640 "%d[%d,%d] %f sec"
641 l.pageno col row t
643 let w = measurestr fstate.fontsize s in
644 GlDraw.color (0.0, 0.0, 0.0);
645 filledrect (float (x-2))
646 (float (y-2))
647 (float (x+2) +. w)
648 (float (y + fstate.fontsize + 2));
649 GlDraw.color color;
650 drawstring fstate.fontsize x (y + fstate.fontsize - 1) s;
651 begintiles ();
654 | None ->
655 endtiles ();
656 let w =
657 let lw = state.winw - x in
658 min lw w
659 and h =
660 let lh = state.winh - y in
661 min lh h
663 if conf.invert
664 then GlTex.env (`mode `blend);
665 begin match state.checkerstexid with
666 | Some id ->
667 Gl.enable `texture_2d;
668 GlTex.bind_texture ~target:`texture_2d id;
669 let x0 = float x
670 and y0 = float y
671 and x1 = float (x+w)
672 and y1 = float (y+h) in
674 let tw = float w /. 16.0
675 and th = float h /. 16.0 in
676 let tx0 = float tilex /. 16.0
677 and ty0 = float tiley /. 16.0 in
678 let tx1 = tx0 +. tw
679 and ty1 = ty0 +. th in
680 Raw.sets_float state.vraw ~pos:0
681 [| x0; y0; x0; y1; x1; y0; x1; y1 |];
682 Raw.sets_float state.traw ~pos:0
683 [| tx0; ty0; tx0; ty1; tx1; ty0; tx1; ty1 |];
684 GlArray.vertex `two state.vraw;
685 GlArray.tex_coord `two state.traw;
686 GlArray.draw_arrays `triangle_strip ~first:0 ~count:4;
687 Gl.disable `texture_2d;
689 | None ->
690 GlDraw.color (1.0, 1.0, 1.0);
691 filledrect (float x) (float y) (float (x+w)) (float (y+h));
692 end;
693 if conf.invert
694 then GlTex.env (`mode `modulate);
695 if w > 128 && h > fstate.fontsize + 10
696 then (
697 let c = if conf.invert then 1.0 else 0.0 in
698 GlDraw.color (c, c, c);
699 let c, r =
700 if conf.verbose
701 then (col*conf.tilew, row*conf.tileh)
702 else col, row
704 drawstring2 fstate.fontsize x y "Loading %d [%d,%d]" l.pageno c r;
706 GlDraw.color color;
707 begintiles ();
709 itertiles l f;
710 endtiles ();
713 let pagevisible layout n = List.exists (fun l -> l.pageno = n) layout;;
715 let tilevisible1 l x y =
716 let ax0 = l.pagex
717 and ax1 = l.pagex + l.pagevw
718 and ay0 = l.pagey
719 and ay1 = l.pagey + l.pagevh in
721 let bx0 = x
722 and by0 = y in
723 let bx1 = min (bx0 + conf.tilew) l.pagew
724 and by1 = min (by0 + conf.tileh) l.pageh in
726 let rx0 = max ax0 bx0
727 and ry0 = max ay0 by0
728 and rx1 = min ax1 bx1
729 and ry1 = min ay1 by1 in
731 let nonemptyintersection = rx1 > rx0 && ry1 > ry0 in
732 nonemptyintersection
735 let tilevisible layout n x y =
736 let rec findpageinlayout m = function
737 | l :: rest when l.pageno = n ->
738 tilevisible1 l x y || (
739 match conf.columns with
740 | Csplit (c, _) when c > m -> findpageinlayout (m+1) rest
741 | Csplit _
742 | Csingle _
743 | Cmulti _ -> false
745 | _ :: rest -> findpageinlayout 0 rest
746 | [] -> false
748 findpageinlayout 0 layout;
751 let tileready l x y =
752 tilevisible1 l x y &&
753 gettileopaque l (x/conf.tilew) (y/conf.tileh) != None
756 let tilepage n p layout =
757 let rec loop = function
758 | l :: rest ->
759 if l.pageno = n
760 then
761 let f col row _ _ _ _ _ _ =
762 if state.currently = Idle
763 then
764 match gettileopaque l col row with
765 | Some _ -> ()
766 | None ->
767 let x = col*conf.tilew
768 and y = row*conf.tileh in
769 let w =
770 let w = l.pagew - x in
771 min w conf.tilew
773 let h =
774 let h = l.pageh - y in
775 min h conf.tileh
777 let pbo =
778 if conf.usepbo
779 then getpbo w h conf.colorspace
780 else ~< "0"
782 wcmd "tile %s %d %d %d %d %s"
783 (~> p) x y w h (~> pbo);
784 state.currently <-
785 Tiling (
786 l, p, conf.colorspace, conf.angle,
787 state.gen, col, row, conf.tilew, conf.tileh
790 itertiles l f;
791 else
792 loop rest
794 | [] -> ()
796 if nogeomcmds state.geomcmds
797 then loop layout;
800 let preloadlayout x y sw sh =
801 let y = if y < sh then 0 else y - sh in
802 let x = min 0 (x + sw) in
803 let h = sh*3 in
804 let w = sw*3 in
805 layout x y w h;
808 let load pages =
809 let rec loop pages =
810 if state.currently != Idle
811 then ()
812 else
813 match pages with
814 | l :: rest ->
815 begin match getopaque l.pageno with
816 | None ->
817 wcmd "page %d %d" l.pageno l.pagedimno;
818 state.currently <- Loading (l, state.gen);
819 | Some opaque ->
820 tilepage l.pageno opaque pages;
821 loop rest
822 end;
823 | _ -> ()
825 if nogeomcmds state.geomcmds
826 then loop pages
829 let preload pages =
830 load pages;
831 if conf.preload && state.currently = Idle
832 then load (preloadlayout state.x state.y state.winw state.winh);
835 let layoutready layout =
836 let rec fold all ls =
837 all && match ls with
838 | l :: rest ->
839 let seen = ref false in
840 let allvisible = ref true in
841 let foo col row _ _ _ _ _ _ =
842 seen := true;
843 allvisible := !allvisible &&
844 begin match gettileopaque l col row with
845 | Some _ -> true
846 | None -> false
849 itertiles l foo;
850 fold (!seen && !allvisible) rest
851 | [] -> true
853 let alltilesvisible = fold true layout in
854 alltilesvisible;
857 let gotoxy x y =
858 let y = bound y 0 state.maxy in
859 let y, layout, proceed =
860 match conf.maxwait with
861 | Some time when state.ghyll == noghyll ->
862 begin match state.throttle with
863 | None ->
864 let layout = layout x y state.winw state.winh in
865 let ready = layoutready layout in
866 if not ready
867 then (
868 load layout;
869 state.throttle <- Some (layout, y, now ());
871 else G.postRedisplay "gotoxy showall (None)";
872 y, layout, ready
873 | Some (_, _, started) ->
874 let dt = now () -. started in
875 if dt > time
876 then (
877 state.throttle <- None;
878 let layout = layout x y state.winw state.winh in
879 load layout;
880 G.postRedisplay "maxwait";
881 y, layout, true
883 else -1, [], false
886 | _ ->
887 let layout = layout x y state.winw state.winh in
888 if not !wtmode || layoutready layout
889 then G.postRedisplay "gotoxy ready";
890 y, layout, true
892 if proceed
893 then (
894 state.x <- x;
895 state.y <- y;
896 state.layout <- layout;
897 begin match state.mode with
898 | LinkNav ln ->
899 begin match ln with
900 | Ltexact (pageno, linkno) ->
901 let rec loop = function
902 | [] ->
903 state.mode <- LinkNav (Ltgendir 0)
904 | l :: _ when l.pageno = pageno ->
905 begin match getopaque pageno with
906 | None -> state.mode <- LinkNav (Ltnotready (pageno, 0))
907 | Some opaque ->
908 let x0, y0, x1, y1 = getlinkrect opaque linkno in
909 if not (x0 >= l.pagex && x1 <= l.pagex + l.pagevw
910 && y0 >= l.pagey && y1 <= l.pagey + l.pagevh)
911 then state.mode <- LinkNav (Ltgendir 0)
913 | _ :: rest -> loop rest
915 loop layout
916 | Ltnotready _ | Ltgendir _ -> ()
918 | Birdseye _
919 | Textentry _
920 | View -> ()
921 end;
922 begin match state.mode with
923 | Birdseye (conf, leftx, pageno, hooverpageno, anchor) ->
924 if not (pagevisible layout pageno)
925 then (
926 match state.layout with
927 | [] -> ()
928 | l :: _ ->
929 state.mode <- Birdseye (
930 conf, leftx, l.pageno, hooverpageno, anchor
933 | LinkNav lt ->
934 begin match lt with
935 | Ltnotready (_, dir)
936 | Ltgendir dir ->
937 let linknav =
938 let rec loop = function
939 | [] -> lt
940 | l :: rest ->
941 match getopaque l.pageno with
942 | None -> Ltnotready (l.pageno, dir)
943 | Some opaque ->
944 let link =
945 let ld =
946 if dir = 0
947 then LDfirstvisible (l.pagex, l.pagey, dir)
948 else (
949 if dir > 0 then LDfirst else LDlast
952 findlink opaque ld
954 match link with
955 | Lnotfound -> loop rest
956 | Lfound n ->
957 showlinktype (getlink opaque n);
958 Ltexact (l.pageno, n)
960 loop state.layout
962 state.mode <- LinkNav linknav
963 | Ltexact _ -> ()
965 | Textentry _
966 | View -> ()
967 end;
968 preload layout;
970 state.ghyll <- noghyll;
971 if conf.updatecurs
972 then (
973 let mx, my = state.mpos in
974 updateunder mx my;
978 let conttiling pageno opaque =
979 tilepage pageno opaque
980 (if conf.preload
981 then preloadlayout state.x state.y state.winw state.winh
982 else state.layout)
985 let gotoxy_and_clear_text x y =
986 if not conf.verbose then state.text <- E.s;
987 gotoxy x y;
990 let getanchory (n, top, dtop) =
991 let y, h = getpageyh n in
992 if conf.presentation
993 then
994 let ips = calcips h in
995 y + truncate (top*.float h -. dtop*.float ips) + ips;
996 else
997 y + truncate (top*.float h -. dtop*.float conf.interpagespace)
1000 let gotoanchor anchor =
1001 gotoxy state.x (getanchory anchor);
1004 let addnav () =
1005 cbput state.hists.nav (getanchor ());
1008 let getnav dir =
1009 let anchor = cbgetc state.hists.nav dir in
1010 getanchory anchor;
1013 let gotoghyll1 single y =
1014 let scroll f n a b =
1015 (* http://devmaster.net/forums/topic/9796-ease-in-ease-out-algorithm/ *)
1016 let snake f a b =
1017 let s x = 3.0*.x**2.0 -. 2.0*.x**3.0 in
1018 if f < a
1019 then s (float f /. float a)
1020 else (
1021 if f > b
1022 then 1.0 -. s ((float (f-b) /. float (n-b)))
1023 else 1.0
1026 snake f a b
1027 and summa n a b =
1028 let ins = float a *. 0.5
1029 and outs = float (n-b) *. 0.5 in
1030 let ones = b - a in
1031 ins +. outs +. float ones
1033 let rec set nab y sy =
1034 let (_N, _A, _B), y =
1035 if single
1036 then
1037 let scl = if y > sy then 2 else -2 in
1038 let _N, _, _ = nab in
1039 (_N,0,_N), y+conf.scrollstep*scl
1040 else nab,y in
1041 let sum = summa _N _A _B in
1042 let dy = float (y - sy) in
1043 state.ghyll <- (
1044 let rec gf n y1 o =
1045 if n >= _N
1046 then state.ghyll <- noghyll
1047 else
1048 let go n =
1049 let s = scroll n _N _A _B in
1050 let y1 = y1 +. ((s *. dy) /. sum) in
1051 gotoxy_and_clear_text state.x (truncate y1);
1052 state.ghyll <- gf (n+1) y1;
1054 match o with
1055 | None -> go n
1056 | Some y' when single -> set nab y' state.y
1057 | Some y' -> set (_N/2, 1, 1) y' state.y
1059 gf 0 (float state.y)
1062 match conf.ghyllscroll with
1063 | Some nab when not conf.presentation ->
1064 if state.ghyll == noghyll
1065 then set nab y state.y
1066 else state.ghyll (Some y)
1067 | _ ->
1068 gotoxy_and_clear_text state.x y
1071 let gotoghyll = gotoghyll1 false;;
1073 let gotopage n top =
1074 let y, h = getpageyh n in
1075 let y = y + (truncate (top *. float h)) in
1076 gotoghyll y
1079 let gotopage1 n top =
1080 let y = getpagey n in
1081 let y = y + top in
1082 gotoghyll y
1085 let invalidate s f =
1086 state.redisplay <- false;
1087 state.layout <- [];
1088 state.pdims <- [];
1089 state.rects <- [];
1090 state.rects1 <- [];
1091 match state.geomcmds with
1092 | ps, [] when emptystr ps ->
1093 f ();
1094 state.geomcmds <- s, [];
1096 | ps, [] ->
1097 state.geomcmds <- ps, [s, f];
1099 | ps, (s', _) :: rest when s' = s ->
1100 state.geomcmds <- ps, ((s, f) :: rest);
1102 | ps, cmds ->
1103 state.geomcmds <- ps, ((s, f) :: cmds);
1106 let flushpages () =
1107 Hashtbl.iter (fun _ opaque ->
1108 wcmd "freepage %s" (~> opaque);
1109 ) state.pagemap;
1110 Hashtbl.clear state.pagemap;
1113 let flushtiles () =
1114 if not (Queue.is_empty state.tilelru)
1115 then (
1116 Queue.iter (fun (k, p, s) ->
1117 wcmd "freetile %s" (~> p);
1118 state.memused <- state.memused - s;
1119 Hashtbl.remove state.tilemap k;
1120 ) state.tilelru;
1121 state.uioh#infochanged Memused;
1122 Queue.clear state.tilelru;
1124 load state.layout;
1127 let stateh h =
1128 let h = truncate (float h*.conf.zoom) in
1129 let d = conf.interpagespace lsl (if conf.presentation then 1 else 0) in
1130 h - d
1133 let opendoc path password =
1134 state.path <- path;
1135 state.password <- password;
1136 state.gen <- state.gen + 1;
1137 state.docinfo <- [];
1138 state.outlines <- [||];
1140 flushpages ();
1141 setaalevel conf.aalevel;
1142 let titlepath =
1143 if emptystr state.origin
1144 then path
1145 else state.origin
1147 Wsi.settitle ("llpp " ^ (mbtoutf8 (Filename.basename titlepath)));
1148 wcmd "open %d %d %s\000%s\000" (btod !wtmode) (btod !cxack) path password;
1149 invalidate "reqlayout"
1150 (fun () ->
1151 wcmd "reqlayout %d %d %d %s\000"
1152 conf.angle (FMTE.to_int conf.fitmodel)
1153 (stateh state.winh) state.nameddest
1157 let reload () =
1158 state.anchor <- getanchor ();
1159 opendoc state.path state.password;
1162 let scalecolor c =
1163 let c = c *. conf.colorscale in
1164 (c, c, c);
1167 let scalecolor2 (r, g, b) =
1168 (r *. conf.colorscale, g *. conf.colorscale, b *. conf.colorscale);
1171 let docolumns columns =
1172 match columns with
1173 | Csingle _ ->
1174 let a = Array.make state.pagecount (-1, -1, -1, (-1, -1, -1, -1)) in
1175 let rec loop pageno pdimno pdim y ph pdims =
1176 if pageno = state.pagecount
1177 then ()
1178 else
1179 let pdimno, ((_, w, h, xoff) as pdim), pdims =
1180 match pdims with
1181 | ((pageno', _, _, _) as pdim) :: rest when pageno' = pageno ->
1182 pdimno+1, pdim, rest
1183 | _ ->
1184 pdimno, pdim, pdims
1186 let x = max 0 (((state.winw - w) / 2) - xoff) in
1187 let y = y +
1188 (if conf.presentation
1189 then (if pageno = 0 then calcips h else calcips ph + calcips h)
1190 else (if pageno = 0 then 0 else conf.interpagespace)
1193 a.(pageno) <- (pdimno, x, y, pdim);
1194 loop (pageno+1) pdimno pdim (y + h) h pdims
1196 loop 0 ~-1 (-1,-1,-1,-1) 0 0 state.pdims;
1197 conf.columns <- Csingle a;
1199 | Cmulti ((columns, coverA, coverB), _) ->
1200 let a = Array.make state.pagecount (-1, -1, -1, (-1, -1, -1, -1)) in
1201 let rec loop pageno pdimno pdim x y rowh pdims =
1202 let rec fixrow m = if m = pageno then () else
1203 let (pdimno, x, y, ((_, _, h, _) as pdim)) = a.(m) in
1204 if h < rowh
1205 then (
1206 let y = y + (rowh - h) / 2 in
1207 a.(m) <- (pdimno, x, y, pdim);
1209 fixrow (m+1)
1211 if pageno = state.pagecount
1212 then fixrow (((pageno - 1) / columns) * columns)
1213 else
1214 let pdimno, ((_, w, h, xoff) as pdim), pdims =
1215 match pdims with
1216 | ((pageno', _, _, _) as pdim) :: rest when pageno' = pageno ->
1217 pdimno+1, pdim, rest
1218 | _ ->
1219 pdimno, pdim, pdims
1221 let x, y, rowh' =
1222 if pageno = coverA - 1 || pageno = state.pagecount - coverB
1223 then (
1224 let x = (state.winw - w) / 2 in
1225 let ips =
1226 if conf.presentation then calcips h else conf.interpagespace in
1227 x, y + ips + rowh, h
1229 else (
1230 if (pageno - coverA) mod columns = 0
1231 then (
1232 let x = max 0 (state.winw - state.w) / 2 in
1233 let y =
1234 if conf.presentation
1235 then
1236 let ips = calcips h in
1237 y + (if pageno = 0 then 0 else calcips rowh + ips)
1238 else
1239 y + (if pageno = 0 then 0 else conf.interpagespace)
1241 x, y + rowh, h
1243 else x, y, max rowh h
1246 let y =
1247 if pageno > 1 && (pageno - coverA) mod columns = 0
1248 then (
1249 let y =
1250 if pageno = columns && conf.presentation
1251 then (
1252 let ips = calcips rowh in
1253 for i = 0 to pred columns
1255 let (pdimno, x, y, pdim) = a.(i) in
1256 a.(i) <- (pdimno, x, y+ips, pdim)
1257 done;
1258 y+ips;
1260 else y
1262 fixrow (pageno - columns);
1265 else y
1267 a.(pageno) <- (pdimno, x, y, pdim);
1268 let x = x + w + xoff*2 + conf.interpagespace in
1269 loop (pageno+1) pdimno pdim x y rowh' pdims
1271 loop 0 ~-1 (-1,-1,-1,-1) 0 0 0 state.pdims;
1272 conf.columns <- Cmulti ((columns, coverA, coverB), a);
1274 | Csplit (c, _) ->
1275 let a = Array.make (state.pagecount*c) (-1, -1, -1, (-1, -1, -1, -1)) in
1276 let rec loop pageno pdimno pdim y pdims =
1277 if pageno = state.pagecount
1278 then ()
1279 else
1280 let pdimno, ((_, w, h, _) as pdim), pdims =
1281 match pdims with
1282 | ((pageno', _, _, _) as pdim) :: rest when pageno' = pageno ->
1283 pdimno+1, pdim, rest
1284 | _ ->
1285 pdimno, pdim, pdims
1287 let cw = w / c in
1288 let rec loop1 n x y =
1289 if n = c then y else (
1290 a.(pageno*c + n) <- (pdimno, x, y, pdim);
1291 loop1 (n+1) (x+cw) (y + h + conf.interpagespace)
1294 let y = loop1 0 0 y in
1295 loop (pageno+1) pdimno pdim y pdims
1297 loop 0 ~-1 (-1,-1,-1,-1) 0 state.pdims;
1298 conf.columns <- Csplit (c, a);
1301 let represent () =
1302 docolumns conf.columns;
1303 state.maxy <- calcheight ();
1304 if state.reprf == noreprf
1305 then (
1306 match state.mode with
1307 | Birdseye (_, _, pageno, _, _) ->
1308 let y, h = getpageyh pageno in
1309 let top = (state.winh - h) / 2 in
1310 gotoxy state.x (max 0 (y - top))
1311 | Textentry _
1312 | View
1313 | LinkNav _ ->
1314 let y = getanchory state.anchor in
1315 let y = min y (state.maxy - state.winh) in
1316 gotoxy state.x y;
1318 else (
1319 state.reprf ();
1320 state.reprf <- noreprf;
1324 let reshape ?(firsttime=false) w h =
1325 GlDraw.viewport ~x:0 ~y:0 ~w ~h;
1326 if not firsttime && nogeomcmds state.geomcmds
1327 then state.anchor <- getanchor ();
1329 state.winw <- w;
1330 let w = truncate (float w *. conf.zoom) in
1331 let w = max w 2 in
1332 state.winh <- h;
1333 setfontsize fstate.fontsize;
1334 GlMat.mode `modelview;
1335 GlMat.load_identity ();
1337 GlMat.mode `projection;
1338 GlMat.load_identity ();
1339 GlMat.rotate ~x:1.0 ~angle:180.0 ();
1340 GlMat.translate ~x:~-.1.0 ~y:~-.1.0 ();
1341 GlMat.scale3 (2.0 /. float state.winw, 2.0 /. float state.winh, 1.0);
1343 let relx =
1344 if conf.zoom <= 1.0
1345 then 0.0
1346 else float state.x /. float state.w
1348 invalidate "geometry"
1349 (fun () ->
1350 state.w <- w;
1351 if not firsttime
1352 then state.x <- truncate (relx *. float w);
1353 let w =
1354 match conf.columns with
1355 | Csingle _ -> w
1356 | Cmulti ((c, _, _), _) -> (w - (c-1)*conf.interpagespace) / c
1357 | Csplit (c, _) -> w * c
1359 wcmd "geometry %d %d %d"
1360 w (stateh h) (FMTE.to_int conf.fitmodel)
1364 let enttext () =
1365 let len = String.length state.text in
1366 let x0 = if conf.leftscroll then vscrollw () else 0 in
1367 let drawstring s =
1368 let hscrollh =
1369 match state.mode with
1370 | Textentry _ | View | LinkNav _ ->
1371 let h, _, _ = state.uioh#scrollpw in
1373 | Birdseye _ -> 0
1375 let rect x w =
1376 filledrect x (float (state.winh - (fstate.fontsize + 4) - hscrollh))
1377 (x+.w) (float (state.winh - hscrollh))
1380 let w = float (state.winw - 1 - vscrollw ()) in
1381 if state.progress >= 0.0 && state.progress < 1.0
1382 then (
1383 GlDraw.color (0.3, 0.3, 0.3);
1384 let w1 = w *. state.progress in
1385 rect (float x0) w1;
1386 GlDraw.color (0.0, 0.0, 0.0);
1387 rect (float x0+.w1) (float x0+.w-.w1)
1389 else (
1390 GlDraw.color (0.0, 0.0, 0.0);
1391 rect (float x0) w;
1394 GlDraw.color (1.0, 1.0, 1.0);
1395 drawstring fstate.fontsize
1396 (if conf.leftscroll then x0 + 2 else x0 + if len > 0 then 8 else 2)
1397 (state.winh - hscrollh - 5) s;
1399 let s =
1400 match state.mode with
1401 | Textentry ((prefix, text, _, _, _, _), _) ->
1402 let s =
1403 if len > 0
1404 then
1405 Printf.sprintf "%s%s_ [%s]" prefix text state.text
1406 else
1407 Printf.sprintf "%s%s_" prefix text
1411 | Birdseye _
1412 | View
1413 | LinkNav _ -> state.text
1415 let s =
1416 if state.newerrmsgs
1417 then (
1418 if not (istextentry state.mode) && state.uioh#eformsgs
1419 then
1420 let s1 = "(press 'e' to review error messasges)" in
1421 if nonemptystr s then s ^ " " ^ s1 else s1
1422 else s
1424 else s
1426 if nonemptystr s
1427 then drawstring s
1430 let gctiles () =
1431 let len = Queue.length state.tilelru in
1432 let layout = lazy (
1433 match state.throttle with
1434 | None ->
1435 if conf.preload
1436 then preloadlayout state.x state.y state.winw state.winh
1437 else state.layout
1438 | Some (layout, _, _) ->
1439 layout
1440 ) in
1441 let rec loop qpos =
1442 if state.memused <= conf.memlimit
1443 then ()
1444 else (
1445 if qpos < len
1446 then
1447 let (k, p, s) as lruitem = Queue.pop state.tilelru in
1448 let n, gen, colorspace, angle, pagew, pageh, col, row = k in
1449 let (_, pw, ph, _) = getpagedim n in
1451 gen = state.gen
1452 && colorspace = conf.colorspace
1453 && angle = conf.angle
1454 && pagew = pw
1455 && pageh = ph
1456 && (
1457 let x = col*conf.tilew
1458 and y = row*conf.tileh in
1459 tilevisible (Lazy.force_val layout) n x y
1461 then Queue.push lruitem state.tilelru
1462 else (
1463 freepbo p;
1464 wcmd "freetile %s" (~> p);
1465 state.memused <- state.memused - s;
1466 state.uioh#infochanged Memused;
1467 Hashtbl.remove state.tilemap k;
1469 loop (qpos+1)
1472 loop 0
1475 let onpagerect pageno f =
1476 let b =
1477 match conf.columns with
1478 | Cmulti (_, b) -> b
1479 | Csingle b -> b
1480 | Csplit (_, b) -> b
1482 if pageno >= 0 && pageno < Array.length b
1483 then
1484 let (_, _, _, (_, w, h, _)) = b.(pageno) in
1485 f w h
1488 let gotopagexy1 wtmode pageno x y =
1489 let _,w1,h1,leftx = getpagedim pageno in
1490 let top = y /. (float h1) in
1491 let left = x /. (float w1) in
1492 let py, w, h = getpageywh pageno in
1493 let wh = state.winh in
1494 let x = left *. (float w) in
1495 let x = leftx + state.x + truncate x in
1496 let sx =
1497 if x < 0 || x >= state.winw
1498 then state.x - x
1499 else state.x
1501 let pdy = truncate (top *. float h) in
1502 let y' = py + pdy in
1503 let dy = y' - state.y in
1504 let sy =
1505 if x != state.x || not (dy > 0 && dy < wh)
1506 then (
1507 if conf.presentation
1508 then
1509 if abs (py - y') > wh
1510 then y'
1511 else py
1512 else y';
1514 else state.y
1516 if state.x != sx || state.y != sy
1517 then (
1518 let x, y =
1519 if wtmode
1520 then (
1521 let ww = state.winw in
1522 let qx = sx / ww
1523 and qy = pdy / wh in
1524 let x = qx * ww
1525 and y = py + qy * wh in
1526 let x = if -x + ww > w1 then -(w1-ww) else x
1527 and y' = if y + wh > state.maxy then state.maxy - wh else y in
1528 let y =
1529 if conf.presentation
1530 then
1531 if abs (py - y') > wh
1532 then y'
1533 else py
1534 else y';
1536 (x, y)
1538 else (sx, sy)
1540 gotoxy_and_clear_text x y;
1542 else gotoxy_and_clear_text state.x state.y;
1545 let gotopagexy wtmode pageno x y =
1546 match state.mode with
1547 | Birdseye _ -> gotopage pageno 0.0
1548 | Textentry _
1549 | View
1550 | LinkNav _ -> gotopagexy1 wtmode pageno x y
1553 let getpassword () =
1554 let passcmd = getenvwithdef "LLPP_ASKPASS" conf.passcmd in
1555 if emptystr passcmd
1556 then E.s
1557 else getcmdoutput
1558 (fun s ->
1559 impmsg "error getting password: %s" s;
1560 dolog "%s" s) passcmd;
1563 let pgoto opaque pageno x y =
1564 let pdimno = getpdimno pageno in
1565 let x, y = project opaque pageno pdimno x y in
1566 gotopagexy false pageno x y;
1569 let act cmds =
1570 (* dolog "%S" cmds; *)
1571 let spl = splitatspace cmds in
1572 let scan s fmt f =
1573 try Scanf.sscanf s fmt f
1574 with exn ->
1575 dolog "error processing '%S': %s" cmds @@ exntos exn;
1576 exit 1
1578 let addoutline outline =
1579 match state.currently with
1580 | Outlining outlines ->
1581 state.currently <- Outlining (outline :: outlines)
1582 | Idle -> state.currently <- Outlining [outline]
1583 | Loading _
1584 | Tiling _ ->
1585 dolog "invalid outlining state";
1586 logcurrently state.currently
1588 match spl with
1589 | "clear", "" ->
1590 state.uioh#infochanged Pdim;
1591 state.pdims <- [];
1593 | "clearrects", "" ->
1594 state.rects <- state.rects1;
1595 G.postRedisplay "clearrects";
1597 | "continue", args ->
1598 let n = scan args "%u" (fun n -> n) in
1599 state.pagecount <- n;
1600 begin match state.currently with
1601 | Outlining l ->
1602 state.currently <- Idle;
1603 state.outlines <- Array.of_list (List.rev l)
1604 | Idle
1605 | Loading _
1606 | Tiling _ -> ()
1607 end;
1609 let cur, cmds = state.geomcmds in
1610 if emptystr cur
1611 then failwith "umpossible";
1613 begin match List.rev cmds with
1614 | [] ->
1615 state.geomcmds <- E.s, [];
1616 state.throttle <- None;
1617 represent ();
1618 | (s, f) :: rest ->
1619 f ();
1620 state.geomcmds <- s, List.rev rest;
1621 end;
1622 if conf.maxwait = None && not !wtmode
1623 then G.postRedisplay "continue";
1625 | "msg", args ->
1626 showtext ' ' args
1628 | "vmsg", args ->
1629 if conf.verbose
1630 then showtext ' ' args
1632 | "emsg", args ->
1633 Buffer.add_string state.errmsgs args;
1634 state.newerrmsgs <- true;
1635 G.postRedisplay "error message"
1637 | "progress", args ->
1638 let progress, text =
1639 scan args "%f %n"
1640 (fun f pos ->
1641 f, String.sub args pos (String.length args - pos))
1643 state.text <- text;
1644 state.progress <- progress;
1645 G.postRedisplay "progress"
1647 | "firstmatch", args ->
1648 let pageno, c, x0, y0, x1, y1, x2, y2, x3, y3 =
1649 scan args "%u %d %f %f %f %f %f %f %f %f"
1650 (fun p c x0 y0 x1 y1 x2 y2 x3 y3 ->
1651 (p, c, x0, y0, x1, y1, x2, y2, x3, y3))
1653 let y = (getpagey pageno) + truncate y0 in
1654 let x =
1655 if conf.zoom > 1.0
1656 then state.winw/2
1657 else state.x
1659 addnav ();
1660 gotoxy x y;
1661 let color = (0.0, 0.0, 1.0 /. float c, 0.5) in
1662 state.rects1 <- [pageno, color, (x0, y0, x1, y1, x2, y2, x3, y3)]
1664 | "match", args ->
1665 let pageno, c, x0, y0, x1, y1, x2, y2, x3, y3 =
1666 scan args "%u %d %f %f %f %f %f %f %f %f"
1667 (fun p c x0 y0 x1 y1 x2 y2 x3 y3 ->
1668 (p, c, x0, y0, x1, y1, x2, y2, x3, y3))
1670 let color = (0.0, 0.0, 1.0 /. float c, 0.5) in
1671 state.rects1 <-
1672 (pageno, color, (x0, y0, x1, y1, x2, y2, x3, y3)) :: state.rects1
1674 | "page", args ->
1675 let pageopaques, t = scan args "%s %f" (fun p t -> p, t) in
1676 let pageopaque = ~< pageopaques in
1677 begin match state.currently with
1678 | Loading (l, gen) ->
1679 vlog "page %d took %f sec" l.pageno t;
1680 Hashtbl.replace state.pagemap (l.pageno, gen) pageopaque;
1681 begin match state.throttle with
1682 | None ->
1683 let preloadedpages =
1684 if conf.preload
1685 then preloadlayout state.x state.y state.winw state.winh
1686 else state.layout
1688 let evict () =
1689 let set =
1690 List.fold_left (fun s l -> IntSet.add l.pageno s)
1691 IntSet.empty preloadedpages
1693 let evictedpages =
1694 Hashtbl.fold (fun ((pageno, _) as key) opaque accu ->
1695 if not (IntSet.mem pageno set)
1696 then (
1697 wcmd "freepage %s" (~> opaque);
1698 key :: accu
1700 else accu
1701 ) state.pagemap []
1703 List.iter (Hashtbl.remove state.pagemap) evictedpages;
1705 evict ();
1706 state.currently <- Idle;
1707 if gen = state.gen
1708 then (
1709 tilepage l.pageno pageopaque state.layout;
1710 load state.layout;
1711 load preloadedpages;
1712 let visible = pagevisible state.layout l.pageno in
1713 if visible
1714 then (
1715 match state.mode with
1716 | LinkNav (Ltnotready (pageno, dir)) ->
1717 if pageno = l.pageno
1718 then (
1719 let link =
1720 let ld =
1721 if dir = 0
1722 then LDfirstvisible (l.pagex, l.pagey, dir)
1723 else (
1724 if dir > 0 then LDfirst else LDlast
1727 findlink pageopaque ld
1729 match link with
1730 | Lnotfound -> ()
1731 | Lfound n ->
1732 showlinktype (getlink pageopaque n);
1733 state.mode <- LinkNav (Ltexact (l.pageno, n))
1735 | LinkNav (Ltgendir _)
1736 | LinkNav (Ltexact _)
1737 | View
1738 | Birdseye _
1739 | Textentry _ -> ()
1742 if visible && layoutready state.layout
1743 then (
1744 G.postRedisplay "page";
1748 | Some (layout, _, _) ->
1749 state.currently <- Idle;
1750 tilepage l.pageno pageopaque layout;
1751 load state.layout
1752 end;
1754 | Idle
1755 | Tiling _
1756 | Outlining _ ->
1757 dolog "Inconsistent loading state";
1758 logcurrently state.currently;
1759 exit 1
1762 | "tile" , args ->
1763 let (x, y, opaques, size, t) =
1764 scan args "%u %u %s %u %f"
1765 (fun x y p size t -> (x, y, p, size, t))
1767 let opaque = ~< opaques in
1768 begin match state.currently with
1769 | Tiling (l, pageopaque, cs, angle, gen, col, row, tilew, tileh) ->
1770 vlog "tile %d [%d,%d] took %f sec" l.pageno col row t;
1772 unmappbo opaque;
1773 if tilew != conf.tilew || tileh != conf.tileh
1774 then (
1775 wcmd "freetile %s" (~> opaque);
1776 state.currently <- Idle;
1777 load state.layout;
1779 else (
1780 puttileopaque l col row gen cs angle opaque size t;
1781 state.memused <- state.memused + size;
1782 state.uioh#infochanged Memused;
1783 gctiles ();
1784 Queue.push ((l.pageno, gen, cs, angle, l.pagew, l.pageh, col, row),
1785 opaque, size) state.tilelru;
1787 let layout =
1788 match state.throttle with
1789 | None -> state.layout
1790 | Some (layout, _, _) -> layout
1793 state.currently <- Idle;
1794 if gen = state.gen
1795 && conf.colorspace = cs
1796 && conf.angle = angle
1797 && tilevisible layout l.pageno x y
1798 then conttiling l.pageno pageopaque;
1800 begin match state.throttle with
1801 | None ->
1802 preload state.layout;
1803 if gen = state.gen
1804 && conf.colorspace = cs
1805 && conf.angle = angle
1806 && tilevisible state.layout l.pageno x y
1807 && (not !wtmode || layoutready state.layout)
1808 then G.postRedisplay "tile nothrottle";
1810 | Some (layout, y, _) ->
1811 let ready = layoutready layout in
1812 if ready
1813 then (
1814 state.y <- y;
1815 state.layout <- layout;
1816 state.throttle <- None;
1817 G.postRedisplay "throttle";
1819 else load layout;
1820 end;
1823 | Idle
1824 | Loading _
1825 | Outlining _ ->
1826 dolog "Inconsistent tiling state";
1827 logcurrently state.currently;
1828 exit 1
1831 | "pdim", args ->
1832 let (n, w, h, _) as pdim =
1833 scan args "%u %u %u %u" (fun n w h x -> n, w, h, x)
1835 let pdim =
1836 match conf.fitmodel with
1837 | FitWidth -> pdim
1838 | FitPage | FitProportional ->
1839 match conf.columns with
1840 | Csplit _ -> (n, w, h, 0)
1841 | Csingle _ | Cmulti _ -> pdim
1843 state.uioh#infochanged Pdim;
1844 state.pdims <- pdim :: state.pdims
1846 | "o", args ->
1847 let (l, n, t, h, pos) =
1848 scan args "%u %u %d %u %n"
1849 (fun l n t h pos -> l, n, t, h, pos)
1851 let s = String.sub args pos (String.length args - pos) in
1852 addoutline (s, l, Oanchor (n, float t /. float h, 0.0))
1854 | "ou", args ->
1855 let (l, len, pos) = scan args "%u %u %n" (fun l len pos -> l, len, pos) in
1856 let s = String.sub args pos len in
1857 let pos2 = pos + len + 1 in
1858 let uri = String.sub args pos2 (String.length args - pos2) in
1859 addoutline (s, l, Ouri uri)
1861 | "on", args ->
1862 let (l, pos) = scan args "%u %n" (fun l pos -> l, pos) in
1863 let s = String.sub args pos (String.length args - pos) in
1864 addoutline (s, l, Onone)
1866 | "a", args ->
1867 let (n, l, t) =
1868 scan args "%u %d %d" (fun n l t -> n, l, t)
1870 state.reprf <- (fun () -> gotopagexy !wtmode n (float l) (float t))
1872 | "info", args ->
1873 let pos = nindex args '\t' in
1874 if pos >= 0 && String.sub args 0 pos = "Title"
1875 then (
1876 let s = String.sub args (pos+1) @@ String.length args - pos - 1 in
1877 conf.title <- s;
1878 Wsi.settitle s;
1880 state.docinfo <- (1, args) :: state.docinfo
1882 | "infoend", "" ->
1883 state.uioh#infochanged Docinfo;
1884 state.docinfo <- List.rev state.docinfo
1886 | "pass", args ->
1887 if args = "fail"
1888 then Wsi.settitle "Wrong password";
1889 let password = getpassword () in
1890 if emptystr password
1891 then error "document is password protected"
1892 else opendoc state.path password
1894 | _ ->
1895 error "unknown cmd `%S'" cmds
1898 let onhist cb =
1899 let rc = cb.rc in
1900 let action = function
1901 | HCprev -> cbget cb ~-1
1902 | HCnext -> cbget cb 1
1903 | HCfirst -> cbget cb ~-(cb.rc)
1904 | HClast -> cbget cb (cb.len - 1 - cb.rc)
1905 and cancel () = cb.rc <- rc
1906 in (action, cancel)
1909 let search pattern forward =
1910 match conf.columns with
1911 | Csplit _ -> impmsg "searching does not work properly in split columns mode"
1912 | Csingle _
1913 | Cmulti _ ->
1914 if nonemptystr pattern
1915 then
1916 let pn, py =
1917 match state.layout with
1918 | [] -> 0, 0
1919 | l :: _ ->
1920 l.pageno, (l.pagey + if forward then 0 else 0*l.pagevh)
1922 wcmd "search %d %d %d %d,%s\000"
1923 (btod conf.icase) pn py (btod forward) pattern;
1926 let intentry text key =
1927 let text =
1928 if key >= 32 && key < 127
1929 then
1930 let c = Char.chr key in
1931 match c with
1932 | '0' .. '9' -> addchar text c
1933 | _ ->
1934 state.text <- Printf.sprintf "invalid char (%d, `%c')" key c;
1935 text
1936 else (
1937 state.text <- Printf.sprintf "invalid key (%d)" key;
1938 text
1941 TEcont text
1944 let linknact f s =
1945 if nonemptystr s
1946 then (
1947 let n =
1948 let l = String.length s in
1949 let rec loop pos n = if pos = l then n else
1950 let m = Char.code s.[pos] - (if pos = 0 && l > 1 then 96 else 97) in
1951 loop (pos+1) (n*26 + m)
1952 in loop 0 0
1954 let rec loop n = function
1955 | [] -> ()
1956 | l :: rest ->
1957 match getopaque l.pageno with
1958 | None -> loop n rest
1959 | Some opaque ->
1960 let m = getlinkcount opaque in
1961 if n < m
1962 then (
1963 let under = getlink opaque n in
1964 f under
1966 else loop (n-m) rest
1968 loop n state.layout;
1972 let linknentry text key =
1973 if key >= 32 && key < 127
1974 then
1975 let text = addchar text (Char.chr key) in
1976 linknact (fun under -> state.text <- undertext ~nopath:true under) text;
1977 TEcont text
1978 else (
1979 state.text <- Printf.sprintf "invalid key %d" key;
1980 TEcont text
1984 let textentry text key =
1985 if Wsi.isspecialkey key
1986 then TEcont text
1987 else TEcont (text ^ toutf8 key)
1990 let reqlayout angle fitmodel =
1991 match state.throttle with
1992 | None ->
1993 if nogeomcmds state.geomcmds
1994 then state.anchor <- getanchor ();
1995 conf.angle <- angle mod 360;
1996 if conf.angle != 0
1997 then (
1998 match state.mode with
1999 | LinkNav _ -> state.mode <- View
2000 | Birdseye _
2001 | Textentry _
2002 | View -> ()
2004 conf.fitmodel <- fitmodel;
2005 invalidate "reqlayout"
2006 (fun () ->
2007 wcmd "reqlayout %d %d %d"
2008 conf.angle (FMTE.to_int conf.fitmodel) (stateh state.winh)
2010 | _ -> ()
2013 let settrim trimmargins trimfuzz =
2014 if nogeomcmds state.geomcmds
2015 then state.anchor <- getanchor ();
2016 conf.trimmargins <- trimmargins;
2017 conf.trimfuzz <- trimfuzz;
2018 let x0, y0, x1, y1 = trimfuzz in
2019 invalidate "settrim"
2020 (fun () ->
2021 wcmd "settrim %d %d %d %d %d" (btod conf.trimmargins) x0 y0 x1 y1);
2022 flushpages ();
2025 let setzoom zoom =
2026 match state.throttle with
2027 | None ->
2028 let zoom = max 0.0001 zoom in
2029 if zoom <> conf.zoom
2030 then (
2031 state.prevzoom <- (conf.zoom, state.x);
2032 conf.zoom <- zoom;
2033 reshape state.winw state.winh;
2034 state.text <- Printf.sprintf "zoom is now %-5.2f" (zoom *. 100.0);
2037 | Some (layout, y, started) ->
2038 let time =
2039 match conf.maxwait with
2040 | None -> 0.0
2041 | Some t -> t
2043 let dt = now () -. started in
2044 if dt > time
2045 then (
2046 state.y <- y;
2047 load layout;
2051 let pivotzoom ?(vw=state.winw)
2052 ?(vh=min (state.maxy-state.y) state.winh)
2053 ?(x=vw/2) ?(y=vh/2) zoom =
2054 let w = float state.w /. zoom in
2055 let hw = w /. 2.0 in
2056 let ratio = float vh /. float vw in
2057 let hh = hw *. ratio in
2058 let x0 = float x -. hw in
2059 let y0 = float y -. hh in
2060 gotoxy (state.x - truncate x0) (state.y + truncate y0);
2061 setzoom zoom;
2064 let pivotzoom ?vw ?vh ?x ?y zoom =
2065 if nogeomcmds state.geomcmds then pivotzoom ?vw ?vh ?x ?y zoom
2068 let setcolumns mode columns coverA coverB =
2069 state.prevcolumns <- Some (conf.columns, conf.zoom);
2070 if columns < 0
2071 then (
2072 if isbirdseye mode
2073 then impmsg "split mode doesn't work in bird's eye"
2074 else (
2075 conf.columns <- Csplit (-columns, E.a);
2076 state.x <- 0;
2077 conf.zoom <- 1.0;
2080 else (
2081 if columns < 2
2082 then (
2083 conf.columns <- Csingle E.a;
2084 state.x <- 0;
2085 setzoom 1.0;
2087 else (
2088 conf.columns <- Cmulti ((columns, coverA, coverB), E.a);
2089 conf.zoom <- 1.0;
2092 reshape state.winw state.winh;
2095 let resetmstate () =
2096 state.mstate <- Mnone;
2097 Wsi.setcursor Wsi.CURSOR_INHERIT;
2100 let enterbirdseye () =
2101 let zoom = float conf.thumbw /. float state.winw in
2102 let birdseyepageno =
2103 let cy = state.winh / 2 in
2104 let fold = function
2105 | [] -> 0
2106 | l :: rest ->
2107 let rec fold best = function
2108 | [] -> best.pageno
2109 | l :: rest ->
2110 let d = cy - (l.pagedispy + l.pagevh/2)
2111 and dbest = cy - (best.pagedispy + best.pagevh/2) in
2112 if abs d < abs dbest
2113 then fold l rest
2114 else best.pageno
2115 in fold l rest
2117 fold state.layout
2119 state.mode <- Birdseye (
2120 { conf with zoom = conf.zoom }, state.x, birdseyepageno, -1, getanchor ()
2122 resetmstate ();
2123 conf.zoom <- zoom;
2124 conf.presentation <- false;
2125 conf.interpagespace <- 10;
2126 conf.hlinks <- false;
2127 conf.fitmodel <- FitPage;
2128 state.x <- 0;
2129 conf.maxwait <- None;
2130 conf.columns <- (
2131 match conf.beyecolumns with
2132 | Some c ->
2133 conf.zoom <- 1.0;
2134 Cmulti ((c, 0, 0), E.a)
2135 | None -> Csingle E.a
2137 if conf.verbose
2138 then
2139 state.text <- Printf.sprintf "birds eye mode on (zoom %3.1f%%)"
2140 (100.0*.zoom)
2141 else
2142 state.text <- E.s
2144 reshape state.winw state.winh;
2147 let leavebirdseye (c, leftx, pageno, _, anchor) goback =
2148 state.mode <- View;
2149 conf.zoom <- c.zoom;
2150 conf.presentation <- c.presentation;
2151 conf.interpagespace <- c.interpagespace;
2152 conf.maxwait <- c.maxwait;
2153 conf.hlinks <- c.hlinks;
2154 conf.fitmodel <- c.fitmodel;
2155 conf.beyecolumns <- (
2156 match conf.columns with
2157 | Cmulti ((c, _, _), _) -> Some c
2158 | Csingle _ -> None
2159 | Csplit _ -> failwith "leaving bird's eye split mode"
2161 conf.columns <- (
2162 match c.columns with
2163 | Cmulti (c, _) -> Cmulti (c, E.a)
2164 | Csingle _ -> Csingle E.a
2165 | Csplit (c, _) -> Csplit (c, E.a)
2167 if conf.verbose
2168 then
2169 state.text <- Printf.sprintf "birds eye mode off (zoom %3.1f%%)"
2170 (100.0*.conf.zoom)
2172 reshape state.winw state.winh;
2173 state.anchor <- if goback then anchor else (pageno, 0.0, 1.0);
2174 state.x <- leftx;
2177 let togglebirdseye () =
2178 match state.mode with
2179 | Birdseye vals -> leavebirdseye vals true
2180 | View -> enterbirdseye ()
2181 | Textentry _
2182 | LinkNav _ -> ()
2185 let upbirdseye incr (conf, leftx, pageno, hooverpageno, anchor) =
2186 let pageno = max 0 (pageno - incr) in
2187 let rec loop = function
2188 | [] -> gotopage1 pageno 0
2189 | l :: _ when l.pageno = pageno ->
2190 if l.pagedispy >= 0 && l.pagey = 0
2191 then G.postRedisplay "upbirdseye"
2192 else gotopage1 pageno 0
2193 | _ :: rest -> loop rest
2195 loop state.layout;
2196 state.text <- E.s;
2197 state.mode <- Birdseye (conf, leftx, pageno, hooverpageno, anchor)
2200 let downbirdseye incr (conf, leftx, pageno, hooverpageno, anchor) =
2201 let pageno = min (state.pagecount - 1) (pageno + incr) in
2202 state.mode <- Birdseye (conf, leftx, pageno, hooverpageno, anchor);
2203 let rec loop = function
2204 | [] ->
2205 let y, h = getpageyh pageno in
2206 let dy = (y - state.y) - (state.winh - h - conf.interpagespace) in
2207 gotoxy state.x (clamp dy)
2208 | l :: _ when l.pageno = pageno ->
2209 if l.pagevh != l.pageh
2210 then gotoxy state.x (clamp (l.pageh - l.pagevh + conf.interpagespace))
2211 else G.postRedisplay "downbirdseye"
2212 | _ :: rest -> loop rest
2214 loop state.layout;
2215 state.text <- E.s;
2218 let optentry mode _ key =
2219 let btos b = if b then "on" else "off" in
2220 if key >= 32 && key < 127
2221 then
2222 let c = Char.chr key in
2223 match c with
2224 | 's' ->
2225 let ondone s =
2226 try conf.scrollstep <- int_of_string s with exn ->
2227 state.text <- Printf.sprintf "bad integer `%s': %s" s @@ exntos exn
2229 TEswitch ("scroll step: ", E.s, None, intentry, ondone, true)
2231 | 'A' ->
2232 let ondone s =
2234 conf.autoscrollstep <- boundastep state.winh (int_of_string s);
2235 if state.autoscroll <> None
2236 then state.autoscroll <- Some conf.autoscrollstep
2237 with exn ->
2238 state.text <- Printf.sprintf "bad integer `%s': %s" s @@ exntos exn
2240 TEswitch ("auto scroll step: ", E.s, None, intentry, ondone, true)
2242 | 'C' ->
2243 let ondone s =
2245 let n, a, b = multicolumns_of_string s in
2246 setcolumns mode n a b;
2247 with exn ->
2248 state.text <- Printf.sprintf "bad columns `%s': %s" s @@ exntos exn
2250 TEswitch ("columns: ", E.s, None, textentry, ondone, true)
2252 | 'Z' ->
2253 let ondone s =
2255 let zoom = float (int_of_string s) /. 100.0 in
2256 pivotzoom zoom
2257 with exn ->
2258 state.text <- Printf.sprintf "bad integer `%s': %s" s @@ exntos exn
2260 TEswitch ("zoom: ", E.s, None, intentry, ondone, true)
2262 | 't' ->
2263 let ondone s =
2265 conf.thumbw <- bound (int_of_string s) 2 4096;
2266 state.text <-
2267 Printf.sprintf "thumbnail width is set to %d" conf.thumbw;
2268 begin match mode with
2269 | Birdseye beye ->
2270 leavebirdseye beye false;
2271 enterbirdseye ();
2272 | Textentry _
2273 | View
2274 | LinkNav _ -> ();
2276 with exn ->
2277 state.text <- Printf.sprintf "bad integer `%s': %s" s @@ exntos exn
2279 TEswitch ("thumbnail width: ", E.s, None, intentry, ondone, true)
2281 | 'R' ->
2282 let ondone s =
2283 match int_of_string s with
2284 | angle -> reqlayout angle conf.fitmodel
2285 | exception exn ->
2286 state.text <-
2287 Printf.sprintf "bad integer `%s': %s" s @@ exntos exn
2289 TEswitch ("rotation: ", E.s, None, intentry, ondone, true)
2291 | 'i' ->
2292 conf.icase <- not conf.icase;
2293 TEdone ("case insensitive search " ^ (btos conf.icase))
2295 | 'p' ->
2296 conf.preload <- not conf.preload;
2297 gotoxy state.x state.y;
2298 TEdone ("preload " ^ (btos conf.preload))
2300 | 'v' ->
2301 conf.verbose <- not conf.verbose;
2302 TEdone ("verbose " ^ (btos conf.verbose))
2304 | 'd' ->
2305 conf.debug <- not conf.debug;
2306 TEdone ("debug " ^ (btos conf.debug))
2308 | 'h' ->
2309 conf.maxhfit <- not conf.maxhfit;
2310 state.maxy <- calcheight ();
2311 TEdone ("maxhfit " ^ (btos conf.maxhfit))
2313 | 'c' ->
2314 conf.crophack <- not conf.crophack;
2315 TEdone ("crophack " ^ btos conf.crophack)
2317 | 'a' ->
2318 let s =
2319 match conf.maxwait with
2320 | None ->
2321 conf.maxwait <- Some infinity;
2322 "always wait for page to complete"
2323 | Some _ ->
2324 conf.maxwait <- None;
2325 "show placeholder if page is not ready"
2327 TEdone s
2329 | 'f' ->
2330 conf.underinfo <- not conf.underinfo;
2331 TEdone ("underinfo " ^ btos conf.underinfo)
2333 | 'P' ->
2334 conf.savebmarks <- not conf.savebmarks;
2335 TEdone ("persistent bookmarks " ^ btos conf.savebmarks)
2337 | 'S' ->
2338 let ondone s =
2340 let pageno, py =
2341 match state.layout with
2342 | [] -> 0, 0
2343 | l :: _ ->
2344 l.pageno, l.pagey
2346 conf.interpagespace <- int_of_string s;
2347 docolumns conf.columns;
2348 state.maxy <- calcheight ();
2349 let y = getpagey pageno in
2350 gotoxy state.x (y + py)
2351 with exn ->
2352 state.text <- Printf.sprintf "bad integer `%s': %s" s @@ exntos exn
2354 TEswitch ("vertical margin: ", E.s, None, intentry, ondone, true)
2356 | 'l' ->
2357 let fm =
2358 match conf.fitmodel with
2359 | FitProportional -> FitWidth
2360 | FitWidth | FitPage -> FitProportional
2362 reqlayout conf.angle fm;
2363 TEdone ("proportional display " ^ btos (fm == FitProportional))
2365 | 'T' ->
2366 settrim (not conf.trimmargins) conf.trimfuzz;
2367 TEdone ("trim margins " ^ btos conf.trimmargins)
2369 | 'I' ->
2370 conf.invert <- not conf.invert;
2371 TEdone ("invert colors " ^ btos conf.invert)
2373 | 'x' ->
2374 let ondone s =
2375 cbput state.hists.sel s;
2376 conf.selcmd <- s;
2378 TEswitch ("selection command: ", E.s, Some (onhist state.hists.sel),
2379 textentry, ondone, true)
2381 | 'M' ->
2382 if conf.pax == None
2383 then conf.pax <- Some (ref (0.0, 0, 0))
2384 else conf.pax <- None;
2385 TEdone ("PAX " ^ btos (conf.pax != None))
2387 | _ ->
2388 state.text <- Printf.sprintf "bad option %d `%c'" key c;
2389 TEstop
2390 else
2391 TEcont state.text
2394 class type lvsource = object
2395 method getitemcount : int
2396 method getitem : int -> (string * int)
2397 method hasaction : int -> bool
2398 method exit :
2399 uioh:uioh ->
2400 cancel:bool ->
2401 active:int ->
2402 first:int ->
2403 pan:int ->
2404 uioh option
2405 method getactive : int
2406 method getfirst : int
2407 method getpan : int
2408 method getminfo : (int * int) array
2409 end;;
2411 class virtual lvsourcebase = object
2412 val mutable m_active = 0
2413 val mutable m_first = 0
2414 val mutable m_pan = 0
2415 method getactive = m_active
2416 method getfirst = m_first
2417 method getpan = m_pan
2418 method getminfo : (int * int) array = E.a
2419 end;;
2421 let textentrykeyboard
2422 key _mask ((c, text, opthist, onkey, ondone, cancelonempty), onleave) =
2423 state.text <- E.s;
2424 let key = Wsi.keypadtodigitkey key in
2425 let enttext te =
2426 state.mode <- Textentry (te, onleave);
2427 enttext ();
2428 G.postRedisplay "textentrykeyboard enttext";
2430 let histaction cmd =
2431 match opthist with
2432 | None -> ()
2433 | Some (action, _) ->
2434 state.mode <- Textentry (
2435 (c, action cmd, opthist, onkey, ondone, cancelonempty), onleave
2437 G.postRedisplay "textentry histaction"
2439 match key with
2440 | @backspace ->
2441 if emptystr text && cancelonempty
2442 then (
2443 onleave Cancel;
2444 G.postRedisplay "textentrykeyboard after cancel";
2446 else
2447 let s = withoutlastutf8 text in
2448 enttext (c, s, opthist, onkey, ondone, cancelonempty)
2450 | @enter | @kpenter ->
2451 ondone text;
2452 onleave Confirm;
2453 G.postRedisplay "textentrykeyboard after confirm"
2455 | @up | @kpup -> histaction HCprev
2456 | @down | @kpdown -> histaction HCnext
2457 | @home | @kphome -> histaction HCfirst
2458 | @jend | @kpend -> histaction HClast
2460 | @escape ->
2461 if emptystr text
2462 then (
2463 begin match opthist with
2464 | None -> ()
2465 | Some (_, onhistcancel) -> onhistcancel ()
2466 end;
2467 onleave Cancel;
2468 state.text <- E.s;
2469 G.postRedisplay "textentrykeyboard after cancel2"
2471 else (
2472 enttext (c, E.s, opthist, onkey, ondone, cancelonempty)
2475 | @delete | @kpdelete -> ()
2477 | _ when key != 0 && not (Wsi.isspecialkey key) ->
2478 begin match onkey text key with
2479 | TEdone text ->
2480 ondone text;
2481 onleave Confirm;
2482 G.postRedisplay "textentrykeyboard after confirm2";
2484 | TEcont text ->
2485 enttext (c, text, opthist, onkey, ondone, cancelonempty);
2487 | TEstop ->
2488 onleave Cancel;
2489 G.postRedisplay "textentrykeyboard after cancel3"
2491 | TEswitch te ->
2492 state.mode <- Textentry (te, onleave);
2493 G.postRedisplay "textentrykeyboard switch";
2494 end;
2496 | _ ->
2497 vlog "unhandled key %s" (Wsi.keyname key)
2500 let firstof first active =
2501 if first > active || abs (first - active) > fstate.maxrows - 1
2502 then max 0 (active - (fstate.maxrows/2))
2503 else first
2506 let calcfirst first active =
2507 if active > first
2508 then
2509 let rows = active - first in
2510 if rows > fstate.maxrows then active - fstate.maxrows else first
2511 else active
2514 let scrollph y maxy =
2515 let sh = float (maxy + state.winh) /. float state.winh in
2516 let sh = float state.winh /. sh in
2517 let sh = max sh (float conf.scrollh) in
2519 let percent = float y /. float maxy in
2520 let position = (float state.winh -. sh) *. percent in
2522 let position =
2523 if position +. sh > float state.winh
2524 then float state.winh -. sh
2525 else position
2527 position, sh;
2530 let adderrmsg src msg =
2531 Buffer.add_string state.errmsgs msg;
2532 state.newerrmsgs <- true;
2533 G.postRedisplay src
2536 let adderrfmt src fmt =
2537 Format.ksprintf (fun s -> adderrmsg src s) fmt;
2540 let coe s = (s :> uioh);;
2542 class listview ~zebra ~helpmode ~(source:lvsource) ~trusted ~modehash =
2543 object (self)
2544 val m_pan = source#getpan
2545 val m_first = source#getfirst
2546 val m_active = source#getactive
2547 val m_qsearch = E.s
2548 val m_prev_uioh = state.uioh
2550 method private elemunder y =
2551 if y < 0
2552 then None
2553 else
2554 let n = y / (fstate.fontsize+1) in
2555 if m_first + n < source#getitemcount
2556 then (
2557 if source#hasaction (m_first + n)
2558 then Some (m_first + n)
2559 else None
2561 else None
2563 method display =
2564 Gl.enable `blend;
2565 GlFunc.blend_func ~src:`src_alpha ~dst:`one_minus_src_alpha;
2566 GlDraw.color (0., 0., 0.) ~alpha:0.85;
2567 filledrect 0. 0. (float state.winw) (float state.winh);
2568 GlDraw.color (1., 1., 1.);
2569 Gl.enable `texture_2d;
2570 let fs = fstate.fontsize in
2571 let nfs = fs + 1 in
2572 let hw = state.winw/3 in
2573 let ww = fstate.wwidth in
2574 let tabw = 17.0*.ww in
2575 let itemcount = source#getitemcount in
2576 let minfo = source#getminfo in
2577 let x0 = 0.0
2578 and x1 =
2579 if conf.leftscroll
2580 then float (state.winw - 1)
2581 else float (state.winw - conf.scrollbw - 1)
2583 let rec loop row =
2584 if (row - m_first) > fstate.maxrows
2585 then ()
2586 else (
2587 if row >= 0 && row < itemcount
2588 then (
2589 let (s, level) = source#getitem row in
2590 let y = (row - m_first) * nfs in
2591 let x = 5.0 +. (float (level + m_pan)) *. ww in
2592 if helpmode
2593 then GlDraw.color
2594 (let c = if row land 1 = 0 then 1.0 else 0.92 in (c,c,c));
2596 if row = m_active
2597 then (
2598 Gl.disable `texture_2d;
2599 let alpha = if source#hasaction row then 0.9 else 0.3 in
2600 GlDraw.color (1., 1., 1.) ~alpha;
2601 linerect (x0 +. 1.) (float (y + 1)) (x1) (float (y + fs + 3));
2602 Gl.enable `texture_2d;
2604 let c =
2605 if zebra && row land 1 = 1
2606 then 0.8
2607 else 1.0
2609 GlDraw.color (c,c,c);
2610 let drawtabularstring s =
2611 let drawstr x s =
2612 let x' = truncate (x0 +. x) in
2613 let pos = nindex s '\000' in
2614 if pos = -1
2615 then drawstring1 fs x' (y+nfs) s
2616 else
2617 let s1 = String.sub s 0 pos
2618 and s2 = String.sub s (pos+1) (String.length s - pos - 1) in
2619 let rec e s =
2620 if emptystr s
2621 then s
2622 else
2623 let s' = withoutlastutf8 s in
2624 let s = s' ^ "@Uellipsis" in
2625 let w = measurestr fs s in
2626 if float x' +. w +. ww < float (hw + x')
2627 then s
2628 else e s'
2630 let s1 =
2631 if float x' +. ww +. measurestr fs s1 > float (hw + x')
2632 then e s1
2633 else s1
2635 ignore (drawstring1 fs x' (y+nfs) s1);
2636 drawstring1 fs (hw + x') (y+nfs) s2
2638 if trusted
2639 then
2640 let x = if helpmode && row > 0 then x +. ww else x in
2641 let tabpos = nindex s '\t' in
2642 if tabpos > 0
2643 then
2644 let len = String.length s - tabpos - 1 in
2645 let s1 = String.sub s 0 tabpos
2646 and s2 = String.sub s (tabpos + 1) len in
2647 let nx = drawstr x s1 in
2648 let sw = nx -. x in
2649 let x = x +. (max tabw sw) in
2650 drawstr x s2
2651 else
2652 let len = String.length s - 2 in
2653 if len > 0 && s.[0] = '\xc2' && s.[1] = '\xb7'
2654 then
2655 let s = String.sub s 2 len in
2656 let x = if not helpmode then x +. ww else x in
2657 GlDraw.color (1.2, 1.2, 1.2);
2658 let vinc = drawstring1 (fs+fs/4)
2659 (truncate (x -. ww)) (y+nfs) s in
2660 GlDraw.color (1., 1., 1.);
2661 vinc +. (float fs *. 0.8)
2662 else
2663 drawstr x s
2664 else
2665 drawstr x s
2667 ignore (drawtabularstring s);
2668 loop (row+1)
2672 loop m_first;
2673 GlDraw.color (1.0, 1.0, 1.0) ~alpha:0.5;
2674 let xadj = 5.0 in
2675 let rec loop row =
2676 if (row - m_first) > fstate.maxrows
2677 then ()
2678 else (
2679 if row >= 0 && row < itemcount
2680 then (
2681 let (s, level) = source#getitem row in
2682 let pos0 = nindex s '\000' in
2683 let y = (row - m_first) * nfs in
2684 let x = float (level + m_pan) *. ww in
2685 let (first, last) = minfo.(row) in
2686 let prefix =
2687 if pos0 > 0 && first > pos0
2688 then String.sub s (pos0+1) (first-pos0-1)
2689 else String.sub s 0 first
2691 let suffix = String.sub s first (last - first) in
2692 let w1 = measurestr fstate.fontsize prefix in
2693 let w2 = measurestr fstate.fontsize suffix in
2694 let x = x +. if conf.leftscroll then xadj else 5.0 in
2695 let x = if pos0 > 0 && first > pos0 then x +. float hw else x in
2696 let x0 = x +. w1
2697 and y0 = float (y+2) in
2698 let x1 = x0 +. w2
2699 and y1 = float (y+fs+3) in
2700 filledrect x0 y0 x1 y1;
2701 loop (row+1)
2705 Gl.disable `texture_2d;
2706 if Array.length minfo > 0 then loop m_first;
2707 Gl.disable `blend;
2709 method updownlevel incr =
2710 let len = source#getitemcount in
2711 let curlevel =
2712 if m_active >= 0 && m_active < len
2713 then snd (source#getitem m_active)
2714 else -1
2716 let rec flow i =
2717 if i = len then i-1 else if i = -1 then 0 else
2718 let _, l = source#getitem i in
2719 if l != curlevel then i else flow (i+incr)
2721 let active = flow m_active in
2722 let first = calcfirst m_first active in
2723 G.postRedisplay "outline updownlevel";
2724 {< m_active = active; m_first = first >}
2726 method private key1 key mask =
2727 let set1 active first qsearch =
2728 coe {< m_active = active; m_first = first; m_qsearch = qsearch >}
2730 let search active pattern incr =
2731 let active = if active = -1 then m_first else active in
2732 let dosearch re =
2733 let rec loop n =
2734 if n >= 0 && n < source#getitemcount
2735 then (
2736 let s, _ = source#getitem n in
2737 match Str.search_forward re s 0 with
2738 | (exception Not_found) -> loop (n + incr)
2739 | _ -> Some n
2741 else None
2743 loop active
2745 let qpat = Str.quote pattern in
2746 match Str.regexp_case_fold qpat with
2747 | s -> dosearch s
2748 | exception exn ->
2749 adderrfmt "listview key1" "regexp_case_fold for `%S' failed: %S\n"
2750 qpat @@ Printexc.to_string exn;
2751 None
2753 let itemcount = source#getitemcount in
2754 let find start incr =
2755 let rec find i =
2756 if i = -1 || i = itemcount
2757 then -1
2758 else (
2759 if source#hasaction i
2760 then i
2761 else find (i + incr)
2764 find start
2766 let set active first =
2767 let first = bound first 0 (itemcount - fstate.maxrows) in
2768 state.text <- E.s;
2769 coe {< m_active = active; m_first = first; m_qsearch = E.s >}
2771 let navigate incr =
2772 let isvisible first n = n >= first && n - first <= fstate.maxrows in
2773 let active, first =
2774 let incr1 = if incr > 0 then 1 else -1 in
2775 if isvisible m_first m_active
2776 then
2777 let next =
2778 let next = m_active + incr in
2779 let next =
2780 if next < 0 || next >= itemcount
2781 then -1
2782 else find next incr1
2784 if abs (m_active - next) > fstate.maxrows
2785 then -1
2786 else next
2788 if next = -1
2789 then
2790 let first = m_first + incr in
2791 let first = bound first 0 (itemcount - fstate.maxrows) in
2792 let next =
2793 let next = m_active + incr in
2794 let next = bound next 0 (itemcount - 1) in
2795 find next ~-incr1
2797 let active =
2798 if next = -1
2799 then m_active
2800 else (
2801 if isvisible first next
2802 then next
2803 else m_active
2806 active, first
2807 else
2808 let first = min next m_first in
2809 let first =
2810 if abs (next - first) > fstate.maxrows
2811 then first + incr
2812 else first
2814 next, first
2815 else
2816 let first = m_first + incr in
2817 let first = bound first 0 (itemcount - 1) in
2818 let active =
2819 let next = m_active + incr in
2820 let next = bound next 0 (itemcount - 1) in
2821 let next = find next incr1 in
2822 let active =
2823 if next = -1 || abs (m_active - first) > fstate.maxrows
2824 then (
2825 let active = if m_active = -1 then next else m_active in
2826 active
2828 else next
2830 if isvisible first active
2831 then active
2832 else -1
2834 active, first
2836 G.postRedisplay "listview navigate";
2837 set active first;
2839 match key with
2840 | (@r|@s) when Wsi.withctrl mask ->
2841 let incr = if key = @r then -1 else 1 in
2842 let active, first =
2843 match search (m_active + incr) m_qsearch incr with
2844 | None ->
2845 state.text <- m_qsearch ^ " [not found]";
2846 m_active, m_first
2847 | Some active ->
2848 state.text <- m_qsearch;
2849 active, firstof m_first active
2851 G.postRedisplay "listview ctrl-r/s";
2852 set1 active first m_qsearch;
2854 | @insert when Wsi.withctrl mask ->
2855 if m_active >= 0 && m_active < source#getitemcount
2856 then (
2857 let s, _ = source#getitem m_active in
2858 selstring s;
2860 coe self
2862 | @backspace ->
2863 if emptystr m_qsearch
2864 then coe self
2865 else (
2866 let qsearch = withoutlastutf8 m_qsearch in
2867 if emptystr qsearch
2868 then (
2869 state.text <- E.s;
2870 G.postRedisplay "listview empty qsearch";
2871 set1 m_active m_first E.s;
2873 else
2874 let active, first =
2875 match search m_active qsearch ~-1 with
2876 | None ->
2877 state.text <- qsearch ^ " [not found]";
2878 m_active, m_first
2879 | Some active ->
2880 state.text <- qsearch;
2881 active, firstof m_first active
2883 G.postRedisplay "listview backspace qsearch";
2884 set1 active first qsearch
2887 | key when (key != 0 && not (Wsi.isspecialkey key)) ->
2888 let pattern = m_qsearch ^ toutf8 key in
2889 let active, first =
2890 match search m_active pattern 1 with
2891 | None ->
2892 state.text <- pattern ^ " [not found]";
2893 m_active, m_first
2894 | Some active ->
2895 state.text <- pattern;
2896 active, firstof m_first active
2898 G.postRedisplay "listview qsearch add";
2899 set1 active first pattern;
2901 | @escape ->
2902 state.text <- E.s;
2903 if emptystr m_qsearch
2904 then (
2905 G.postRedisplay "list view escape";
2906 let mx, my = state.mpos in
2907 updateunder mx my;
2908 begin
2909 match
2910 source#exit ~uioh:(coe self)
2911 ~cancel:true ~active:m_active ~first:m_first ~pan:m_pan
2912 with
2913 | None -> m_prev_uioh
2914 | Some uioh -> uioh
2917 else (
2918 G.postRedisplay "list view kill qsearch";
2919 coe {< m_qsearch = E.s >}
2922 | @enter | @kpenter ->
2923 state.text <- E.s;
2924 let self = {< m_qsearch = E.s >} in
2925 let opt =
2926 G.postRedisplay "listview enter";
2927 if m_active >= 0 && m_active < source#getitemcount
2928 then (
2929 source#exit ~uioh:(coe self) ~cancel:false
2930 ~active:m_active ~first:m_first ~pan:m_pan;
2932 else (
2933 source#exit ~uioh:(coe self) ~cancel:true
2934 ~active:m_active ~first:m_first ~pan:m_pan;
2937 begin match opt with
2938 | None -> m_prev_uioh
2939 | Some uioh -> uioh
2942 | @delete | @kpdelete ->
2943 coe self
2945 | @up | @kpup -> navigate ~-1
2946 | @down | @kpdown -> navigate 1
2947 | @prior | @kpprior -> navigate ~-(fstate.maxrows)
2948 | @next | @kpnext -> navigate fstate.maxrows
2950 | @right | @kpright ->
2951 state.text <- E.s;
2952 G.postRedisplay "listview right";
2953 coe {< m_pan = m_pan - 1 >}
2955 | @left | @kpleft ->
2956 state.text <- E.s;
2957 G.postRedisplay "listview left";
2958 coe {< m_pan = m_pan + 1 >}
2960 | @home | @kphome ->
2961 let active = find 0 1 in
2962 G.postRedisplay "listview home";
2963 set active 0;
2965 | @jend | @kpend ->
2966 let first = max 0 (itemcount - fstate.maxrows) in
2967 let active = find (itemcount - 1) ~-1 in
2968 G.postRedisplay "listview end";
2969 set active first;
2971 | key when (key = 0 || Wsi.isspecialkey key) ->
2972 coe self
2974 | _ ->
2975 dolog "listview unknown key %#x" key; coe self
2977 method key key mask =
2978 match state.mode with
2979 | Textentry te -> textentrykeyboard key mask te; coe self
2980 | Birdseye _
2981 | View
2982 | LinkNav _ -> self#key1 key mask
2984 method button button down x y _ =
2985 let opt =
2986 match button with
2987 | 1 when vscrollhit x ->
2988 G.postRedisplay "listview scroll";
2989 if down
2990 then
2991 let _, position, sh = self#scrollph in
2992 if y > truncate position && y < truncate (position +. sh)
2993 then (
2994 state.mstate <- Mscrolly;
2995 Some (coe self)
2997 else
2998 let s = float (max 0 (y - conf.scrollh)) /. float state.winh in
2999 let first = truncate (s *. float source#getitemcount) in
3000 let first = min source#getitemcount first in
3001 Some (coe {< m_first = first; m_active = first >})
3002 else (
3003 state.mstate <- Mnone;
3004 Some (coe self);
3006 | 1 when down ->
3007 begin match self#elemunder y with
3008 | Some n ->
3009 G.postRedisplay "listview click";
3010 source#exit ~uioh:(coe {< m_active = n >})
3011 ~cancel:false ~active:n ~first:m_first ~pan:m_pan
3012 | _ ->
3013 Some (coe self)
3015 | n when (n == 4 || n == 5) && not down ->
3016 let len = source#getitemcount in
3017 let first =
3018 if n = 5 && m_first + fstate.maxrows >= len
3019 then
3020 m_first
3021 else
3022 let first = m_first + (if n == 4 then -1 else 1) in
3023 bound first 0 (len - 1)
3025 G.postRedisplay "listview wheel";
3026 Some (coe {< m_first = first >})
3027 | n when (n = 6 || n = 7) && not down ->
3028 let inc = if n = 7 then -1 else 1 in
3029 G.postRedisplay "listview hwheel";
3030 Some (coe {< m_pan = m_pan + inc >})
3031 | _ ->
3032 Some (coe self)
3034 match opt with
3035 | None -> m_prev_uioh
3036 | Some uioh -> uioh
3038 method multiclick _ x y = self#button 1 true x y
3040 method motion _ y =
3041 match state.mstate with
3042 | Mscrolly ->
3043 let s = float (max 0 (y - conf.scrollh)) /. float state.winh in
3044 let first = truncate (s *. float source#getitemcount) in
3045 let first = min source#getitemcount first in
3046 G.postRedisplay "listview motion";
3047 coe {< m_first = first; m_active = first >}
3048 | Msel _
3049 | Mpan _
3050 | Mscrollx
3051 | Mzoom _
3052 | Mzoomrect _
3053 | Mnone -> coe self
3055 method pmotion x y =
3056 if x < state.winw - conf.scrollbw
3057 then
3058 let n =
3059 match self#elemunder y with
3060 | None -> Wsi.setcursor Wsi.CURSOR_INHERIT; m_active
3061 | Some n -> Wsi.setcursor Wsi.CURSOR_INFO; n
3063 let o =
3064 if n != m_active
3065 then (G.postRedisplay "listview pmotion"; {< m_active = n >})
3066 else self
3068 coe o
3069 else (
3070 Wsi.setcursor Wsi.CURSOR_INHERIT;
3071 coe self
3074 method infochanged _ = ()
3076 method scrollpw = (0, 0.0, 0.0)
3077 method scrollph =
3078 let nfs = fstate.fontsize + 1 in
3079 let y = m_first * nfs in
3080 let itemcount = source#getitemcount in
3081 let maxi = max 0 (itemcount - fstate.maxrows) in
3082 let maxy = maxi * nfs in
3083 let p, h = scrollph y maxy in
3084 conf.scrollbw, p, h
3086 method modehash = modehash
3087 method eformsgs = false
3088 method alwaysscrolly = true
3089 end;;
3091 class outlinelistview ~zebra ~source =
3092 let settext autonarrow s =
3093 if autonarrow
3094 then
3095 let ss = source#statestr in
3096 state.text <-
3097 if emptystr ss
3098 then "[" ^ s ^ "]"
3099 else "{" ^ ss ^ "} [" ^ s ^ "]"
3100 else state.text <- s
3102 object (self)
3103 inherit listview
3104 ~zebra
3105 ~helpmode:false
3106 ~source:(source :> lvsource)
3107 ~trusted:false
3108 ~modehash:(findkeyhash conf "outline")
3109 as super
3111 val m_autonarrow = false
3113 method! key key mask =
3114 let maxrows =
3115 if emptystr state.text
3116 then fstate.maxrows
3117 else fstate.maxrows - 2
3119 let calcfirst first active =
3120 if active > first
3121 then
3122 let rows = active - first in
3123 if rows > maxrows then active - maxrows else first
3124 else active
3126 let navigate incr =
3127 let active = m_active + incr in
3128 let active = bound active 0 (source#getitemcount - 1) in
3129 let first = calcfirst m_first active in
3130 G.postRedisplay "outline navigate";
3131 coe {< m_active = active; m_first = first >}
3133 let navscroll first =
3134 let active =
3135 let dist = m_active - first in
3136 if dist < 0
3137 then first
3138 else (
3139 if dist < maxrows
3140 then m_active
3141 else first + maxrows
3144 G.postRedisplay "outline navscroll";
3145 coe {< m_first = first; m_active = active >}
3147 let ctrl = Wsi.withctrl mask in
3148 match key with
3149 | @a when ctrl ->
3150 let text =
3151 if m_autonarrow
3152 then (source#denarrow; E.s)
3153 else (
3154 let pattern = source#renarrow in
3155 if nonemptystr m_qsearch
3156 then (source#narrow m_qsearch; m_qsearch)
3157 else pattern
3160 settext (not m_autonarrow) text;
3161 G.postRedisplay "toggle auto narrowing";
3162 coe {< m_first = 0; m_active = 0; m_autonarrow = not m_autonarrow >}
3164 | @slash when emptystr m_qsearch && not m_autonarrow ->
3165 settext true E.s;
3166 G.postRedisplay "toggle auto narrowing";
3167 coe {< m_first = 0; m_active = 0; m_autonarrow = true >}
3169 | @n when ctrl ->
3170 source#narrow m_qsearch;
3171 if not m_autonarrow
3172 then source#add_narrow_pattern m_qsearch;
3173 G.postRedisplay "outline ctrl-n";
3174 coe {< m_first = 0; m_active = 0 >}
3176 | @S when ctrl ->
3177 let active = source#calcactive (getanchor ()) in
3178 let first = firstof m_first active in
3179 G.postRedisplay "outline ctrl-s";
3180 coe {< m_first = first; m_active = active >}
3182 | @u when ctrl ->
3183 G.postRedisplay "outline ctrl-u";
3184 if m_autonarrow && nonemptystr m_qsearch
3185 then (
3186 ignore (source#renarrow);
3187 settext m_autonarrow E.s;
3188 coe {< m_first = 0; m_active = 0; m_qsearch = E.s >}
3190 else (
3191 source#del_narrow_pattern;
3192 let pattern = source#renarrow in
3193 let text =
3194 if emptystr pattern then E.s else "Narrowed to " ^ pattern
3196 settext m_autonarrow text;
3197 coe {< m_first = 0; m_active = 0; m_qsearch = E.s >}
3200 | @l when ctrl ->
3201 let first = max 0 (m_active - (fstate.maxrows / 2)) in
3202 G.postRedisplay "outline ctrl-l";
3203 coe {< m_first = first >}
3205 | @tab when m_autonarrow ->
3206 if nonemptystr m_qsearch
3207 then (
3208 G.postRedisplay "outline list view tab";
3209 source#add_narrow_pattern m_qsearch;
3210 settext true E.s;
3211 coe {< m_qsearch = E.s >}
3213 else coe self
3215 | @escape when m_autonarrow ->
3216 if nonemptystr m_qsearch
3217 then source#add_narrow_pattern m_qsearch;
3218 super#key key mask
3220 | @enter | @kpenter when m_autonarrow ->
3221 if nonemptystr m_qsearch
3222 then source#add_narrow_pattern m_qsearch;
3223 super#key key mask
3225 | key when m_autonarrow && (not (Wsi.isspecialkey key)) ->
3226 let pattern = m_qsearch ^ toutf8 key in
3227 G.postRedisplay "outlinelistview autonarrow add";
3228 source#narrow pattern;
3229 settext true pattern;
3230 coe {< m_first = 0; m_active = 0; m_qsearch = pattern >}
3232 | key when m_autonarrow && key = @backspace ->
3233 if emptystr m_qsearch
3234 then coe self
3235 else
3236 let pattern = withoutlastutf8 m_qsearch in
3237 G.postRedisplay "outlinelistview autonarrow backspace";
3238 ignore (source#renarrow);
3239 source#narrow pattern;
3240 settext true pattern;
3241 coe {< m_first = 0; m_active = 0; m_qsearch = pattern >}
3243 | @up | @kpup when ctrl ->
3244 navscroll (max 0 (m_first - 1))
3246 | @down | @kpdown when ctrl ->
3247 navscroll (min (source#getitemcount - 1) (m_first + 1))
3249 | @up | @kpup -> navigate ~-1
3250 | @down | @kpdown -> navigate 1
3251 | @prior | @kpprior -> navigate ~-(fstate.maxrows)
3252 | @next | @kpnext -> navigate fstate.maxrows
3254 | @right | @kpright ->
3255 let o =
3256 if ctrl
3257 then (
3258 G.postRedisplay "outline ctrl right";
3259 {< m_pan = m_pan + 1 >}
3261 else self#updownlevel 1
3263 coe o
3265 | @left | @kpleft ->
3266 let o =
3267 if ctrl
3268 then (
3269 G.postRedisplay "outline ctrl left";
3270 {< m_pan = m_pan - 1 >}
3272 else self#updownlevel ~-1
3274 coe o
3276 | @home | @kphome ->
3277 G.postRedisplay "outline home";
3278 coe {< m_first = 0; m_active = 0 >}
3280 | @jend | @kpend ->
3281 let active = source#getitemcount - 1 in
3282 let first = max 0 (active - fstate.maxrows) in
3283 G.postRedisplay "outline end";
3284 coe {< m_active = active; m_first = first >}
3286 | _ -> super#key key mask
3287 end;;
3289 let genhistoutlines () =
3290 Config.gethist ()
3291 |> List.sort (fun (_, c1, _, _, _, _) (_, c2, _, _, _, _) ->
3292 compare c2.lastvisit c1.lastvisit)
3293 |> List.map
3294 (fun ((path, c, _, _, _, origin) as hist) ->
3295 let path = if nonemptystr origin then origin else path in
3296 let base = mbtoutf8 @@ Filename.basename path in
3297 (base ^ "\000" ^ c.title, 1, Ohistory hist)
3299 |> Array.of_list
3302 let gotohist (path, c, bookmarks, x, anchor, origin) =
3303 Config.save leavebirdseye;
3304 state.anchor <- anchor;
3305 state.bookmarks <- bookmarks;
3306 state.origin <- origin;
3307 state.x <- x;
3308 setconf conf c;
3309 let x0, y0, x1, y1 = conf.trimfuzz in
3310 wcmd "trimset %d %d %d %d %d" (btod conf.trimmargins) x0 y0 x1 y1;
3311 reshape ~firsttime:true state.winw state.winh;
3312 opendoc path origin;
3313 setzoom c.zoom;
3316 let makecheckers () =
3317 (* Based on lablGL-1.04/LablGlut/examples/lablGL/checker.ml which had
3318 following to say:
3319 converted by Issac Trotts. July 25, 2002 *)
3320 let image = GlPix.create `ubyte ~format:`luminance ~width:2 ~height:2 in
3321 Raw.sets_string (GlPix.to_raw image) ~pos:0 "\255\200\200\255";
3322 let id = GlTex.gen_texture () in
3323 GlTex.bind_texture ~target:`texture_2d id;
3324 GlPix.store (`unpack_alignment 1);
3325 GlTex.image2d image;
3326 List.iter (GlTex.parameter ~target:`texture_2d)
3327 [ `mag_filter `nearest; `min_filter `nearest ];
3331 let setcheckers enabled =
3332 match state.checkerstexid with
3333 | None ->
3334 if enabled then state.checkerstexid <- Some (makecheckers ())
3336 | Some checkerstexid ->
3337 if not enabled
3338 then (
3339 GlTex.delete_texture checkerstexid;
3340 state.checkerstexid <- None;
3344 let describe_location () =
3345 let fn = page_of_y state.y in
3346 let ln = page_of_y (state.y + state.winh - 1) in
3347 let maxy = state.maxy - (if conf.maxhfit then state.winh else 0) in
3348 let percent =
3349 if maxy <= 0
3350 then 100.
3351 else (100. *. (float state.y /. float maxy))
3353 if fn = ln
3354 then
3355 Printf.sprintf "page %d of %d [%.2f%%]"
3356 (fn+1) state.pagecount percent
3357 else
3358 Printf.sprintf
3359 "pages %d-%d of %d [%.2f%%]"
3360 (fn+1) (ln+1) state.pagecount percent
3363 let setpresentationmode v =
3364 let n = page_of_y state.y in
3365 state.anchor <- (n, 0.0, 1.0);
3366 conf.presentation <- v;
3367 if conf.fitmodel = FitPage
3368 then reqlayout conf.angle conf.fitmodel;
3369 represent ();
3372 let setbgcol (r, g, b) =
3373 let col =
3374 let r = r *. 255.0 |> truncate
3375 and g = g *. 255.0 |> truncate
3376 and b = b *. 255.0 |> truncate in
3377 r lsl 16 |> (lor) (g lsl 8) |> (lor) b
3379 Wsi.setwinbgcol col;
3382 let enterinfomode =
3383 let btos b = if b then "@Uradical" else E.s in
3384 let showextended = ref false in
3385 let leave mode _ = state.mode <- mode in
3386 let src =
3387 (object
3388 val mutable m_l = []
3389 val mutable m_a = E.a
3390 val mutable m_prev_uioh = nouioh
3391 val mutable m_prev_mode = View
3393 inherit lvsourcebase
3395 method reset prev_mode prev_uioh =
3396 m_a <- Array.of_list (List.rev m_l);
3397 m_l <- [];
3398 m_prev_mode <- prev_mode;
3399 m_prev_uioh <- prev_uioh;
3401 method int name get set =
3402 m_l <-
3403 (name, `int get, 1, Action (
3404 fun u ->
3405 let ondone s =
3406 try set (int_of_string s)
3407 with exn ->
3408 state.text <- Printf.sprintf "bad integer `%s': %s"
3409 s @@ exntos exn
3411 state.text <- E.s;
3412 let te = name ^ ": ", E.s, None, intentry, ondone, true in
3413 state.mode <- Textentry (te, leave m_prev_mode);
3415 )) :: m_l
3417 method int_with_suffix name get set =
3418 m_l <-
3419 (name, `intws get, 1, Action (
3420 fun u ->
3421 let ondone s =
3422 try set (int_of_string_with_suffix s)
3423 with exn ->
3424 state.text <- Printf.sprintf "bad integer `%s': %s"
3425 s @@ exntos exn
3427 state.text <- E.s;
3428 let te =
3429 name ^ ": ", E.s, None, intentry_with_suffix, ondone, true
3431 state.mode <- Textentry (te, leave m_prev_mode);
3433 )) :: m_l
3435 method bool ?(offset=1) ?(btos=btos) name get set =
3436 m_l <-
3437 (name, `bool (btos, get), offset, Action (
3438 fun u ->
3439 let v = get () in
3440 set (not v);
3442 )) :: m_l
3444 method color name get set =
3445 m_l <-
3446 (name, `color get, 1, Action (
3447 fun u ->
3448 let invalid = (nan, nan, nan) in
3449 let ondone s =
3450 let c =
3451 try color_of_string s
3452 with exn ->
3453 state.text <- Printf.sprintf "bad color `%s': %s"
3454 s @@ exntos exn;
3455 invalid
3457 if c <> invalid
3458 then set c;
3460 let te = name ^ ": ", E.s, None, textentry, ondone, true in
3461 state.text <- color_to_string (get ());
3462 state.mode <- Textentry (te, leave m_prev_mode);
3464 )) :: m_l
3466 method string name get set =
3467 m_l <-
3468 (name, `string get, 1, Action (
3469 fun u ->
3470 let ondone s = set s in
3471 let te = name ^ ": ", E.s, None, textentry, ondone, true in
3472 state.mode <- Textentry (te, leave m_prev_mode);
3474 )) :: m_l
3476 method colorspace name get set =
3477 m_l <-
3478 (name, `string get, 1, Action (
3479 fun _ ->
3480 let source =
3481 (object
3482 inherit lvsourcebase
3484 initializer
3485 m_active <- CSTE.to_int conf.colorspace;
3486 m_first <- 0;
3488 method getitemcount =
3489 Array.length CSTE.names
3490 method getitem n =
3491 (CSTE.names.(n), 0)
3492 method exit ~uioh ~cancel ~active ~first ~pan =
3493 ignore (uioh, first, pan);
3494 if not cancel then set active;
3495 None
3496 method hasaction _ = true
3497 end)
3499 state.text <- E.s;
3500 let modehash = findkeyhash conf "info" in
3501 coe (new listview ~zebra:false ~helpmode:false
3502 ~source ~trusted:true ~modehash)
3503 )) :: m_l
3505 method paxmark name get set =
3506 m_l <-
3507 (name, `string get, 1, Action (
3508 fun _ ->
3509 let source =
3510 (object
3511 inherit lvsourcebase
3513 initializer
3514 m_active <- MTE.to_int conf.paxmark;
3515 m_first <- 0;
3517 method getitemcount = Array.length MTE.names
3518 method getitem n = (MTE.names.(n), 0)
3519 method exit ~uioh ~cancel ~active ~first ~pan =
3520 ignore (uioh, first, pan);
3521 if not cancel then set active;
3522 None
3523 method hasaction _ = true
3524 end)
3526 state.text <- E.s;
3527 let modehash = findkeyhash conf "info" in
3528 coe (new listview ~zebra:false ~helpmode:false
3529 ~source ~trusted:true ~modehash)
3530 )) :: m_l
3532 method fitmodel name get set =
3533 m_l <-
3534 (name, `string get, 1, Action (
3535 fun _ ->
3536 let source =
3537 (object
3538 inherit lvsourcebase
3540 initializer
3541 m_active <- FMTE.to_int conf.fitmodel;
3542 m_first <- 0;
3544 method getitemcount = Array.length FMTE.names
3545 method getitem n = (FMTE.names.(n), 0)
3546 method exit ~uioh ~cancel ~active ~first ~pan =
3547 ignore (uioh, first, pan);
3548 if not cancel then set active;
3549 None
3550 method hasaction _ = true
3551 end)
3553 state.text <- E.s;
3554 let modehash = findkeyhash conf "info" in
3555 coe (new listview ~zebra:false ~helpmode:false
3556 ~source ~trusted:true ~modehash)
3557 )) :: m_l
3559 method caption s offset =
3560 m_l <- (s, `empty, offset, Noaction) :: m_l
3562 method caption2 s f offset =
3563 m_l <- (s, `string f, offset, Noaction) :: m_l
3565 method getitemcount = Array.length m_a
3567 method getitem n =
3568 let tostr = function
3569 | `int f -> string_of_int (f ())
3570 | `intws f -> string_with_suffix_of_int (f ())
3571 | `string f -> f ()
3572 | `color f -> color_to_string (f ())
3573 | `bool (btos, f) -> btos (f ())
3574 | `empty -> E.s
3576 let name, t, offset, _ = m_a.(n) in
3577 ((let s = tostr t in
3578 if nonemptystr s
3579 then Printf.sprintf "%s\t%s" name s
3580 else name),
3581 offset)
3583 method exit ~uioh ~cancel ~active ~first ~pan =
3584 let uiohopt =
3585 if not cancel
3586 then (
3587 let uioh =
3588 match m_a.(active) with
3589 | _, _, _, Action f -> f uioh
3590 | _, _, _, Noaction -> uioh
3592 Some uioh
3594 else None
3596 m_active <- active;
3597 m_first <- first;
3598 m_pan <- pan;
3599 uiohopt
3601 method hasaction n =
3602 match m_a.(n) with
3603 | _, _, _, Action _ -> true
3604 | _, _, _, Noaction -> false
3606 initializer m_active <- 1
3607 end)
3609 let rec fillsrc prevmode prevuioh =
3610 let sep () = src#caption E.s 0 in
3611 let colorp name get set =
3612 src#string name
3613 (fun () -> color_to_string (get ()))
3614 (fun v ->
3616 let c = color_of_string v in
3617 set c
3618 with exn ->
3619 state.text <- Printf.sprintf "bad color `%s': %s" v @@ exntos exn
3622 let oldmode = state.mode in
3623 let birdseye = isbirdseye state.mode in
3625 src#caption (if birdseye then "Setup (Bird's eye)" else "Setup") 0;
3627 src#bool "presentation mode"
3628 (fun () -> conf.presentation)
3629 (fun v -> setpresentationmode v);
3631 src#bool "ignore case in searches"
3632 (fun () -> conf.icase)
3633 (fun v -> conf.icase <- v);
3635 src#bool "preload"
3636 (fun () -> conf.preload)
3637 (fun v -> conf.preload <- v);
3639 src#bool "highlight links"
3640 (fun () -> conf.hlinks)
3641 (fun v -> conf.hlinks <- v);
3643 src#bool "under info"
3644 (fun () -> conf.underinfo)
3645 (fun v -> conf.underinfo <- v);
3647 src#bool "persistent bookmarks"
3648 (fun () -> conf.savebmarks)
3649 (fun v -> conf.savebmarks <- v);
3651 src#fitmodel "fit model"
3652 (fun () -> FMTE.to_string conf.fitmodel)
3653 (fun v -> reqlayout conf.angle (FMTE.of_int v));
3655 src#bool "trim margins"
3656 (fun () -> conf.trimmargins)
3657 (fun v -> settrim v conf.trimfuzz; fillsrc prevmode prevuioh);
3659 src#bool "persistent location"
3660 (fun () -> conf.jumpback)
3661 (fun v -> conf.jumpback <- v);
3663 sep ();
3664 src#int "inter-page space"
3665 (fun () -> conf.interpagespace)
3666 (fun n ->
3667 conf.interpagespace <- n;
3668 docolumns conf.columns;
3669 let pageno, py =
3670 match state.layout with
3671 | [] -> 0, 0
3672 | l :: _ ->
3673 l.pageno, l.pagey
3675 state.maxy <- calcheight ();
3676 let y = getpagey pageno in
3677 gotoxy state.x (y + py)
3680 src#int "page bias"
3681 (fun () -> conf.pagebias)
3682 (fun v -> conf.pagebias <- v);
3684 src#int "scroll step"
3685 (fun () -> conf.scrollstep)
3686 (fun n -> conf.scrollstep <- n);
3688 src#int "horizontal scroll step"
3689 (fun () -> conf.hscrollstep)
3690 (fun v -> conf.hscrollstep <- v);
3692 src#int "auto scroll step"
3693 (fun () ->
3694 match state.autoscroll with
3695 | Some step -> step
3696 | _ -> conf.autoscrollstep)
3697 (fun n ->
3698 let n = boundastep state.winh n in
3699 if state.autoscroll <> None
3700 then state.autoscroll <- Some n;
3701 conf.autoscrollstep <- n);
3703 src#int "zoom"
3704 (fun () -> truncate (conf.zoom *. 100.))
3705 (fun v -> pivotzoom ((float v) /. 100.));
3707 src#int "rotation"
3708 (fun () -> conf.angle)
3709 (fun v -> reqlayout v conf.fitmodel);
3711 src#int "scroll bar width"
3712 (fun () -> conf.scrollbw)
3713 (fun v ->
3714 conf.scrollbw <- v;
3715 reshape state.winw state.winh;
3718 src#int "scroll handle height"
3719 (fun () -> conf.scrollh)
3720 (fun v -> conf.scrollh <- v;);
3722 src#int "thumbnail width"
3723 (fun () -> conf.thumbw)
3724 (fun v ->
3725 conf.thumbw <- min 4096 v;
3726 match oldmode with
3727 | Birdseye beye ->
3728 leavebirdseye beye false;
3729 enterbirdseye ()
3730 | Textentry _
3731 | View
3732 | LinkNav _ -> ()
3735 let mode = state.mode in
3736 src#string "columns"
3737 (fun () ->
3738 match conf.columns with
3739 | Csingle _ -> "1"
3740 | Cmulti (multi, _) -> multicolumns_to_string multi
3741 | Csplit (count, _) -> "-" ^ string_of_int count
3743 (fun v ->
3744 let n, a, b = multicolumns_of_string v in
3745 setcolumns mode n a b);
3747 sep ();
3748 src#caption "Pixmap cache" 0;
3749 src#int_with_suffix "size (advisory)"
3750 (fun () -> conf.memlimit)
3751 (fun v -> conf.memlimit <- v);
3753 src#caption2 "used"
3754 (fun () -> Printf.sprintf "%s bytes, %d tiles"
3755 (string_with_suffix_of_int state.memused)
3756 (Hashtbl.length state.tilemap)) 1;
3758 sep ();
3759 src#caption "Layout" 0;
3760 src#caption2 "Dimension"
3761 (fun () ->
3762 Printf.sprintf "%dx%d (virtual %dx%d)"
3763 state.winw state.winh
3764 state.w state.maxy)
3766 if conf.debug
3767 then
3768 src#caption2 "Position" (fun () ->
3769 Printf.sprintf "%dx%d" state.x state.y
3771 else
3772 src#caption2 "Position" (fun () -> describe_location ()) 1
3775 sep ();
3776 src#bool ~offset:0 ~btos:(fun v -> if v then "(on)" else "(off)")
3777 "Save these parameters as global defaults at exit"
3778 (fun () -> conf.bedefault)
3779 (fun v -> conf.bedefault <- v)
3782 sep ();
3783 let btos b = if b then "@Ulguillemet" else "@Urguillemet" in
3784 src#bool ~offset:0 ~btos "Extended parameters"
3785 (fun () -> !showextended)
3786 (fun v -> showextended := v; fillsrc prevmode prevuioh);
3787 if !showextended
3788 then (
3789 src#bool "checkers"
3790 (fun () -> conf.checkers)
3791 (fun v -> conf.checkers <- v; setcheckers v);
3792 src#bool "update cursor"
3793 (fun () -> conf.updatecurs)
3794 (fun v -> conf.updatecurs <- v);
3795 src#bool "scroll-bar on the left"
3796 (fun () -> conf.leftscroll)
3797 (fun v -> conf.leftscroll <- v);
3798 src#bool "verbose"
3799 (fun () -> conf.verbose)
3800 (fun v -> conf.verbose <- v);
3801 src#bool "invert colors"
3802 (fun () -> conf.invert)
3803 (fun v -> conf.invert <- v);
3804 src#bool "max fit"
3805 (fun () -> conf.maxhfit)
3806 (fun v -> conf.maxhfit <- v);
3807 src#bool "pax mode"
3808 (fun () -> conf.pax != None)
3809 (fun v ->
3810 if v
3811 then conf.pax <- Some (ref (now (), 0, 0))
3812 else conf.pax <- None);
3813 src#string "uri launcher"
3814 (fun () -> conf.urilauncher)
3815 (fun v -> conf.urilauncher <- v);
3816 src#string "path launcher"
3817 (fun () -> conf.pathlauncher)
3818 (fun v -> conf.pathlauncher <- v);
3819 src#string "tile size"
3820 (fun () -> Printf.sprintf "%dx%d" conf.tilew conf.tileh)
3821 (fun v ->
3823 let w, h = Scanf.sscanf v "%dx%d" (fun w h -> w, h) in
3824 conf.tilew <- max 64 w;
3825 conf.tileh <- max 64 h;
3826 flushtiles ();
3827 with exn ->
3828 state.text <- Printf.sprintf "bad tile size `%s': %s"
3829 v @@ exntos exn
3831 src#int "texture count"
3832 (fun () -> conf.texcount)
3833 (fun v ->
3834 if realloctexts v
3835 then conf.texcount <- v
3836 else impmsg "failed to set texture count please retry later"
3838 src#int "slice height"
3839 (fun () -> conf.sliceheight)
3840 (fun v ->
3841 conf.sliceheight <- v;
3842 wcmd "sliceh %d" conf.sliceheight;
3844 src#int "anti-aliasing level"
3845 (fun () -> conf.aalevel)
3846 (fun v ->
3847 conf.aalevel <- bound v 0 8;
3848 state.anchor <- getanchor ();
3849 opendoc state.path state.password;
3851 src#string "page scroll scaling factor"
3852 (fun () -> string_of_float conf.pgscale)
3853 (fun v ->
3855 let s = float_of_string v in
3856 conf.pgscale <- s
3857 with exn ->
3858 state.text <- Printf.sprintf
3859 "bad page scroll scaling factor `%s': %s" v @@ exntos exn
3862 src#int "ui font size"
3863 (fun () -> fstate.fontsize)
3864 (fun v -> setfontsize (bound v 5 100));
3865 src#int "hint font size"
3866 (fun () -> conf.hfsize)
3867 (fun v -> conf.hfsize <- bound v 5 100);
3868 colorp "background color"
3869 (fun () -> conf.bgcolor)
3870 (fun v -> conf.bgcolor <- v; setbgcol v);
3871 src#bool "crop hack"
3872 (fun () -> conf.crophack)
3873 (fun v -> conf.crophack <- v);
3874 src#string "trim fuzz"
3875 (fun () -> irect_to_string conf.trimfuzz)
3876 (fun v ->
3878 conf.trimfuzz <- irect_of_string v;
3879 if conf.trimmargins
3880 then settrim true conf.trimfuzz;
3881 with exn ->
3882 state.text <- Printf.sprintf "bad irect `%s': %s" v @@ exntos exn
3884 src#string "throttle"
3885 (fun () ->
3886 match conf.maxwait with
3887 | None -> "show place holder if page is not ready"
3888 | Some time ->
3889 if time = infinity
3890 then "wait for page to fully render"
3891 else
3892 "wait " ^ string_of_float time
3893 ^ " seconds before showing placeholder"
3895 (fun v ->
3897 let f = float_of_string v in
3898 if f <= 0.0
3899 then conf.maxwait <- None
3900 else conf.maxwait <- Some f
3901 with exn ->
3902 state.text <- Printf.sprintf "bad time `%s': %s" v @@ exntos exn
3904 src#string "ghyll scroll"
3905 (fun () ->
3906 match conf.ghyllscroll with
3907 | None -> E.s
3908 | Some nab -> ghyllscroll_to_string nab
3910 (fun v ->
3911 try conf.ghyllscroll <- ghyllscroll_of_string v
3912 with
3913 | Failure msg ->
3914 state.text <- Printf.sprintf "bad ghyll `%s': %s" v msg
3915 | exn ->
3916 state.text <- Printf.sprintf "bad ghyll `%s': %s" v @@ exntos exn
3918 src#string "selection command"
3919 (fun () -> conf.selcmd)
3920 (fun v -> conf.selcmd <- v);
3921 src#string "synctex command"
3922 (fun () -> conf.stcmd)
3923 (fun v -> conf.stcmd <- v);
3924 src#string "pax command"
3925 (fun () -> conf.paxcmd)
3926 (fun v -> conf.paxcmd <- v);
3927 src#string "ask password command"
3928 (fun () -> conf.passcmd)
3929 (fun v -> conf.passcmd <- v);
3930 src#string "save path command"
3931 (fun () -> conf.savecmd)
3932 (fun v -> conf.savecmd <- v);
3933 src#colorspace "color space"
3934 (fun () -> CSTE.to_string conf.colorspace)
3935 (fun v ->
3936 conf.colorspace <- CSTE.of_int v;
3937 wcmd "cs %d" v;
3938 load state.layout;
3940 src#paxmark "pax mark method"
3941 (fun () -> MTE.to_string conf.paxmark)
3942 (fun v -> conf.paxmark <- MTE.of_int v);
3943 if bousable () && !opengl_has_pbo
3944 then
3945 src#bool "use PBO"
3946 (fun () -> conf.usepbo)
3947 (fun v -> conf.usepbo <- v);
3948 src#bool "mouse wheel scrolls pages"
3949 (fun () -> conf.wheelbypage)
3950 (fun v -> conf.wheelbypage <- v);
3951 src#bool "open remote links in a new instance"
3952 (fun () -> conf.riani)
3953 (fun v -> conf.riani <- v);
3954 src#bool "edit annotations inline"
3955 (fun () -> conf.annotinline)
3956 (fun v -> conf.annotinline <- v);
3957 src#bool "coarse positioning in presentation mode"
3958 (fun () -> conf.coarseprespos)
3959 (fun v -> conf.coarseprespos <- v);
3962 sep ();
3963 src#caption "Document" 0;
3964 List.iter (fun (_, s) -> src#caption s 1) state.docinfo;
3965 src#caption2 "Pages"
3966 (fun () -> string_of_int state.pagecount) 1;
3967 src#caption2 "Dimensions"
3968 (fun () -> string_of_int (List.length state.pdims)) 1;
3969 if conf.trimmargins
3970 then (
3971 sep ();
3972 src#caption "Trimmed margins" 0;
3973 src#caption2 "Dimensions"
3974 (fun () -> string_of_int (List.length state.pdims)) 1;
3977 sep ();
3978 src#caption "OpenGL" 0;
3979 src#caption (Printf.sprintf "Vendor\t%s" (GlMisc.get_string `vendor)) 1;
3980 src#caption (Printf.sprintf "Renderer\t%s" (GlMisc.get_string `renderer)) 1;
3982 sep ();
3983 src#caption "Location" 0;
3984 if nonemptystr state.origin
3985 then src#caption ("Orign\t" ^ mbtoutf8 state.origin) 1;
3986 src#caption ("Path\t" ^ mbtoutf8 state.path) 1;
3988 src#reset prevmode prevuioh;
3990 fun () ->
3991 state.text <- E.s;
3992 resetmstate ();
3993 let prevmode = state.mode
3994 and prevuioh = state.uioh in
3995 fillsrc prevmode prevuioh;
3996 let source = (src :> lvsource) in
3997 let modehash = findkeyhash conf "info" in
3998 state.uioh <- coe (object (self)
3999 inherit listview ~zebra:false ~helpmode:false
4000 ~source ~trusted:true ~modehash as super
4001 val mutable m_prevmemused = 0
4002 method! infochanged = function
4003 | Memused ->
4004 if m_prevmemused != state.memused
4005 then (
4006 m_prevmemused <- state.memused;
4007 G.postRedisplay "memusedchanged";
4009 | Pdim -> G.postRedisplay "pdimchanged"
4010 | Docinfo -> fillsrc prevmode prevuioh
4012 method! key key mask =
4013 if not (Wsi.withctrl mask)
4014 then
4015 match key with
4016 | @left | @kpleft -> coe (self#updownlevel ~-1)
4017 | @right | @kpright -> coe (self#updownlevel 1)
4018 | _ -> super#key key mask
4019 else super#key key mask
4020 end);
4021 G.postRedisplay "info";
4024 let enterhelpmode =
4025 let source =
4026 (object
4027 inherit lvsourcebase
4028 method getitemcount = Array.length state.help
4029 method getitem n =
4030 let s, l, _ = state.help.(n) in
4031 (s, l)
4033 method exit ~uioh ~cancel ~active ~first ~pan =
4034 let optuioh =
4035 if not cancel
4036 then (
4037 match state.help.(active) with
4038 | _, _, Action f -> Some (f uioh)
4039 | _, _, Noaction -> Some uioh
4041 else None
4043 m_active <- active;
4044 m_first <- first;
4045 m_pan <- pan;
4046 optuioh
4048 method hasaction n =
4049 match state.help.(n) with
4050 | _, _, Action _ -> true
4051 | _, _, Noaction -> false
4053 initializer
4054 m_active <- -1
4055 end)
4056 in fun () ->
4057 let modehash = findkeyhash conf "help" in
4058 resetmstate ();
4059 state.uioh <- coe (new listview
4060 ~zebra:false ~helpmode:true
4061 ~source ~trusted:true ~modehash);
4062 G.postRedisplay "help";
4065 let entermsgsmode =
4066 let msgsource =
4067 (object
4068 inherit lvsourcebase
4069 val mutable m_items = E.a
4071 method getitemcount = 1 + Array.length m_items
4073 method getitem n =
4074 if n = 0
4075 then "[Clear]", 0
4076 else m_items.(n-1), 0
4078 method exit ~uioh ~cancel ~active ~first ~pan =
4079 ignore uioh;
4080 if not cancel
4081 then (
4082 if active = 0
4083 then Buffer.clear state.errmsgs;
4085 m_active <- active;
4086 m_first <- first;
4087 m_pan <- pan;
4088 None
4090 method hasaction n =
4091 n = 0
4093 method reset =
4094 state.newerrmsgs <- false;
4095 let l = Str.split newlinere (Buffer.contents state.errmsgs) in
4096 m_items <- Array.of_list l
4098 initializer
4099 m_active <- 0
4100 end)
4101 in fun () ->
4102 state.text <- E.s;
4103 resetmstate ();
4104 msgsource#reset;
4105 let source = (msgsource :> lvsource) in
4106 let modehash = findkeyhash conf "listview" in
4107 state.uioh <- coe (object
4108 inherit listview ~zebra:false ~helpmode:false
4109 ~source ~trusted:false ~modehash as super
4110 method! display =
4111 if state.newerrmsgs
4112 then msgsource#reset;
4113 super#display
4114 end);
4115 G.postRedisplay "msgs";
4118 let getusertext s =
4119 let editor = getenvwithdef "EDITOR" E.s in
4120 if emptystr editor
4121 then E.s
4122 else
4123 let tmppath = Filename.temp_file "llpp" "note" in
4124 if nonemptystr s
4125 then (
4126 let oc = open_out tmppath in
4127 output_string oc s;
4128 close_out oc;
4130 let execstr = editor ^ " " ^ tmppath in
4131 let s =
4132 match spawn execstr [] with
4133 | (exception exn) ->
4134 impmsg "spawn(%S) failed: %s" execstr @@ exntos exn;
4136 | pid ->
4137 match Unix.waitpid [] pid with
4138 | (exception exn) ->
4139 impmsg "waitpid(%d) failed: %s" pid @@ exntos exn;
4141 | (_pid, status) ->
4142 match status with
4143 | Unix.WEXITED 0 -> filecontents tmppath
4144 | Unix.WEXITED n ->
4145 impmsg "editor process(%s) exited abnormally: %d" execstr n;
4147 | Unix.WSIGNALED n ->
4148 impmsg "editor process(%s) was killed by signal %d" execstr n;
4150 | Unix.WSTOPPED n ->
4151 impmsg "editor(%s) process was stopped by signal %d" execstr n;
4154 match Unix.unlink tmppath with
4155 | (exception exn) ->
4156 impmsg "failed to ulink %S: %s" tmppath @@ exntos exn;
4158 | () -> s
4161 let enterannotmode opaque slinkindex =
4162 let msgsource =
4163 (object
4164 inherit lvsourcebase
4165 val mutable m_text = E.s
4166 val mutable m_items = E.a
4168 method getitemcount = Array.length m_items
4170 method getitem n =
4171 let label, _func = m_items.(n) in
4172 label, 0
4174 method exit ~uioh ~cancel ~active ~first ~pan =
4175 ignore (uioh, first, pan);
4176 if not cancel
4177 then (
4178 let _label, func = m_items.(active) in
4179 func ()
4181 None
4183 method hasaction n = nonemptystr @@ fst m_items.(n)
4185 method reset s =
4186 let rec split accu b i =
4187 let p = b+i in
4188 if p = String.length s
4189 then (String.sub s b (p-b), unit) :: accu
4190 else
4191 if (i > 70 && s.[p] = ' ') || s.[p] = '\r' || s.[p] = '\n'
4192 then
4193 let ss = if i = 0 then E.s else String.sub s b i in
4194 split ((ss, unit)::accu) (p+1) 0
4195 else
4196 split accu b (i+1)
4198 let cleanup () =
4199 wcmd "freepage %s" (~> opaque);
4200 let keys =
4201 Hashtbl.fold (fun key opaque' accu ->
4202 if opaque' = opaque'
4203 then key :: accu else accu) state.pagemap []
4205 List.iter (Hashtbl.remove state.pagemap) keys;
4206 flushtiles ();
4207 gotoxy state.x state.y
4209 let dele () =
4210 delannot opaque slinkindex;
4211 cleanup ();
4213 let edit inline () =
4214 let update s =
4215 if emptystr s
4216 then dele ()
4217 else (
4218 modannot opaque slinkindex s;
4219 cleanup ();
4222 if inline
4223 then
4224 let mode = state.mode in
4225 state.mode <-
4226 Textentry (
4227 ("annotation: ", m_text, None, textentry, update, true),
4228 fun _ -> state.mode <- mode);
4229 state.text <- E.s;
4230 enttext ();
4231 else
4232 let s = getusertext m_text in
4233 update s
4235 m_text <- s;
4236 m_items <-
4237 ( "[Copy]", fun () -> selstring m_text)
4238 :: ("[Delete]", dele)
4239 :: ("[Edit]", edit conf.annotinline)
4240 :: (E.s, unit)
4241 :: split [] 0 0 |> List.rev |> Array.of_list
4243 initializer
4244 m_active <- 0
4245 end)
4247 state.text <- E.s;
4248 let s = getannotcontents opaque slinkindex in
4249 resetmstate ();
4250 msgsource#reset s;
4251 let source = (msgsource :> lvsource) in
4252 let modehash = findkeyhash conf "listview" in
4253 state.uioh <- coe (object
4254 inherit listview ~zebra:false ~helpmode:false
4255 ~source ~trusted:false ~modehash
4256 end);
4257 G.postRedisplay "enterannotmode";
4260 let gotounder under =
4261 let getpath filename =
4262 let path =
4263 if nonemptystr filename
4264 then
4265 if Filename.is_relative filename
4266 then
4267 let dir = Filename.dirname state.path in
4268 let dir =
4269 if Filename.is_implicit dir
4270 then Filename.concat (Sys.getcwd ()) dir
4271 else dir
4273 Filename.concat dir filename
4274 else filename
4275 else E.s
4277 if Sys.file_exists path
4278 then path
4279 else E.s
4281 match under with
4282 | Ulinkgoto (pageno, top) ->
4283 if pageno >= 0
4284 then (
4285 addnav ();
4286 let top =
4287 if conf.presentation && conf.coarseprespos
4288 then 0
4289 else top
4291 gotopage1 pageno top;
4294 | Ulinkuri s -> gotouri s
4296 | Uremote (filename, pageno) ->
4297 let path = getpath filename in
4298 if nonemptystr path
4299 then (
4300 if conf.riani
4301 then
4302 let command = Printf.sprintf "%s -page %d %S" !selfexec pageno path in
4303 match spawn command [] with
4304 | _pid -> ()
4305 | (exception exn) ->
4306 dolog "failed to execute `%s': %s" command @@ exntos exn
4307 else
4308 let anchor = getanchor () in
4309 let ranchor = state.path, state.password, anchor, state.origin in
4310 state.origin <- E.s;
4311 state.anchor <- (pageno, 0.0, 0.0);
4312 state.ranchors <- ranchor :: state.ranchors;
4313 opendoc path E.s;
4315 else impmsg "cannot find %s" filename
4317 | Uremotedest (filename, destname) ->
4318 let path = getpath filename in
4319 if nonemptystr path
4320 then (
4321 if conf.riani
4322 then
4323 let command = !selfexec ^ " " ^ path ^ " -dest " ^ destname in
4324 match spawn command [] with
4325 | (exception exn) ->
4326 dolog "failed to execute `%s': %s" command @@ exntos exn
4327 | _pid -> ()
4328 else
4329 let anchor = getanchor () in
4330 let ranchor = state.path, state.password, anchor, state.origin in
4331 state.origin <- E.s;
4332 state.nameddest <- destname;
4333 state.ranchors <- ranchor :: state.ranchors;
4334 opendoc path E.s;
4336 else impmsg "cannot find %s" filename
4338 | Uunexpected _ | Ulaunch _ | Unamed _ | Utext _ | Unone -> ()
4339 | Uannotation (opaque, slinkindex) -> enterannotmode opaque slinkindex
4342 let gotooutline (_, _, kind) =
4343 match kind with
4344 | Onone -> ()
4345 | Oanchor anchor ->
4346 let (pageno, y, _) = anchor in
4347 let y = getanchory
4348 (if conf.presentation then (pageno, y, 1.0) else anchor)
4350 addnav ();
4351 gotoghyll y
4352 | Ouri uri -> gotounder (Ulinkuri uri)
4353 | Olaunch cmd -> gotounder (Ulaunch cmd)
4354 | Oremote remote -> gotounder (Uremote remote)
4355 | Ohistory hist -> gotohist hist
4356 | Oremotedest remotedest -> gotounder (Uremotedest remotedest)
4359 class outlinesoucebase fetchoutlines = object (self)
4360 inherit lvsourcebase
4361 val mutable m_items = E.a
4362 val mutable m_minfo = E.a
4363 val mutable m_orig_items = E.a
4364 val mutable m_orig_minfo = E.a
4365 val mutable m_narrow_patterns = []
4366 val mutable m_gen = -1
4368 method getitemcount = Array.length m_items
4370 method getitem n =
4371 let s, n, _ = m_items.(n) in
4372 (s, n+0)
4374 method exit ~(uioh:uioh) ~cancel ~active ~(first:int) ~pan :
4375 uioh option =
4376 ignore (uioh, first);
4377 let items, minfo =
4378 if m_narrow_patterns = []
4379 then m_orig_items, m_orig_minfo
4380 else m_items, m_minfo
4382 m_pan <- pan;
4383 if not cancel
4384 then (
4385 m_items <- items;
4386 m_minfo <- minfo;
4387 gotooutline m_items.(active);
4389 else (
4390 m_items <- items;
4391 m_minfo <- minfo;
4393 None
4395 method hasaction (_:int) = true
4397 method greetmsg =
4398 if Array.length m_items != Array.length m_orig_items
4399 then
4400 let s =
4401 match m_narrow_patterns with
4402 | one :: [] -> one
4403 | many -> String.concat "@Uellipsis" (List.rev many)
4405 "Narrowed to " ^ s ^ " (ctrl-u to restore)"
4406 else E.s
4408 method statestr =
4409 match m_narrow_patterns with
4410 | [] -> E.s
4411 | one :: [] -> one
4412 | head :: _ -> "@Uellipsis" ^ head
4414 method narrow pattern =
4415 match Str.regexp_case_fold pattern with
4416 | (exception _) -> ()
4417 | re ->
4418 let rec loop accu minfo n =
4419 if n = -1
4420 then (
4421 m_items <- Array.of_list accu;
4422 m_minfo <- Array.of_list minfo;
4424 else
4425 let (s, _, _) as o = m_items.(n) in
4426 let accu, minfo =
4427 match Str.search_forward re s 0 with
4428 | (exception Not_found) -> accu, minfo
4429 | first -> o :: accu, (first, Str.match_end ()) :: minfo
4431 loop accu minfo (n-1)
4433 loop [] [] (Array.length m_items - 1)
4435 method! getminfo = m_minfo
4437 method denarrow =
4438 m_orig_items <- fetchoutlines ();
4439 m_minfo <- m_orig_minfo;
4440 m_items <- m_orig_items
4442 method add_narrow_pattern pattern =
4443 m_narrow_patterns <- pattern :: m_narrow_patterns
4445 method del_narrow_pattern =
4446 match m_narrow_patterns with
4447 | _ :: rest -> m_narrow_patterns <- rest
4448 | [] -> ()
4450 method renarrow =
4451 self#denarrow;
4452 match m_narrow_patterns with
4453 | pattern :: [] -> self#narrow pattern; pattern
4454 | list ->
4455 List.fold_left (fun accu pattern ->
4456 self#narrow pattern;
4457 pattern ^ "@Uellipsis" ^ accu) E.s list
4459 method calcactive (_:anchor) = 0
4461 method reset anchor items =
4462 if state.gen != m_gen
4463 then (
4464 m_orig_items <- items;
4465 m_items <- items;
4466 m_narrow_patterns <- [];
4467 m_minfo <- E.a;
4468 m_orig_minfo <- E.a;
4469 m_gen <- state.gen;
4471 else (
4472 if items != m_orig_items
4473 then (
4474 m_orig_items <- items;
4475 if m_narrow_patterns == []
4476 then m_items <- items;
4479 let active = self#calcactive anchor in
4480 m_active <- active;
4481 m_first <- firstof m_first active
4485 let outlinesource fetchoutlines =
4486 (object
4487 inherit outlinesoucebase fetchoutlines
4488 method! calcactive anchor =
4489 let rely = getanchory anchor in
4490 let rec loop n best bestd =
4491 if n = Array.length m_items
4492 then best
4493 else
4494 let _, _, kind = m_items.(n) in
4495 match kind with
4496 | Oanchor anchor ->
4497 let orely = getanchory anchor in
4498 let d = abs (orely - rely) in
4499 if d < bestd
4500 then loop (n+1) n d
4501 else loop (n+1) best bestd
4502 | Onone | Oremote _ | Olaunch _
4503 | Oremotedest _ | Ouri _ | Ohistory _ ->
4504 loop (n+1) best bestd
4506 loop 0 ~-1 max_int
4507 end)
4510 let enteroutlinemode, enterbookmarkmode, enterhistmode =
4511 let mkselector sourcetype =
4512 let fetchoutlines () =
4513 match sourcetype with
4514 | `bookmarks -> Array.of_list state.bookmarks
4515 | `outlines -> state.outlines
4516 | `history -> genhistoutlines ()
4518 let source =
4519 if sourcetype = `history
4520 then new outlinesoucebase fetchoutlines
4521 else outlinesource fetchoutlines
4523 fun errmsg ->
4524 let outlines = fetchoutlines () in
4525 if Array.length outlines = 0
4526 then (
4527 showtext ' ' errmsg;
4529 else (
4530 resetmstate ();
4531 Wsi.setcursor Wsi.CURSOR_INHERIT;
4532 let anchor = getanchor () in
4533 source#reset anchor outlines;
4534 state.text <- source#greetmsg;
4535 state.uioh <-
4536 coe (new outlinelistview ~zebra:(sourcetype=`history) ~source);
4537 G.postRedisplay "enter selector";
4540 let mkenter sourcetype errmsg =
4541 let enter = mkselector sourcetype in
4542 fun () -> enter errmsg
4544 (**)mkenter `outlines "document has no outline"
4545 , mkenter `bookmarks "document has no bookmarks (yet)"
4546 , mkenter `history "history is empty"
4549 let quickbookmark ?title () =
4550 match state.layout with
4551 | [] -> ()
4552 | l :: _ ->
4553 let title =
4554 match title with
4555 | None ->
4556 let tm = Unix.localtime (now ()) in
4557 Printf.sprintf
4558 "Quick (page %d) (bookmarked at %02d/%02d/%d %02d:%02d)"
4559 (l.pageno+1)
4560 tm.Unix.tm_mday
4561 (tm.Unix.tm_mon+1)
4562 (tm.Unix.tm_year + 1900)
4563 tm.Unix.tm_hour
4564 tm.Unix.tm_min
4565 | Some title -> title
4567 state.bookmarks <- (title, 0, Oanchor (getanchor1 l)) :: state.bookmarks
4570 let setautoscrollspeed step goingdown =
4571 let incr = max 1 ((abs step) / 2) in
4572 let incr = if goingdown then incr else -incr in
4573 let astep = boundastep state.winh (step + incr) in
4574 state.autoscroll <- Some astep;
4577 let canpan () =
4578 match conf.columns with
4579 | Csplit _ -> true
4580 | Csingle _ | Cmulti _ -> state.x != 0 || conf.zoom > 1.0
4583 let panbound x = bound x (-state.w) state.winw;;
4585 let existsinrow pageno (columns, coverA, coverB) p =
4586 let last = ((pageno - coverA) mod columns) + columns in
4587 let rec any = function
4588 | [] -> false
4589 | l :: rest ->
4590 if l.pageno = coverA - 1 || l.pageno = state.pagecount - coverB
4591 then p l
4592 else (
4593 if not (p l)
4594 then (if l.pageno = last then false else any rest)
4595 else true
4598 any state.layout
4601 let nextpage () =
4602 match state.layout with
4603 | [] ->
4604 let pageno = page_of_y state.y in
4605 gotoghyll (getpagey (pageno+1))
4606 | l :: rest ->
4607 match conf.columns with
4608 | Csingle _ ->
4609 if conf.presentation && rest == [] && l.pageh > l.pagey + l.pagevh
4610 then
4611 let y = clamp (pgscale state.winh) in
4612 gotoghyll y
4613 else
4614 let pageno = min (l.pageno+1) (state.pagecount-1) in
4615 gotoghyll (getpagey pageno)
4616 | Cmulti ((c, _, _) as cl, _) ->
4617 if conf.presentation
4618 && (existsinrow l.pageno cl
4619 (fun l -> l.pageh > l.pagey + l.pagevh))
4620 then
4621 let y = clamp (pgscale state.winh) in
4622 gotoghyll y
4623 else
4624 let pageno = min (l.pageno+c) (state.pagecount-1) in
4625 gotoghyll (getpagey pageno)
4626 | Csplit (n, _) ->
4627 if l.pageno < state.pagecount - 1 || l.pagecol < n - 1
4628 then
4629 let pagey, pageh = getpageyh l.pageno in
4630 let pagey = pagey + pageh * l.pagecol in
4631 let ips = if l.pagecol = 0 then 0 else conf.interpagespace in
4632 gotoghyll (pagey + pageh + ips)
4635 let prevpage () =
4636 match state.layout with
4637 | [] ->
4638 let pageno = page_of_y state.y in
4639 gotoghyll (getpagey (pageno-1))
4640 | l :: _ ->
4641 match conf.columns with
4642 | Csingle _ ->
4643 if conf.presentation && l.pagey != 0
4644 then
4645 gotoghyll (clamp (pgscale ~-(state.winh)))
4646 else
4647 let pageno = max 0 (l.pageno-1) in
4648 gotoghyll (getpagey pageno)
4649 | Cmulti ((c, _, coverB) as cl, _) ->
4650 if conf.presentation &&
4651 (existsinrow l.pageno cl (fun l -> l.pagey != 0))
4652 then
4653 gotoghyll (clamp (pgscale ~-(state.winh)))
4654 else
4655 let decr =
4656 if l.pageno = state.pagecount - coverB
4657 then 1
4658 else c
4660 let pageno = max 0 (l.pageno-decr) in
4661 gotoghyll (getpagey pageno)
4662 | Csplit (n, _) ->
4663 let y =
4664 if l.pagecol = 0
4665 then
4666 if l.pageno = 0
4667 then l.pagey
4668 else
4669 let pageno = max 0 (l.pageno-1) in
4670 let pagey, pageh = getpageyh pageno in
4671 pagey + (n-1)*pageh
4672 else
4673 let pagey, pageh = getpageyh l.pageno in
4674 pagey + pageh * (l.pagecol-1) - conf.interpagespace
4676 gotoghyll y
4679 let save () =
4680 if emptystr conf.savecmd
4681 then error "don't know where to save modified document"
4682 else
4683 let savecmd = Str.global_replace percentsre state.path conf.savecmd in
4684 let path =
4685 getcmdoutput
4686 (fun s -> error "failed to obtain path to the saved copy: %s" s)
4687 savecmd
4689 if nonemptystr path
4690 then
4691 let tmp = path ^ ".tmp" in
4692 savedoc tmp;
4693 Unix.rename tmp path;
4696 let viewkeyboard key mask =
4697 let enttext te =
4698 let mode = state.mode in
4699 state.mode <- Textentry (te, fun _ -> state.mode <- mode);
4700 state.text <- E.s;
4701 enttext ();
4702 G.postRedisplay "view:enttext"
4704 let ctrl = Wsi.withctrl mask in
4705 let key = Wsi.keypadtodigitkey key in
4706 match key with
4707 | @Q -> exit 0
4709 | @W ->
4710 if hasunsavedchanges ()
4711 then save ()
4713 | @insert ->
4714 if conf.angle mod 360 = 0 && not (isbirdseye state.mode)
4715 then (
4716 state.mode <- LinkNav (Ltgendir 0);
4717 gotoxy state.x state.y;
4719 else impmsg "keyboard link navigation does not work under rotation"
4721 | @escape | @q ->
4722 begin match state.mstate with
4723 | Mzoomrect _ ->
4724 resetmstate ();
4725 G.postRedisplay "kill rect";
4726 | Msel _
4727 | Mpan _
4728 | Mscrolly | Mscrollx
4729 | Mzoom _
4730 | Mnone ->
4731 begin match state.mode with
4732 | LinkNav _ ->
4733 state.mode <- View;
4734 G.postRedisplay "esc leave linknav"
4735 | Birdseye _
4736 | Textentry _
4737 | View ->
4738 match state.ranchors with
4739 | [] -> raise Quit
4740 | (path, password, anchor, origin) :: rest ->
4741 state.ranchors <- rest;
4742 state.anchor <- anchor;
4743 state.origin <- origin;
4744 state.nameddest <- E.s;
4745 opendoc path password
4746 end;
4747 end;
4749 | @backspace ->
4750 gotoghyll (getnav ~-1)
4752 | @o ->
4753 enteroutlinemode ()
4755 | @H ->
4756 enterhistmode ()
4758 | @u ->
4759 state.rects <- [];
4760 state.text <- E.s;
4761 Hashtbl.iter (fun _ opaque ->
4762 clearmark opaque;
4763 Hashtbl.clear state.prects) state.pagemap;
4764 G.postRedisplay "dehighlight";
4766 | @slash | @question ->
4767 let ondone isforw s =
4768 cbput state.hists.pat s;
4769 state.searchpattern <- s;
4770 search s isforw
4772 let s = String.make 1 (Char.chr key) in
4773 enttext (s, E.s, Some (onhist state.hists.pat),
4774 textentry, ondone (key = @slash), true)
4776 | @plus | @kpplus | @equals when ctrl ->
4777 let incr = if conf.zoom +. 0.01 > 0.1 then 0.1 else 0.01 in
4778 pivotzoom (conf.zoom +. incr)
4780 | @plus | @kpplus ->
4781 let ondone s =
4782 let n =
4783 try int_of_string s with exn ->
4784 state.text <- Printf.sprintf "bad integer `%s': %s" s @@ exntos exn;
4785 max_int
4787 if n != max_int
4788 then (
4789 conf.pagebias <- n;
4790 state.text <- "page bias is now " ^ string_of_int n;
4793 enttext ("page bias: ", E.s, None, intentry, ondone, true)
4795 | @minus | @kpminus when ctrl ->
4796 let decr = if conf.zoom -. 0.1 < 0.1 then 0.01 else 0.1 in
4797 pivotzoom (max 0.01 (conf.zoom -. decr))
4799 | @minus | @kpminus ->
4800 let ondone msg = state.text <- msg in
4801 enttext (
4802 "option [acfhilpstvxACFPRSZTISM]: ", E.s, None,
4803 optentry state.mode, ondone, true
4806 | @0 when ctrl ->
4807 if conf.zoom = 1.0
4808 then gotoxy 0 state.y
4809 else setzoom 1.0
4811 | (@1 | @2) when ctrl && conf.fitmodel != FitPage -> (* ctrl-1/2 *)
4812 let cols =
4813 match conf.columns with
4814 | Csingle _ | Cmulti _ -> 1
4815 | Csplit (n, _) -> n
4817 let h = state.winh -
4818 conf.interpagespace lsl (if conf.presentation then 1 else 0)
4820 let zoom = zoomforh state.winw h 0 cols in
4821 if zoom > 0.0 && (key = @2 || zoom < 1.0)
4822 then setzoom zoom
4824 | @3 when ctrl ->
4825 let fm =
4826 match conf.fitmodel with
4827 | FitWidth -> FitProportional
4828 | FitProportional -> FitPage
4829 | FitPage -> FitWidth
4831 state.text <- "fit model: " ^ FMTE.to_string fm;
4832 reqlayout conf.angle fm
4834 | @4 when ctrl -> (* ctrl-4 *)
4835 let zoom = getmaxw () /. float state.winw in
4836 if zoom > 0.0 then setzoom zoom
4838 | @F9 ->
4839 togglebirdseye ()
4841 | @9 when ctrl ->
4842 togglebirdseye ()
4844 | (48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57)
4845 when not ctrl -> (* 0..9 *)
4846 let ondone s =
4847 let n =
4848 try int_of_string s with exn ->
4849 state.text <- Printf.sprintf "bad integer `%s': %s" s @@ exntos exn;
4852 if n >= 0
4853 then (
4854 addnav ();
4855 cbput state.hists.pag (string_of_int n);
4856 gotopage1 (n + conf.pagebias - 1) 0;
4859 let pageentry text key =
4860 match Char.unsafe_chr key with
4861 | 'g' -> TEdone text
4862 | _ -> intentry text key
4864 let text = String.make 1 (Char.chr key) in
4865 enttext (":", text, Some (onhist state.hists.pag),
4866 pageentry, ondone, true)
4868 | @b ->
4869 conf.scrollb <- if conf.scrollb = 0 then (scrollbvv lor scrollbhv) else 0;
4870 reshape state.winw state.winh;
4872 | @B ->
4873 state.bzoom <- not state.bzoom;
4874 state.rects <- [];
4875 showtext ' ' ("block zoom " ^ if state.bzoom then "on" else "off")
4877 | @l ->
4878 conf.hlinks <- not conf.hlinks;
4879 state.text <- "highlightlinks " ^ if conf.hlinks then "on" else "off";
4880 G.postRedisplay "toggle highlightlinks";
4882 | @F ->
4883 if conf.angle mod 360 = 0
4884 then (
4885 state.glinks <- true;
4886 let mode = state.mode in
4887 state.mode <-
4888 Textentry (
4889 (":", E.s, None, linknentry, linknact gotounder, false),
4890 (fun _ ->
4891 state.glinks <- false;
4892 state.mode <- mode)
4894 state.text <- E.s;
4895 G.postRedisplay "view:linkent(F)"
4897 else impmsg "hint mode does not work under rotation"
4899 | @y ->
4900 state.glinks <- true;
4901 let mode = state.mode in
4902 state.mode <- Textentry (
4904 ":", E.s, None, linknentry, linknact (fun under ->
4905 selstring (undertext under);
4906 ), false
4908 fun _ ->
4909 state.glinks <- false;
4910 state.mode <- mode
4912 state.text <- E.s;
4913 G.postRedisplay "view:linkent"
4915 | @a ->
4916 begin match state.autoscroll with
4917 | Some step ->
4918 conf.autoscrollstep <- step;
4919 state.autoscroll <- None
4920 | None ->
4921 if conf.autoscrollstep = 0
4922 then state.autoscroll <- Some 1
4923 else state.autoscroll <- Some conf.autoscrollstep
4926 | @p when ctrl ->
4927 launchpath () (* XXX where do error messages go? *)
4929 | @P ->
4930 setpresentationmode (not conf.presentation);
4931 showtext ' ' ("presentation mode " ^
4932 if conf.presentation then "on" else "off");
4934 | @f ->
4935 if List.mem Wsi.Fullscreen state.winstate
4936 then Wsi.reshape conf.cwinw conf.cwinh
4937 else Wsi.fullscreen ()
4939 | @p | @N ->
4940 search state.searchpattern false
4942 | @n | @F3 ->
4943 search state.searchpattern true
4945 | @t ->
4946 begin match state.layout with
4947 | [] -> ()
4948 | l :: _ ->
4949 gotoghyll (getpagey l.pageno)
4952 | @space ->
4953 nextpage ()
4955 | @delete | @kpdelete -> (* delete *)
4956 prevpage ()
4958 | @equals ->
4959 showtext ' ' (describe_location ());
4961 | @w ->
4962 begin match state.layout with
4963 | [] -> ()
4964 | l :: _ ->
4965 Wsi.reshape l.pagew l.pageh;
4966 G.postRedisplay "w"
4969 | @apos ->
4970 enterbookmarkmode ()
4972 | @h | @F1 ->
4973 enterhelpmode ()
4975 | @i ->
4976 enterinfomode ()
4978 | @e when Buffer.length state.errmsgs > 0 ->
4979 entermsgsmode ()
4981 | @m ->
4982 let ondone s =
4983 match state.layout with
4984 | l :: _ ->
4985 if nonemptystr s
4986 then
4987 state.bookmarks <-
4988 (s, 0, Oanchor (getanchor1 l)) :: state.bookmarks
4989 | _ -> ()
4991 enttext ("bookmark: ", E.s, None, textentry, ondone, true)
4993 | @tilde ->
4994 quickbookmark ();
4995 showtext ' ' "Quick bookmark added";
4997 | @z ->
4998 begin match state.layout with
4999 | l :: _ ->
5000 let rect = getpdimrect l.pagedimno in
5001 let w, h =
5002 if conf.crophack
5003 then
5004 (truncate (1.8 *. (rect.(1) -. rect.(0))),
5005 truncate (1.2 *. (rect.(3) -. rect.(0))))
5006 else
5007 (truncate (rect.(1) -. rect.(0)),
5008 truncate (rect.(3) -. rect.(0)))
5010 let w = truncate ((float w)*.conf.zoom)
5011 and h = truncate ((float h)*.conf.zoom) in
5012 if w != 0 && h != 0
5013 then (
5014 state.anchor <- getanchor ();
5015 Wsi.reshape w (h + conf.interpagespace)
5017 G.postRedisplay "z";
5019 | [] -> ()
5022 | @x -> state.roam ()
5024 | @Lt | @Gt ->
5025 reqlayout (conf.angle +
5026 (if key = @Gt then 30 else -30)) conf.fitmodel
5028 | @Lb | @Rb ->
5029 conf.colorscale <-
5030 bound (conf.colorscale +. (if key = 93 then 0.1 else -0.1)) 0.0 1.0
5032 G.postRedisplay "brightness";
5034 | @c when state.mode = View ->
5035 if Wsi.withalt mask
5036 then (
5037 if conf.zoom > 1.0
5038 then
5039 let m = (state.winw - state.w) / 2 in
5040 gotoxy_and_clear_text m state.y
5042 else
5043 let (c, a, b), z =
5044 match state.prevcolumns with
5045 | None -> (1, 0, 0), 1.0
5046 | Some (columns, z) ->
5047 let cab =
5048 match columns with
5049 | Csplit (c, _) -> -c, 0, 0
5050 | Cmulti ((c, a, b), _) -> c, a, b
5051 | Csingle _ -> 1, 0, 0
5053 cab, z
5055 setcolumns View c a b;
5056 setzoom z
5058 | @down | @up when ctrl && Wsi.withshift mask ->
5059 let zoom, x = state.prevzoom in
5060 setzoom zoom;
5061 state.x <- x;
5063 | @k | @up | @kpup ->
5064 begin match state.autoscroll with
5065 | None ->
5066 begin match state.mode with
5067 | Birdseye beye -> upbirdseye 1 beye
5068 | Textentry _
5069 | View
5070 | LinkNav _ ->
5071 if ctrl
5072 then gotoxy_and_clear_text state.x (clamp ~-(state.winh/2))
5073 else (
5074 if not (Wsi.withshift mask) && conf.presentation
5075 then prevpage ()
5076 else gotoghyll1 true (clamp (-conf.scrollstep))
5079 | Some n ->
5080 setautoscrollspeed n false
5083 | @j | @down | @kpdown ->
5084 begin match state.autoscroll with
5085 | None ->
5086 begin match state.mode with
5087 | Birdseye beye -> downbirdseye 1 beye
5088 | Textentry _
5089 | View
5090 | LinkNav _ ->
5091 if ctrl
5092 then gotoxy_and_clear_text state.x (clamp (state.winh/2))
5093 else (
5094 if not (Wsi.withshift mask) && conf.presentation
5095 then nextpage ()
5096 else gotoghyll1 true (clamp (conf.scrollstep))
5099 | Some n ->
5100 setautoscrollspeed n true
5103 | @left | @right | @kpleft | @kpright when not (Wsi.withalt mask) ->
5104 if canpan ()
5105 then
5106 let dx =
5107 if ctrl
5108 then state.winw / 2
5109 else conf.hscrollstep
5111 let dx = if key = @left || key = @kpleft then dx else -dx in
5112 gotoxy_and_clear_text (panbound (state.x + dx)) state.y
5113 else (
5114 state.text <- E.s;
5115 G.postRedisplay "left/right"
5118 | @prior | @kpprior ->
5119 let y =
5120 if ctrl
5121 then
5122 match state.layout with
5123 | [] -> state.y
5124 | l :: _ -> state.y - l.pagey
5125 else
5126 clamp (pgscale (-state.winh))
5128 gotoghyll y
5130 | @next | @kpnext ->
5131 let y =
5132 if ctrl
5133 then
5134 match List.rev state.layout with
5135 | [] -> state.y
5136 | l :: _ -> getpagey l.pageno
5137 else
5138 clamp (pgscale state.winh)
5140 gotoghyll y
5142 | @g | @home | @kphome ->
5143 addnav ();
5144 gotoghyll 0
5145 | @G | @jend | @kpend ->
5146 addnav ();
5147 gotoghyll (clamp state.maxy)
5149 | @right | @kpright when Wsi.withalt mask ->
5150 gotoghyll (getnav 1)
5151 | @left | @kpleft when Wsi.withalt mask ->
5152 gotoghyll (getnav ~-1)
5154 | @r ->
5155 reload ()
5157 | @v when conf.debug ->
5158 state.rects <- [];
5159 List.iter (fun l ->
5160 match getopaque l.pageno with
5161 | None -> ()
5162 | Some opaque ->
5163 let x0, y0, x1, y1 = pagebbox opaque in
5164 let rect = (float x0, float y0,
5165 float x1, float y0,
5166 float x1, float y1,
5167 float x0, float y1) in
5168 debugrect rect;
5169 let color = (0.0, 0.0, 1.0 /. (l.pageno mod 3 |> float), 0.5) in
5170 state.rects <- (l.pageno, color, rect) :: state.rects;
5171 ) state.layout;
5172 G.postRedisplay "v";
5174 | @pipe ->
5175 let mode = state.mode in
5176 let cmd = ref E.s in
5177 let onleave = function
5178 | Cancel -> state.mode <- mode
5179 | Confirm ->
5180 List.iter (fun l ->
5181 match getopaque l.pageno with
5182 | Some opaque -> pipesel opaque !cmd
5183 | None -> ()) state.layout;
5184 state.mode <- mode
5186 let ondone s =
5187 cbput state.hists.sel s;
5188 cmd := s
5190 let te =
5191 "| ", !cmd, Some (onhist state.hists.sel), textentry, ondone, true
5193 G.postRedisplay "|";
5194 state.mode <- Textentry (te, onleave);
5196 | _ ->
5197 vlog "huh? %s" (Wsi.keyname key)
5200 let linknavkeyboard key mask linknav =
5201 let getpage pageno =
5202 let rec loop = function
5203 | [] -> None
5204 | l :: _ when l.pageno = pageno -> Some l
5205 | _ :: rest -> loop rest
5206 in loop state.layout
5208 let doexact (pageno, n) =
5209 match getopaque pageno, getpage pageno with
5210 | Some opaque, Some l ->
5211 if key = @enter || key = @kpenter
5212 then
5213 let under = getlink opaque n in
5214 G.postRedisplay "link gotounder";
5215 gotounder under;
5216 state.mode <- View;
5217 else
5218 let opt, dir =
5219 match key with
5220 | @home ->
5221 Some (findlink opaque LDfirst), -1
5223 | @jend ->
5224 Some (findlink opaque LDlast), 1
5226 | @left ->
5227 Some (findlink opaque (LDleft n)), -1
5229 | @right ->
5230 Some (findlink opaque (LDright n)), 1
5232 | @up ->
5233 Some (findlink opaque (LDup n)), -1
5235 | @down ->
5236 Some (findlink opaque (LDdown n)), 1
5238 | _ -> None, 0
5240 let pwl l dir =
5241 begin match findpwl l.pageno dir with
5242 | Pwlnotfound -> ()
5243 | Pwl pageno ->
5244 let notfound dir =
5245 state.mode <- LinkNav (Ltgendir dir);
5246 let y, h = getpageyh pageno in
5247 let y =
5248 if dir < 0
5249 then y + h - state.winh
5250 else y
5252 gotoxy state.x y
5254 begin match getopaque pageno, getpage pageno with
5255 | Some opaque, Some _ ->
5256 let link =
5257 let ld = if dir > 0 then LDfirst else LDlast in
5258 findlink opaque ld
5260 begin match link with
5261 | Lfound m ->
5262 showlinktype (getlink opaque m);
5263 state.mode <- LinkNav (Ltexact (pageno, m));
5264 G.postRedisplay "linknav jpage";
5265 | Lnotfound -> notfound dir
5266 end;
5267 | _ -> notfound dir
5268 end;
5269 end;
5271 begin match opt with
5272 | Some Lnotfound -> pwl l dir;
5273 | Some (Lfound m) ->
5274 if m = n
5275 then pwl l dir
5276 else (
5277 let _, y0, _, y1 = getlinkrect opaque m in
5278 if y0 < l.pagey
5279 then gotopage1 l.pageno y0
5280 else (
5281 let d = fstate.fontsize + 1 in
5282 if y1 - l.pagey > l.pagevh - d
5283 then gotopage1 l.pageno (y1 - state.winh + d)
5284 else G.postRedisplay "linknav";
5286 showlinktype (getlink opaque m);
5287 state.mode <- LinkNav (Ltexact (l.pageno, m));
5290 | None -> viewkeyboard key mask
5291 end;
5292 | _ -> viewkeyboard key mask
5294 if key = @insert
5295 then (
5296 state.mode <- View;
5297 G.postRedisplay "leave linknav"
5299 else
5300 match linknav with
5301 | Ltgendir _ | Ltnotready _ -> viewkeyboard key mask
5302 | Ltexact exact -> doexact exact
5305 let keyboard key mask =
5306 if (key = @g && Wsi.withctrl mask) && not (istextentry state.mode)
5307 then wcmd "interrupt"
5308 else state.uioh <- state.uioh#key key mask
5311 let birdseyekeyboard key mask
5312 ((oconf, leftx, pageno, hooverpageno, anchor) as beye) =
5313 let incr =
5314 match conf.columns with
5315 | Csingle _ -> 1
5316 | Cmulti ((c, _, _), _) -> c
5317 | Csplit _ -> failwith "bird's eye split mode"
5319 let pgh layout = List.fold_left
5320 (fun m l -> max l.pageh m) state.winh layout in
5321 match key with
5322 | @l when Wsi.withctrl mask ->
5323 let y, h = getpageyh pageno in
5324 let top = (state.winh - h) / 2 in
5325 gotoxy state.x (max 0 (y - top))
5326 | @enter | @kpenter -> leavebirdseye beye false
5327 | @escape -> leavebirdseye beye true
5328 | @up -> upbirdseye incr beye
5329 | @down -> downbirdseye incr beye
5330 | @left -> upbirdseye 1 beye
5331 | @right -> downbirdseye 1 beye
5333 | @prior ->
5334 begin match state.layout with
5335 | l :: _ ->
5336 if l.pagey != 0
5337 then (
5338 state.mode <- Birdseye (
5339 oconf, leftx, l.pageno, hooverpageno, anchor
5341 gotopage1 l.pageno 0;
5343 else (
5344 let layout = layout state.x (state.y-state.winh)
5345 state.winw
5346 (pgh state.layout) in
5347 match layout with
5348 | [] -> gotoxy state.x (clamp (-state.winh))
5349 | l :: _ ->
5350 state.mode <- Birdseye (
5351 oconf, leftx, l.pageno, hooverpageno, anchor
5353 gotopage1 l.pageno 0
5356 | [] -> gotoxy state.x (clamp (-state.winh))
5357 end;
5359 | @next ->
5360 begin match List.rev state.layout with
5361 | l :: _ ->
5362 let layout = layout state.x
5363 (state.y + (pgh state.layout))
5364 state.winw state.winh in
5365 begin match layout with
5366 | [] ->
5367 let incr = l.pageh - l.pagevh in
5368 if incr = 0
5369 then (
5370 state.mode <-
5371 Birdseye (
5372 oconf, leftx, state.pagecount - 1, hooverpageno, anchor
5374 G.postRedisplay "birdseye pagedown";
5376 else gotoxy state.x (clamp (incr + conf.interpagespace*2));
5378 | l :: _ ->
5379 state.mode <-
5380 Birdseye (oconf, leftx, l.pageno, hooverpageno, anchor);
5381 gotopage1 l.pageno 0;
5384 | [] -> gotoxy state.x (clamp state.winh)
5385 end;
5387 | @home ->
5388 state.mode <- Birdseye (oconf, leftx, 0, hooverpageno, anchor);
5389 gotopage1 0 0
5391 | @jend ->
5392 let pageno = state.pagecount - 1 in
5393 state.mode <- Birdseye (oconf, leftx, pageno, hooverpageno, anchor);
5394 if not (pagevisible state.layout pageno)
5395 then
5396 let h =
5397 match List.rev state.pdims with
5398 | [] -> state.winh
5399 | (_, _, h, _) :: _ -> h
5401 gotoxy
5402 state.x
5403 (max 0 (getpagey pageno - (state.winh - h - conf.interpagespace)))
5404 else G.postRedisplay "birdseye end";
5406 | _ -> viewkeyboard key mask
5409 let drawpage l =
5410 let color =
5411 match state.mode with
5412 | Textentry _ -> scalecolor 0.4
5413 | LinkNav _
5414 | View -> scalecolor 1.0
5415 | Birdseye (_, _, pageno, hooverpageno, _) ->
5416 if l.pageno = hooverpageno
5417 then scalecolor 0.9
5418 else (
5419 if l.pageno = pageno
5420 then (
5421 let c = scalecolor 1.0 in
5422 GlDraw.color c;
5423 GlDraw.line_width 3.0;
5424 let dispx = l.pagedispx in
5425 linerect
5426 (float (dispx-1)) (float (l.pagedispy-1))
5427 (float (dispx+l.pagevw+1))
5428 (float (l.pagedispy+l.pagevh+1))
5430 GlDraw.line_width 1.0;
5433 else scalecolor 0.8
5436 drawtiles l color;
5439 let postdrawpage l linkindexbase =
5440 match getopaque l.pageno with
5441 | Some opaque ->
5442 if tileready l l.pagex l.pagey
5443 then
5444 let x = l.pagedispx - l.pagex
5445 and y = l.pagedispy - l.pagey in
5446 let hlmask =
5447 match conf.columns with
5448 | Csingle _ | Cmulti _ ->
5449 (if conf.hlinks then 1 else 0)
5450 + (if state.glinks
5451 && not (isbirdseye state.mode) then 2 else 0)
5452 | Csplit _ -> 0
5454 let s =
5455 match state.mode with
5456 | Textentry ((_, s, _, _, _, _), _) when state.glinks -> s
5457 | Textentry _
5458 | Birdseye _
5459 | View
5460 | LinkNav _ -> E.s
5462 Hashtbl.find_all state.prects l.pageno |>
5463 List.iter (fun vals -> drawprect opaque x y vals);
5464 let n = postprocess opaque hlmask x y (linkindexbase, s, conf.hfsize) in
5465 if n < 0
5466 then (state.redisplay <- true; 0)
5467 else n
5468 else 0
5469 | _ -> 0
5472 let scrollindicator () =
5473 let sbw, ph, sh = state.uioh#scrollph in
5474 let sbh, pw, sw = state.uioh#scrollpw in
5476 let x0,x1,hx0 =
5477 if conf.leftscroll
5478 then (0, sbw, sbw)
5479 else ((state.winw - sbw), state.winw, 0)
5482 Gl.enable `blend;
5483 GlDraw.color (0.64, 0.64, 0.64) ~alpha:0.7;
5484 filledrect (float x0) 0. (float x1) (float state.winh);
5485 filledrect
5486 (float hx0) (float (state.winh - sbh))
5487 (float (hx0 + state.winw)) (float state.winh)
5489 GlDraw.color (0.0, 0.0, 0.0) ~alpha:0.7;
5491 filledrect (float x0) ph (float x1) (ph +. sh);
5492 let pw = pw +. float hx0 in
5493 filledrect pw (float (state.winh - sbh)) (pw +. sw) (float state.winh);
5494 Gl.disable `blend;
5497 let showsel () =
5498 match state.mstate with
5499 | Mnone | Mscrolly | Mscrollx | Mpan _ | Mzoom _ | Mzoomrect _ ->
5502 | Msel ((x0, y0), (x1, y1)) ->
5503 let identify opaque l px py = Some (opaque, l.pageno, px, py) in
5504 let o0,n0,px0,py0 = onppundermouse identify x0 y0 (~< E.s, -1, 0, 0) in
5505 let _o1,n1,px1,py1 = onppundermouse identify x1 y1 (~< E.s, -1, 0, 0) in
5506 if n0 != -1 && n0 = n1 then seltext o0 (px0, py0, px1, py1);
5509 let showrects = function [] -> () | rects ->
5510 Gl.enable `blend;
5511 GlDraw.color (0.0, 0.0, 1.0) ~alpha:0.5;
5512 GlFunc.blend_func ~src:`src_alpha ~dst:`one_minus_src_alpha;
5513 List.iter
5514 (fun (pageno, c, (x0, y0, x1, y1, x2, y2, x3, y3)) ->
5515 List.iter (fun l ->
5516 if l.pageno = pageno
5517 then (
5518 let dx = float (l.pagedispx - l.pagex) in
5519 let dy = float (l.pagedispy - l.pagey) in
5520 let r, g, b, alpha = c in
5521 GlDraw.color (r, g, b) ~alpha;
5522 filledrect2 (x0+.dx) (y0+.dy)
5523 (x1+.dx) (y1+.dy)
5524 (x3+.dx) (y3+.dy)
5525 (x2+.dx) (y2+.dy);
5527 ) state.layout
5528 ) rects
5530 Gl.disable `blend;
5533 let display () =
5534 begin match conf.columns, state.layout with
5535 | Csingle _, _ :: _ ->
5536 GlDraw.color (scalecolor2 conf.bgcolor);
5537 let y =
5538 List.fold_left (fun y l ->
5539 let x0 = 0 in
5540 let y0 = y in
5541 let x1 = l.pagedispx in
5542 let y1 = (l.pagedispy + l.pagevh) in
5543 filledrect (float x0) (float y0) (float x1) (float y1);
5544 let x0 = x1 + l.pagevw in
5545 let x1 = state.winw in
5546 filledrect1 (float x0) (float y0) (float x1) (float y1);
5547 if y != l.pagedispy
5548 then (
5549 let x0 = 0
5550 and x1 = state.winw in
5551 let y0 = y
5552 and y1 = l.pagedispy in
5553 filledrect1 (float x0) (float y0) (float x1) (float y1);
5555 l.pagedispy + l.pagevh) 0 state.layout
5557 let x0 = 0
5558 and x1 = state.winw in
5559 let y0 = y
5560 and y1 = state.winh in
5561 filledrect1 (float x0) (float y0) (float x1) (float y1)
5562 | (Cmulti _ | Csplit _), _ | Csingle _, [] ->
5563 GlClear.color (scalecolor2 conf.bgcolor);
5564 GlClear.clear [`color];
5565 end;
5566 List.iter drawpage state.layout;
5567 let rects =
5568 match state.mode with
5569 | LinkNav (Ltexact (pageno, linkno)) ->
5570 begin match getopaque pageno with
5571 | Some opaque ->
5572 let x0, y0, x1, y1 = getlinkrect opaque linkno in
5573 let color = (0.0, 0.0, 0.5, 0.5) in
5574 (pageno, color, (
5575 float x0, float y0,
5576 float x1, float y0,
5577 float x1, float y1,
5578 float x0, float y1)
5579 ) :: state.rects
5580 | None -> state.rects
5582 | LinkNav (Ltgendir _) | LinkNav (Ltnotready _)
5583 | Birdseye _
5584 | Textentry _
5585 | View -> state.rects
5587 showrects rects;
5588 let rec postloop linkindexbase = function
5589 | l :: rest ->
5590 let linkindexbase = linkindexbase + postdrawpage l linkindexbase in
5591 postloop linkindexbase rest
5592 | [] -> ()
5594 showsel ();
5595 postloop 0 state.layout;
5596 state.uioh#display;
5597 begin match state.mstate with
5598 | Mzoomrect ((x0, y0), (x1, y1)) ->
5599 Gl.enable `blend;
5600 GlDraw.color (0.3, 0.3, 0.3) ~alpha:0.5;
5601 GlFunc.blend_func ~src:`src_alpha ~dst:`one_minus_src_alpha;
5602 filledrect (float x0) (float y0) (float x1) (float y1);
5603 Gl.disable `blend;
5604 | Msel _
5605 | Mpan _
5606 | Mscrolly | Mscrollx
5607 | Mzoom _
5608 | Mnone -> ()
5609 end;
5610 enttext ();
5611 scrollindicator ();
5612 Wsi.swapb ();
5615 let zoomrect x y x1 y1 =
5616 let x0 = min x x1
5617 and x1 = max x x1
5618 and y0 = min y y1 in
5619 let zoom = (float state.w) /. float (x1 - x0) in
5620 let margin =
5621 let simple () = if state.w < state.winw then state.w / 2 else 0 in
5622 match conf.fitmodel with
5623 | FitWidth | FitProportional -> simple ()
5624 | FitPage ->
5625 match conf.columns with
5626 | Csplit _ ->
5627 onppundermouse (fun _ l _ _ -> Some l.pagedispx) x0 y0 x0
5628 | Cmulti _ | Csingle _ -> simple ()
5630 gotoxy ((state.x + margin) - x0) (state.y + y0);
5631 state.anchor <- getanchor ();
5632 setzoom zoom;
5633 resetmstate ();
5636 let annot inline x y =
5637 match unproject x y with
5638 | Some (opaque, n, ux, uy) ->
5639 let add text =
5640 addannot opaque ux uy text;
5641 wcmd "freepage %s" (~> opaque);
5642 Hashtbl.remove state.pagemap (n, state.gen);
5643 flushtiles ();
5644 gotoxy state.x state.y
5646 if inline
5647 then
5648 let ondone s = add s in
5649 let mode = state.mode in
5650 state.mode <- Textentry (
5651 ("annotation: ", E.s, None, textentry, ondone, true),
5652 fun _ -> state.mode <- mode);
5653 state.text <- E.s;
5654 enttext ();
5655 G.postRedisplay "annot"
5656 else
5657 add @@ getusertext E.s
5658 | _ -> ()
5661 let zoomblock x y =
5662 let g opaque l px py =
5663 match rectofblock opaque px py with
5664 | Some a ->
5665 let x0 = a.(0) -. 20. in
5666 let x1 = a.(1) +. 20. in
5667 let y0 = a.(2) -. 20. in
5668 let zoom = (float state.w) /. (x1 -. x0) in
5669 let pagey = getpagey l.pageno in
5670 let margin = (state.w - l.pagew)/2 in
5671 let nx = -truncate x0 - margin in
5672 gotoxy_and_clear_text nx (pagey + truncate y0);
5673 state.anchor <- getanchor ();
5674 setzoom zoom;
5675 None
5676 | None -> None
5678 match conf.columns with
5679 | Csplit _ ->
5680 impmsg "block zooming does not work properly in split columns mode"
5681 | Cmulti _ | Csingle _ -> onppundermouse g x y ()
5684 let scrollx x =
5685 let winw = state.winw - 1 in
5686 let s = float x /. float winw in
5687 let destx = truncate (float (state.w + winw) *. s) in
5688 gotoxy_and_clear_text (winw - destx) state.y;
5689 state.mstate <- Mscrollx;
5692 let scrolly y =
5693 let s = float y /. float state.winh in
5694 let desty = truncate (float (state.maxy - state.winh) *. s) in
5695 gotoxy_and_clear_text state.x desty;
5696 state.mstate <- Mscrolly;
5699 let viewmulticlick clicks x y mask =
5700 let g opaque l px py =
5701 let mark =
5702 match clicks with
5703 | 2 -> Mark_word
5704 | 3 -> Mark_line
5705 | 4 -> Mark_block
5706 | _ -> Mark_page
5708 if markunder opaque px py mark
5709 then (
5710 Some (fun () ->
5711 let dopipe cmd =
5712 match getopaque l.pageno with
5713 | None -> ()
5714 | Some opaque -> pipesel opaque cmd
5716 state.roam <- (fun () -> dopipe conf.paxcmd);
5717 if not (Wsi.withctrl mask) then dopipe conf.selcmd;
5720 else None
5722 G.postRedisplay "viewmulticlick";
5723 onppundermouse g x y (fun () -> impmsg "nothing to select") ();
5726 let canselect () =
5727 match conf.columns with
5728 | Csplit _ -> false
5729 | Csingle _ | Cmulti _ -> conf.angle mod 360 = 0
5732 let viewmouse button down x y mask =
5733 match button with
5734 | n when (n == 4 || n == 5) && not down ->
5735 if Wsi.withctrl mask
5736 then (
5737 match state.mstate with
5738 | Mzoom (oldn, i) ->
5739 if oldn = n
5740 then (
5741 if i = 2
5742 then
5743 let incr =
5744 match n with
5745 | 5 ->
5746 if conf.zoom +. 0.01 > 0.1 then 0.1 else 0.01
5747 | _ ->
5748 if conf.zoom -. 0.1 < 0.1 then -0.01 else -0.1
5750 let zoom = conf.zoom -. incr in
5751 pivotzoom ~x ~y zoom;
5752 state.mstate <- Mzoom (n, 0);
5753 else
5754 state.mstate <- Mzoom (n, i+1);
5756 else state.mstate <- Mzoom (n, 0)
5758 | Msel _
5759 | Mpan _
5760 | Mscrolly | Mscrollx
5761 | Mzoomrect _
5762 | Mnone -> state.mstate <- Mzoom (n, 0)
5764 else (
5765 match state.autoscroll with
5766 | Some step -> setautoscrollspeed step (n=4)
5767 | None ->
5768 if conf.wheelbypage || conf.presentation
5769 then (
5770 if n = 4
5771 then prevpage ()
5772 else nextpage ()
5774 else
5775 let incr =
5776 if n = 4
5777 then -conf.scrollstep
5778 else conf.scrollstep
5780 let incr = incr * 2 in
5781 let y = clamp incr in
5782 gotoxy_and_clear_text state.x y
5785 | n when (n = 6 || n = 7) && not down && canpan () ->
5786 let x =
5787 panbound (state.x + (if n = 7 then -2 else 2) * conf.hscrollstep) in
5788 gotoxy_and_clear_text x state.y
5790 | 1 when Wsi.withshift mask ->
5791 state.mstate <- Mnone;
5792 if not down
5793 then (
5794 match unproject x y with
5795 | None -> ()
5796 | Some (_, pageno, ux, uy) ->
5797 let cmd = Printf.sprintf
5798 "%s %s %d %d %d"
5799 conf.stcmd state.path pageno ux uy
5801 match spawn cmd [] with
5802 | (exception exn) ->
5803 impmsg "execution of synctex command(%S) failed: %S"
5804 conf.stcmd @@ exntos exn
5805 | _pid -> ()
5808 | 1 when Wsi.withctrl mask ->
5809 if down
5810 then (
5811 Wsi.setcursor Wsi.CURSOR_FLEUR;
5812 state.mstate <- Mpan (x, y)
5814 else
5815 state.mstate <- Mnone
5817 | 3 ->
5818 if down
5819 then (
5820 if Wsi.withshift mask
5821 then (
5822 annot conf.annotinline x y;
5823 G.postRedisplay "addannot"
5825 else
5826 let p = (x, y) in
5827 Wsi.setcursor Wsi.CURSOR_CYCLE;
5828 state.mstate <- Mzoomrect (p, p)
5830 else (
5831 match state.mstate with
5832 | Mzoomrect ((x0, y0), _) ->
5833 if abs (x-x0) > 10 && abs (y - y0) > 10
5834 then zoomrect x0 y0 x y
5835 else (
5836 resetmstate ();
5837 G.postRedisplay "kill accidental zoom rect";
5839 | Msel _
5840 | Mpan _
5841 | Mscrolly | Mscrollx
5842 | Mzoom _
5843 | Mnone ->
5844 resetmstate ()
5847 | 1 when vscrollhit x ->
5848 if down
5849 then
5850 let _, position, sh = state.uioh#scrollph in
5851 if y > truncate position && y < truncate (position +. sh)
5852 then state.mstate <- Mscrolly
5853 else scrolly y
5854 else
5855 state.mstate <- Mnone
5857 | 1 when y > state.winh - hscrollh () ->
5858 if down
5859 then
5860 let _, position, sw = state.uioh#scrollpw in
5861 if x > truncate position && x < truncate (position +. sw)
5862 then state.mstate <- Mscrollx
5863 else scrollx x
5864 else
5865 state.mstate <- Mnone
5867 | 1 when state.bzoom -> if not down then zoomblock x y
5869 | 1 ->
5870 let dest = if down then getunder x y else Unone in
5871 begin match dest with
5872 | Ulinkgoto _
5873 | Ulinkuri _
5874 | Uremote _ | Uremotedest _
5875 | Uunexpected _ | Ulaunch _ | Unamed _ ->
5876 gotounder dest
5878 | Unone when down ->
5879 Wsi.setcursor Wsi.CURSOR_FLEUR;
5880 state.mstate <- Mpan (x, y);
5882 | Uannotation (opaque, slinkindex) -> enterannotmode opaque slinkindex
5884 | Unone | Utext _ ->
5885 if down
5886 then (
5887 if canselect ()
5888 then (
5889 state.mstate <- Msel ((x, y), (x, y));
5890 G.postRedisplay "mouse select";
5893 else (
5894 match state.mstate with
5895 | Mnone -> ()
5897 | Mzoom _ | Mscrollx | Mscrolly ->
5898 state.mstate <- Mnone
5900 | Mzoomrect ((x0, y0), _) ->
5901 zoomrect x0 y0 x y
5903 | Mpan _ ->
5904 Wsi.setcursor Wsi.CURSOR_INHERIT;
5905 state.mstate <- Mnone
5907 | Msel ((x0, y0), (x1, y1)) ->
5908 let rec loop = function
5909 | [] -> ()
5910 | l :: rest ->
5911 let inside =
5912 let a0 = l.pagedispy in
5913 let a1 = a0 + l.pagevh in
5914 let b0 = l.pagedispx in
5915 let b1 = b0 + l.pagevw in
5916 ((y0 >= a0 && y0 <= a1) || (y1 >= a0 && y1 <= a1))
5917 && ((x0 >= b0 && x0 <= b1) || (x1 >= b0 && x1 <= b1))
5919 if inside
5920 then
5921 match getopaque l.pageno with
5922 | Some opaque ->
5923 let dosel cmd () =
5924 match Unix.pipe () with
5925 | (exception exn) ->
5926 impmsg "cannot create sel pipe: %s" @@
5927 exntos exn;
5928 | (r, w) ->
5929 let clo what fd =
5930 Ne.clo fd (fun msg ->
5931 dolog "%s close failed: %s" what msg)
5933 let pid =
5934 try spawn cmd [r, 0; w, -1]
5935 with exn ->
5936 dolog "cannot execute %S: %s"
5937 cmd @@ exntos exn;
5940 if pid > 0
5941 then (
5942 copysel w opaque;
5943 G.postRedisplay "copysel";
5945 else clo "Msel pipe/w" w;
5946 clo "Msel pipe/r" r;
5948 dosel conf.selcmd ();
5949 state.roam <- dosel conf.paxcmd;
5950 | None -> ()
5951 else loop rest
5953 loop state.layout;
5954 resetmstate ();
5958 | _ -> ()
5961 let birdseyemouse button down x y mask
5962 (conf, leftx, _, hooverpageno, anchor) =
5963 match button with
5964 | 1 when down ->
5965 let rec loop = function
5966 | [] -> ()
5967 | l :: rest ->
5968 if y > l.pagedispy && y < l.pagedispy + l.pagevh
5969 && x > l.pagedispx && x < l.pagedispx + l.pagevw
5970 then (
5971 leavebirdseye (conf, leftx, l.pageno, hooverpageno, anchor) false;
5973 else loop rest
5975 loop state.layout
5976 | 3 -> ()
5977 | _ -> viewmouse button down x y mask
5980 let uioh = object
5981 method display = ()
5983 method key key mask =
5984 begin match state.mode with
5985 | Textentry textentry -> textentrykeyboard key mask textentry
5986 | Birdseye birdseye -> birdseyekeyboard key mask birdseye
5987 | View -> viewkeyboard key mask
5988 | LinkNav linknav -> linknavkeyboard key mask linknav
5989 end;
5990 state.uioh
5992 method button button bstate x y mask =
5993 begin match state.mode with
5994 | LinkNav _
5995 | View -> viewmouse button bstate x y mask
5996 | Birdseye beye -> birdseyemouse button bstate x y mask beye
5997 | Textentry _ -> ()
5998 end;
5999 state.uioh
6001 method multiclick clicks x y mask =
6002 begin match state.mode with
6003 | LinkNav _
6004 | View -> viewmulticlick clicks x y mask
6005 | Birdseye _
6006 | Textentry _ -> ()
6007 end;
6008 state.uioh
6010 method motion x y =
6011 begin match state.mode with
6012 | Textentry _ -> ()
6013 | View | Birdseye _ | LinkNav _ ->
6014 match state.mstate with
6015 | Mzoom _ | Mnone -> ()
6017 | Mpan (x0, y0) ->
6018 let dx = x - x0
6019 and dy = y0 - y in
6020 state.mstate <- Mpan (x, y);
6021 let x = if canpan () then panbound (state.x + dx) else state.x in
6022 let y = clamp dy in
6023 gotoxy_and_clear_text x y
6025 | Msel (a, _) ->
6026 state.mstate <- Msel (a, (x, y));
6027 G.postRedisplay "motion select";
6029 | Mscrolly ->
6030 let y = min state.winh (max 0 y) in
6031 scrolly y
6033 | Mscrollx ->
6034 let x = min state.winw (max 0 x) in
6035 scrollx x
6037 | Mzoomrect (p0, _) ->
6038 state.mstate <- Mzoomrect (p0, (x, y));
6039 G.postRedisplay "motion zoomrect";
6040 end;
6041 state.uioh
6043 method pmotion x y =
6044 begin match state.mode with
6045 | Birdseye (conf, leftx, pageno, hooverpageno, anchor) ->
6046 let rec loop = function
6047 | [] ->
6048 if hooverpageno != -1
6049 then (
6050 state.mode <- Birdseye (conf, leftx, pageno, -1, anchor);
6051 G.postRedisplay "pmotion birdseye no hoover";
6053 | l :: rest ->
6054 if y > l.pagedispy && y < l.pagedispy + l.pagevh
6055 && x > l.pagedispx && x < l.pagedispx + l.pagevw
6056 then (
6057 state.mode <- Birdseye (conf, leftx, pageno, l.pageno, anchor);
6058 G.postRedisplay "pmotion birdseye hoover";
6060 else loop rest
6062 loop state.layout
6064 | Textentry _ -> ()
6066 | LinkNav _
6067 | View ->
6068 match state.mstate with
6069 | Mpan _ | Msel _ | Mzoom _ | Mscrolly | Mscrollx | Mzoomrect _ -> ()
6070 | Mnone ->
6071 updateunder x y;
6072 if canselect ()
6073 then
6074 match conf.pax with
6075 | None -> ()
6076 | Some r ->
6077 let past, _, _ = !r in
6078 let now = now () in
6079 let delta = now -. past in
6080 if delta > 0.01
6081 then paxunder x y
6082 else r := (now, x, y)
6083 end;
6084 state.uioh
6086 method infochanged _ = ()
6088 method scrollph =
6089 let maxy = state.maxy - (if conf.maxhfit then state.winh else 0) in
6090 let p, h =
6091 if maxy = 0
6092 then 0.0, float state.winh
6093 else scrollph state.y maxy
6095 vscrollw (), p, h
6097 method scrollpw =
6098 let fwinw = float state.winw in
6099 let sw =
6100 let sw = fwinw /. float state.w in
6101 let sw = fwinw *. sw in
6102 max sw (float conf.scrollh)
6104 let position =
6105 let maxx = state.w + state.winw in
6106 let x = state.winw - state.x in
6107 let percent = float x /. float maxx in
6108 (fwinw -. sw) *. percent
6110 hscrollh (), position, sw
6112 method modehash =
6113 let modename =
6114 match state.mode with
6115 | LinkNav _ -> "links"
6116 | Textentry _ -> "textentry"
6117 | Birdseye _ -> "birdseye"
6118 | View -> "view"
6120 findkeyhash conf modename
6122 method eformsgs = true
6123 method alwaysscrolly = false
6124 end;;
6126 let addrect pageno r g b a x0 y0 x1 y1 =
6127 Hashtbl.add state.prects pageno [|r; g; b; a; x0; y0; x1; y1|];
6130 let ract cmds =
6131 let cl = splitatspace cmds in
6132 let scan s fmt f =
6133 try Scanf.sscanf s fmt f
6134 with exn ->
6135 adderrfmt "remote exec"
6136 "error processing '%S': %s\n" cmds @@ exntos exn
6138 let rectx s pageno (r, g, b, a) x0 y0 x1 y1 =
6139 vlog "%s page %d color (%f %f %f %f) x0,y0,x1,y1 = %f %f %f %f"
6140 s pageno r g b a x0 y0 x1 y1;
6141 onpagerect
6142 pageno
6143 (fun w h ->
6144 let _,w1,h1,_ = getpagedim pageno in
6145 let sw = float w1 /. float w
6146 and sh = float h1 /. float h in
6147 let x0s = x0 *. sw
6148 and x1s = x1 *. sw
6149 and y0s = y0 *. sh
6150 and y1s = y1 *. sh in
6151 let rect = (x0s,y0s,x1s,y0s,x1s,y1s,x0s,y1s) in
6152 let color = (r, g, b, a) in
6153 if conf.verbose then debugrect rect;
6154 state.rects <- (pageno, color, rect) :: state.rects;
6155 G.postRedisplay s;
6158 match cl with
6159 | "reload", "" -> reload ()
6160 | "goto", args ->
6161 scan args "%u %f %f"
6162 (fun pageno x y ->
6163 let cmd, _ = state.geomcmds in
6164 if emptystr cmd
6165 then gotopagexy !wtmode pageno x y
6166 else
6167 let f prevf () =
6168 gotopagexy !wtmode pageno x y;
6169 prevf ()
6171 state.reprf <- f state.reprf
6173 | "goto1", args -> scan args "%u %f" gotopage
6174 | "gotor", args ->
6175 scan args "%S %u"
6176 (fun filename pageno -> gotounder (Uremote (filename, pageno)))
6177 | "gotord", args ->
6178 scan args "%S %S"
6179 (fun filename dest -> gotounder (Uremotedest (filename, dest)))
6180 | "rect", args ->
6181 scan args "%u %u %f %f %f %f"
6182 (fun pageno c x0 y0 x1 y1 ->
6183 let color = (0.0, 0.0, 1.0 /. float c, 0.5) in
6184 rectx "rect" pageno color x0 y0 x1 y1;
6186 | "prect", args ->
6187 scan args "%u %f %f %f %f %f %f %f %f"
6188 (fun pageno r g b alpha x0 y0 x1 y1 ->
6189 addrect pageno r g b alpha x0 y0 x1 y1;
6190 G.postRedisplay "prect"
6192 | "pgoto", args ->
6193 scan args "%u %f %f"
6194 (fun pageno x y ->
6195 let optopaque =
6196 match getopaque pageno with
6197 | Some opaque -> opaque
6198 | None -> ~< E.s
6200 pgoto optopaque pageno x y;
6201 let rec fixx = function
6202 | [] -> ()
6203 | l :: rest ->
6204 if l.pageno = pageno
6205 then gotoxy (state.x - l.pagedispx) state.y
6206 else fixx rest
6208 let layout =
6209 let mult =
6210 match conf.columns with
6211 | Csingle _ | Csplit _ -> 1
6212 | Cmulti ((n, _, _), _) -> n
6214 layout 0 state.y (state.winw * mult) state.winh
6216 fixx layout
6218 | "activatewin", "" -> Wsi.activatewin ()
6219 | "quit", "" -> raise Quit
6220 | "keys", keys ->
6221 begin try
6222 let l = Config.keys_of_string keys in
6223 List.iter (fun (k, m) -> keyboard k m) l
6224 with exn ->
6225 adderrfmt "error processing keys" "`%S': %s\n" cmds @@ exntos exn
6227 | "clearrects", "" ->
6228 Hashtbl.clear state.prects;
6229 G.postRedisplay "clearrects"
6230 | _ ->
6231 adderrfmt "remote command"
6232 "error processing remote command: %S\n" cmds;
6235 let remote =
6236 let scratch = Bytes.create 80 in
6237 let buf = Buffer.create 80 in
6238 fun fd ->
6239 match tempfailureretry (Unix.read fd scratch 0) 80 with
6240 | (exception Unix.Unix_error (Unix.EAGAIN, _, _)) -> None
6241 | 0 ->
6242 Unix.close fd;
6243 if Buffer.length buf > 0
6244 then (
6245 let s = Buffer.contents buf in
6246 Buffer.clear buf;
6247 ract s;
6249 None
6250 | n ->
6251 let rec eat ppos =
6252 let nlpos =
6253 match Bytes.index_from scratch ppos '\n' with
6254 | pos -> if pos >= n then -1 else pos
6255 | (exception Not_found) -> -1
6257 if nlpos >= 0
6258 then (
6259 Buffer.add_subbytes buf scratch ppos (nlpos-ppos);
6260 let s = Buffer.contents buf in
6261 Buffer.clear buf;
6262 ract s;
6263 eat (nlpos+1);
6265 else (
6266 Buffer.add_subbytes buf scratch ppos (n-ppos);
6267 Some fd
6269 in eat 0
6272 let remoteopen path =
6273 try Some (Unix.openfile path [Unix.O_NONBLOCK; Unix.O_RDONLY] 0o0)
6274 with exn ->
6275 adderrfmt "remoteopen" "error opening %S: %s" path @@ exntos exn;
6276 None
6279 let () =
6280 let gcconfig = ref E.s in
6281 let trimcachepath = ref E.s in
6282 let rcmdpath = ref E.s in
6283 let pageno = ref None in
6284 let rootwid = ref 0 in
6285 let openlast = ref false in
6286 let nofc = ref false in
6287 let doreap = ref false in
6288 selfexec := Sys.executable_name;
6289 Arg.parse
6290 (Arg.align
6291 [("-p", Arg.String (fun s -> state.password <- s),
6292 "<password> Set password");
6294 ("-f", Arg.String
6295 (fun s ->
6296 Config.fontpath := s;
6297 selfexec := !selfexec ^ " -f " ^ Filename.quote s;
6299 "<path> Set path to the user interface font");
6301 ("-c", Arg.String
6302 (fun s ->
6303 selfexec := !selfexec ^ " -c " ^ Filename.quote s;
6304 Config.confpath := s),
6305 "<path> Set path to the configuration file");
6307 ("-last", Arg.Set openlast, " Open last document");
6309 ("-page", Arg.Int (fun pageno1 -> pageno := Some (pageno1-1)),
6310 "<page-number> Jump to page");
6312 ("-tcf", Arg.String (fun s -> trimcachepath := s),
6313 "<path> Set path to the trim cache file");
6315 ("-dest", Arg.String (fun s -> state.nameddest <- s),
6316 "<named-destination> Set named destination");
6318 ("-wtmode", Arg.Set wtmode, " Operate in wt mode");
6319 ("-cxack", Arg.Set cxack, " Cut corners");
6321 ("-remote", Arg.String (fun s -> rcmdpath := s),
6322 "<path> Set path to the remote commands source");
6324 ("-origin", Arg.String (fun s -> state.origin <- s),
6325 "<original-path> Set original path");
6327 ("-gc", Arg.Set_string gcconfig,
6328 "<script-path> Collect garbage with the help of a script");
6330 ("-nofc", Arg.Set nofc, " Do not use fontconfig");
6332 ("-v", Arg.Unit (fun () ->
6333 Printf.printf
6334 "%s\nconfiguration path: %s\n"
6335 (version ())
6336 Config.defconfpath
6338 exit 0), " Print version and exit");
6340 ("-embed", Arg.Set_int rootwid,
6341 "<window-id> Embed into window")
6344 (fun s -> state.path <- s)
6345 ("Usage: " ^ Sys.argv.(0) ^ " [options] some.pdf\nOptions:")
6347 if !wtmode
6348 then selfexec := !selfexec ^ " -wtmode";
6350 let histmode = emptystr state.path && not !openlast in
6352 if not (Config.load !openlast)
6353 then dolog "failed to load configuration";
6355 begin match !pageno with
6356 | Some pageno -> state.anchor <- (pageno, 0.0, 0.0)
6357 | None -> ()
6358 end;
6360 if nonemptystr !gcconfig
6361 then (
6362 let (c, s) =
6363 match Unix.socketpair Unix.PF_UNIX Unix.SOCK_STREAM 0 with
6364 | (exception exn) -> error "socketpair for gc failed: %s" @@ exntos exn
6365 | fds -> fds
6367 match spawn !gcconfig [(c, 0); (c, 1); (s, -1)] with
6368 | (exception exn) -> error "failed to execute gc script: %s" @@ exntos exn
6369 | _pid ->
6370 Ne.clo c @@ (fun s -> error "failed to close gc fd %s" s);
6371 Config.gc s;
6372 exit 0
6375 let wsfd, winw, winh = Wsi.init (object (self)
6376 val mutable m_clicks = 0
6377 val mutable m_click_x = 0
6378 val mutable m_click_y = 0
6379 val mutable m_lastclicktime = infinity
6381 method private cleanup =
6382 state.roam <- noroam;
6383 Hashtbl.iter (fun _ opaque -> clearmark opaque) state.pagemap
6384 method expose = G.postRedisplay "expose"
6385 method visible v =
6386 let name =
6387 match v with
6388 | Wsi.Unobscured -> "unobscured"
6389 | Wsi.PartiallyObscured -> "partiallyobscured"
6390 | Wsi.FullyObscured -> "fullyobscured"
6392 vlog "visibility change %s" name
6393 method display = display ()
6394 method map mapped = vlog "mapped %b" mapped
6395 method reshape w h =
6396 self#cleanup;
6397 reshape w h
6398 method mouse b d x y m =
6399 if d && canselect ()
6400 then (
6401 (* http://blogs.msdn.com/b/oldnewthing/archive/2004/10/18/243925.aspx *)
6402 m_click_x <- x;
6403 m_click_y <- y;
6404 if b = 1
6405 then (
6406 let t = now () in
6407 if abs x - m_click_x > 10
6408 || abs y - m_click_y > 10
6409 || abs_float (t -. m_lastclicktime) > 0.3
6410 then m_clicks <- 0;
6411 m_clicks <- m_clicks + 1;
6412 m_lastclicktime <- t;
6413 if m_clicks = 1
6414 then (
6415 self#cleanup;
6416 G.postRedisplay "cleanup";
6417 state.uioh <- state.uioh#button b d x y m;
6419 else state.uioh <- state.uioh#multiclick m_clicks x y m
6421 else (
6422 self#cleanup;
6423 m_clicks <- 0;
6424 m_lastclicktime <- infinity;
6425 state.uioh <- state.uioh#button b d x y m
6428 else (
6429 state.uioh <- state.uioh#button b d x y m
6431 method motion x y =
6432 state.mpos <- (x, y);
6433 state.uioh <- state.uioh#motion x y
6434 method pmotion x y =
6435 state.mpos <- (x, y);
6436 state.uioh <- state.uioh#pmotion x y
6437 method key k m =
6438 let mascm = m land (
6439 Wsi.altmask + Wsi.shiftmask + Wsi.ctrlmask + Wsi.metamask
6440 ) in
6441 let keyboard k m =
6442 let x = state.x and y = state.y in
6443 keyboard k m;
6444 if x != state.x || y != state.y then self#cleanup
6446 match state.keystate with
6447 | KSnone ->
6448 let km = k, mascm in
6449 begin
6450 match
6451 let modehash = state.uioh#modehash in
6452 try Hashtbl.find modehash km
6453 with Not_found ->
6454 try Hashtbl.find (findkeyhash conf "global") km
6455 with Not_found -> KMinsrt (k, m)
6456 with
6457 | KMinsrt (k, m) -> keyboard k m
6458 | KMinsrl l -> List.iter (fun (k, m) -> keyboard k m) l
6459 | KMmulti (l, r) -> state.keystate <- KSinto (l, r)
6461 | KSinto ((k', m') :: [], insrt) when k'=k && m' land mascm = m' ->
6462 List.iter (fun (k, m) -> keyboard k m) insrt;
6463 state.keystate <- KSnone
6464 | KSinto ((k', m') :: keys, insrt) when k'=k && m' land mascm = m' ->
6465 state.keystate <- KSinto (keys, insrt)
6466 | KSinto _ -> state.keystate <- KSnone
6468 method enter x y =
6469 state.mpos <- (x, y);
6470 state.uioh <- state.uioh#pmotion x y
6471 method leave = state.mpos <- (-1, -1)
6472 method winstate wsl = state.winstate <- wsl
6473 method quit = raise Quit
6474 end) !rootwid conf.cwinw conf.cwinh platform in
6476 setbgcol conf.bgcolor;
6477 state.wsfd <- wsfd;
6479 if not (
6480 List.exists GlMisc.check_extension
6481 [ "GL_ARB_texture_rectangle"
6482 ; "GL_EXT_texture_recangle"
6483 ; "GL_NV_texture_rectangle" ]
6485 then (dolog "OpenGL does not suppport rectangular textures"; exit 1);
6487 if (
6488 let r = GlMisc.get_string `renderer in
6489 let p = "Mesa DRI Intel(" in
6490 let l = String.length p in
6491 String.length r > l && String.sub r 0 l = p
6493 then (
6494 defconf.sliceheight <- 1024;
6495 defconf.texcount <- 32;
6496 defconf.usepbo <- true;
6499 let cs, ss =
6500 match Unix.socketpair Unix.PF_UNIX Unix.SOCK_STREAM 0 with
6501 | (exception exn) ->
6502 dolog "socketpair failed: %s" @@ exntos exn;
6503 exit 1
6504 | (r, w) ->
6505 cloexec r;
6506 cloexec w;
6507 r, w
6510 setcheckers conf.checkers;
6512 opengl_has_pbo := GlMisc.check_extension "GL_ARB_pixel_buffer_object";
6514 init cs (
6515 conf.angle, conf.fitmodel, (conf.trimmargins, conf.trimfuzz),
6516 conf.texcount, conf.sliceheight, conf.mustoresize, conf.colorspace,
6517 !Config.fontpath, !trimcachepath,
6518 !opengl_has_pbo,
6519 not !nofc
6521 List.iter GlArray.enable [`texture_coord; `vertex];
6522 state.ss <- ss;
6523 reshape ~firsttime:true winw winh;
6524 state.uioh <- uioh;
6525 if histmode
6526 then (
6527 Wsi.settitle "llpp (history)";
6528 enterhistmode ();
6530 else (
6531 state.text <- "Opening " ^ (mbtoutf8 state.path);
6532 opendoc state.path state.password;
6534 display ();
6535 Wsi.mapwin ();
6536 Wsi.setcursor Wsi.CURSOR_INHERIT;
6537 Sys.set_signal Sys.sighup (Sys.Signal_handle (fun _ -> reload ()));
6539 let rec reap () =
6540 match Unix.waitpid [Unix.WNOHANG] ~-1 with
6541 | (exception (Unix.Unix_error (Unix.ECHILD, _, _))) -> ()
6542 | (exception exn) -> dolog "Unix.waitpid: %s" @@ exntos exn
6543 | 0, _ -> ()
6544 | _pid, _status -> reap ()
6546 Sys.set_signal Sys.sigchld (Sys.Signal_handle (fun _ -> doreap := true));
6548 let optrfd =
6549 ref (
6550 if nonemptystr !rcmdpath
6551 then remoteopen !rcmdpath
6552 else None
6556 let rec loop deadline =
6557 if !doreap
6558 then (
6559 doreap := false;
6560 reap ()
6562 let r = [state.ss; state.wsfd] in
6563 let r =
6564 match !optrfd with
6565 | None -> r
6566 | Some fd -> fd :: r
6568 if state.redisplay
6569 then (
6570 state.redisplay <- false;
6571 display ();
6573 let timeout =
6574 let now = now () in
6575 if deadline > now
6576 then (
6577 if deadline = infinity
6578 then ~-.1.0
6579 else max 0.0 (deadline -. now)
6581 else 0.0
6583 let r, _, _ =
6584 try Unix.select r [] [] timeout
6585 with Unix.Unix_error (Unix.EINTR, _, _) -> [], [], []
6587 begin match r with
6588 | [] ->
6589 state.ghyll None;
6590 let newdeadline =
6591 if state.ghyll == noghyll
6592 then
6593 match state.autoscroll with
6594 | Some step when step != 0 ->
6595 let y = state.y + step in
6596 let fy = if conf.maxhfit then state.winh else 0 in
6597 let y =
6598 if y < 0
6599 then state.maxy - fy
6600 else if y >= state.maxy - fy then 0 else y
6602 if state.mode = View
6603 then gotoxy_and_clear_text state.x y
6604 else gotoxy state.x y;
6605 deadline +. 0.01
6606 | _ -> infinity
6607 else deadline +. 0.01
6609 loop newdeadline
6611 | l ->
6612 let rec checkfds = function
6613 | [] -> ()
6614 | fd :: rest when fd = state.ss ->
6615 let cmd = rcmd state.ss in
6616 act cmd;
6617 checkfds rest
6619 | fd :: rest when fd = state.wsfd ->
6620 Wsi.readresp fd;
6621 checkfds rest
6623 | fd :: rest when Some fd = !optrfd ->
6624 begin match remote fd with
6625 | None -> optrfd := remoteopen !rcmdpath;
6626 | opt -> optrfd := opt
6627 end;
6628 checkfds rest
6630 | _ :: rest ->
6631 dolog "select returned unknown descriptor";
6632 checkfds rest
6634 checkfds l;
6635 let newdeadline =
6636 let deadline1 =
6637 if deadline = infinity
6638 then now () +. 0.01
6639 else deadline
6641 match state.autoscroll with
6642 | Some step when step != 0 -> deadline1
6643 | _ -> if state.ghyll == noghyll then infinity else deadline1
6645 loop newdeadline
6646 end;
6649 loop infinity;
6650 with Quit ->
6651 Config.save leavebirdseye;
6652 if hasunsavedchanges ()
6653 then save ();