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
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
35 external project
: opaque
-> int -> int -> float -> float -> (float * float)
37 external drawtile
: tileparams
-> opaque
-> unit = "ml_drawtile";;
38 external rectofblock
: opaque
-> int -> int -> float array
option
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 =
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
=
59 Gl.enable `texture_2d
;
60 GlFunc.blend_func ~src
:`src_alpha ~dst
:`one_minus_src_alpha
;
61 ignore
(drawstr size x y s
);
63 Gl.disable `texture_2d
;
66 let drawstring1 size x y s
=
70 let drawstring2 size x y fmt
=
71 Printf.kprintf
(drawstring size
(x
+1) (y
+size
+1)) fmt
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
;
84 let debugrect (x0
, y0
, x1
, y1
, x2
, y2
, x3
, y3
) =
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
;
93 let isbirdseye = function
100 let istextentry = function
101 | Textentry _
-> true
107 let wtmode = ref false;;
108 let cxack = ref false;;
110 let pgscale h
= truncate
(float h
*. conf
.pgscale);;
113 if not state
.uioh#alwaysscrolly
&& (conf
.scrollb
land scrollbhv
= 0)
114 || (state
.x
= 0 && state
.w
<= state
.winw
- conf
.scrollbw
)
120 if not state
.uioh#alwaysscrolly
&& (conf
.scrollb
land scrollbvv
= 0)
128 else x
> state
.winw
- vscrollw ()
131 let wadjsb () = -vscrollw ();;
132 let xadjsb () = if conf
.leftscroll
then vscrollw () else 0;;
135 fstate
.fontsize
<- n
;
136 fstate
.wwidth
<- measurestr fstate
.fontsize
"w";
137 fstate
.maxrows
<- (state
.winh
- fstate
.fontsize
- 1) / (fstate
.fontsize
+ 1);
143 else Printf.kprintf ignore fmt
147 if emptystr conf
.pathlauncher
148 then dolog
"%s" state
.path
150 let command = Str.global_replace percentsre state
.path conf
.pathlauncher
in
151 match spawn
command [] with
154 dolog
"failed to execute `%s': %s" command @@ exntos exn
160 let postRedisplay who
=
161 vlog "redisplay for [%S]" who
;
162 state
.redisplay
<- true;
166 let getopaque pageno
=
167 try Some
(Hashtbl.find state
.pagemap
(pageno
, state
.gen
))
168 with Not_found
-> None
171 let pagetranslatepoint l x y
=
172 let dy = y
- l
.pagedispy
in
173 let y = dy + l
.pagey
in
174 let dx = x
- l
.pagedispx
in
175 let x = dx + l
.pagex
in
179 let onppundermouse g
x y d
=
182 begin match getopaque l
.pageno
with
184 let x0 = l
.pagedispx
in
185 let x1 = x0 + l
.pagevw
in
186 let y0 = l
.pagedispy
in
187 let y1 = y0 + l
.pagevh
in
188 if y >= y0 && y <= y1 && x >= x0 && x <= x1
190 let px, py
= pagetranslatepoint l
x y in
191 match g opaque l
px py
with
204 let g opaque l
px py
=
207 match rectofblock opaque
px py
with
208 | Some
[|x0;x1;y0;y1|] ->
209 let ox = xadjsb () |> float in
210 let rect = (x0+.ox, y0, x1+.ox, y0, x1+.ox, y1, x0+.ox, y1) in
211 let color = (0.0, 0.0, 1.0 /. (l
.pageno
mod 3 |> float), 0.5) in
212 state
.rects
<- [l
.pageno
, color, rect];
213 G.postRedisplay "getunder";
216 let under = whatsunder opaque
px py
in
217 if under = Unone
then None
else Some
under
219 onppundermouse g x y Unone
224 match unproject opaque
x y with
225 | Some
(x, y) -> Some
(Some
(opaque
, l
.pageno
, x, y))
228 onppundermouse g x y None
;
232 state
.text
<- Printf.sprintf
"%c%s" c s
;
233 G.postRedisplay "showtext";
237 Format.ksprintf
(fun s
-> showtext '
!' s
) fmt
;
240 let pipesel opaque cmd
=
243 match Unix.pipe
() with
244 | (exception exn
) -> dolog
"pipesel cannot create pipe: %S" @@ exntos exn
;
246 let doclose what fd
=
247 Ne.clo fd
(fun msg
-> dolog
"%s close failed: %s" what msg
)
250 try spawn cmd
[r
, 0; w
, -1]
252 dolog
"cannot execute %S: %s" cmd
@@ exntos exn
;
258 G.postRedisplay "pipesel";
260 else doclose "pipesel pipe/w" w
;
261 doclose "pipesel pipe/r" r
;
265 let g opaque l
px py
=
266 if markunder opaque
px py conf
.paxmark
269 match getopaque l
.pageno
with
271 | Some opaque
-> pipesel opaque conf
.paxcmd
276 G.postRedisplay "paxunder";
277 if conf
.paxmark
= Mark_page
280 match getopaque l
.pageno
with
282 | Some opaque
-> clearmark opaque
) state
.layout
;
283 state
.roam
<- onppundermouse g x y (fun () -> impmsg "whoopsie daisy");
287 match Unix.pipe
() with
288 | (exception exn
) -> impmsg "pipe failed: %s" @@ exntos exn
291 Ne.clo fd
(fun msg
-> impmsg "failed to close %s: %s" cap msg
)
294 try spawn conf
.selcmd
[r
, 0; w
, -1]
296 impmsg "failed to execute %s: %s" conf
.selcmd
@@ exntos exn
;
302 let l = String.length s
in
303 let bytes = Bytes.unsafe_of_string s
in
304 let n = tempfailureretry
(Unix.write w
bytes 0) l in
306 then impmsg "failed to write %d characters to sel pipe, wrote %d"
309 impmsg "failed to write to sel pipe: %s" @@ exntos exn
312 clo "selstring pipe/r" r
;
313 clo "selstring pipe/w" w
;
316 let undertext ?
(nopath
=false) = function
319 | Ulinkgoto
(pageno
, _
) ->
321 then "page " ^ string_of_int
(pageno
+1)
322 else Printf.sprintf
"%s: page %d" state
.path
(pageno
+1)
323 | Utext s
-> "font: " ^ s
324 | Uunexpected s
-> "unexpected: " ^ s
325 | Ulaunch s
-> "launch: " ^ s
326 | Unamed s
-> "named: " ^ s
327 | Uremote
(filename
, pageno
) ->
328 Printf.sprintf
"%s: page %d" filename
(pageno
+1)
329 | Uremotedest
(filename
, destname
) ->
330 Printf.sprintf
"%s: destination %S" filename destname
331 | Uannotation
(opaque
, slinkindex
) ->
332 "annotation: " ^ getannotcontents opaque slinkindex
335 let updateunder x y =
336 match getunder x y with
337 | Unone
-> Wsi.setcursor
Wsi.CURSOR_INHERIT
339 if conf
.underinfo
then showtext 'u'
("ri: " ^ uri
);
340 Wsi.setcursor
Wsi.CURSOR_INFO
341 | Ulinkgoto
(pageno
, _
) ->
343 then showtext 'p'
("age: " ^ string_of_int
(pageno
+1));
344 Wsi.setcursor
Wsi.CURSOR_INFO
346 if conf
.underinfo
then showtext '
f'
("ont: " ^ s
);
347 Wsi.setcursor
Wsi.CURSOR_TEXT
349 if conf
.underinfo
then showtext 'u'
("nexpected: " ^ s
);
350 Wsi.setcursor
Wsi.CURSOR_INHERIT
352 if conf
.underinfo
then showtext '
l'
("aunch: " ^ s
);
353 Wsi.setcursor
Wsi.CURSOR_INHERIT
355 if conf
.underinfo
then showtext '
n'
("amed: " ^ s
);
356 Wsi.setcursor
Wsi.CURSOR_INHERIT
357 | Uremote
(filename
, pageno
) ->
358 if conf
.underinfo
then showtext 'r'
359 (Printf.sprintf
"emote: %s (%d)" filename
(pageno
+1));
360 Wsi.setcursor
Wsi.CURSOR_INFO
361 | Uremotedest
(filename
, destname
) ->
362 if conf
.underinfo
then showtext 'r'
363 (Printf.sprintf
"emote destination: %s (%S)" filename destname
);
364 Wsi.setcursor
Wsi.CURSOR_INFO
366 if conf
.underinfo
then showtext 'a'
"nnotation";
367 Wsi.setcursor
Wsi.CURSOR_INFO
370 let showlinktype under =
371 if conf
.underinfo
&& under != Unone
372 then showtext ' '
@@ undertext under
375 let intentry_with_suffix text key
=
377 if key
>= 32 && key
< 127
383 let text = addchar
text c in
386 | 'k'
| 'm'
| '
g'
| 'K'
| 'M'
| 'G'
->
387 let text = addchar
text @@ asciilower
c in
391 state
.text <- Printf.sprintf
"invalid char (%d, `%c')" key
c;
396 let b = Buffer.create
16 in
397 Buffer.add_string
b "llll";
400 let b = Buffer.to_bytes
b in
401 wcmd state
.ss
b @@ Bytes.length
b
405 let nogeomcmds cmds
=
407 | s
, [] -> emptystr s
411 let layoutN ((columns
, coverA
, coverB
), b) x y sw sh
=
412 let sh = sh - (hscrollh ()) in
413 let wadj = wadjsb () in
414 let rec fold accu
n =
415 if n = Array.length
b
418 let pdimno, dx, vy
, (_
, w
, h
, xoff
) = b.(n) in
421 || n = state
.pagecount
- coverB
422 || (n - coverA
) mod columns
= columns
- 1)
428 let pagey = max
0 (y - vy
) in
429 let pagedispy = if pagey > 0 then 0 else vy
- y in
430 let pagedispx, pagex
=
432 if n = coverA
- 1 || n = state
.pagecount
- coverB
433 then x + (wadj + sw
- w
) / 2
441 let vw = wadj + sw
- pagedispx in
442 let pw = w
- pagex
in
445 let pagevh = min
(h
- pagey) (sh - pagedispy) in
446 if pagevw > 0 && pagevh > 0
457 ; pagedispx = pagedispx
458 ; pagedispy = pagedispy
470 if Array.length
b = 0
472 else List.rev
(fold [] (page_of_y
y))
475 let layoutS (columns
, b) x y sw
sh =
476 let sh = sh - hscrollh () in
477 let wadj = wadjsb () in
478 let rec fold accu n =
479 if n = Array.length
b
482 let pdimno, px, vy
, (_
, pagew
, pageh
, xoff
) = b.(n) in
490 let pagey = max
0 (y - vy
) in
491 let pagedispy = if pagey > 0 then 0 else vy
- y in
492 let pagedispx, pagex
=
506 let pagecolw = pagew
/columns
in
509 then pagedispx + ((wadj + sw
- pagecolw) / 2)
513 let vw = wadj + sw
- pagedispx in
514 let pw = pagew
- pagex
in
517 let pagevw = min
pagevw pagecolw in
518 let pagevh = min
(pageh
- pagey) (sh - pagedispy) in
519 if pagevw > 0 && pagevh > 0
530 ; pagedispx = pagedispx
531 ; pagedispy = pagedispy
532 ; pagecol
= n mod columns
546 let layout x y sw
sh =
547 if nogeomcmds state
.geomcmds
549 match conf
.columns
with
550 | Csingle
b -> layoutN ((1, 0, 0), b) x y sw
sh
551 | Cmulti
c -> layoutN c x y sw
sh
552 | Csplit s
-> layoutS s
x y sw
sh
557 let y = state
.y + incr
in
559 let y = min
y (state
.maxy
- (if conf
.maxhfit
then state
.winh
else 0)) in
564 let tilex = l.pagex
mod conf
.tilew
in
565 let tiley = l.pagey mod conf
.tileh
in
567 let col = l.pagex
/ conf
.tilew
in
568 let row = l.pagey / conf
.tileh
in
570 let xadj = xadjsb () in
571 let rec rowloop row y0 dispy h
=
575 let dh = conf
.tileh
- y0 in
577 let rec colloop col x0 dispx w
=
581 let dw = conf
.tilew
- x0 in
583 let dispx'
= xadj + dispx in
584 f col row dispx' dispy
x0 y0 dw dh;
585 colloop (col+1) 0 (dispx+dw) (w
-dw)
588 colloop col tilex l.pagedispx l.pagevw;
589 rowloop (row+1) 0 (dispy
+dh) (h
-dh)
592 if l.pagevw > 0 && l.pagevh > 0
593 then rowloop row tiley l.pagedispy l.pagevh;
596 let gettileopaque l col row =
598 l.pageno
, state
.gen
, conf
.colorspace
, conf
.angle
, l.pagew
, l.pageh
, col, row
600 try Some
(Hashtbl.find state
.tilemap
key)
601 with Not_found
-> None
604 let puttileopaque l col row gen colorspace angle opaque size elapsed
=
605 let key = l.pageno
, gen
, colorspace
, angle
, l.pagew
, l.pageh
, col, row in
606 Hashtbl.add state
.tilemap
key (opaque
, size
, elapsed
)
609 let filledrect2 x0 y0 x1 y1 x2 y2 x3 y3
=
610 Raw.sets_float state
.vraw ~pos
:0 [| x0; y0; x1; y1; x2
; y2
; x3
; y3
|];
611 GlArray.vertex `two state
.vraw
;
612 GlArray.draw_arrays `triangle_strip ~first
:0 ~count
:4;
615 let filledrect1 x0 y0 x1 y1 = filledrect2 x0 y0 x0 y1 x1 y0 x1 y1;;
617 let filledrect x0 y0 x1 y1 =
618 GlArray.disable `texture_coord
;
619 filledrect1 x0 y0 x1 y1;
620 GlArray.enable `texture_coord
;
623 let linerect x0 y0 x1 y1 =
624 GlArray.disable `texture_coord
;
625 Raw.sets_float state
.vraw ~pos
:0 [| x0; y0; x0; y1; x1; y1; x1; y0 |];
626 GlArray.vertex `two state
.vraw
;
627 GlArray.draw_arrays `line_loop ~first
:0 ~count
:4;
628 GlArray.enable `texture_coord
;
631 let drawtiles l color =
633 let wadj = wadjsb () in
635 let f col row x y tilex tiley w h
=
636 match gettileopaque l col row with
637 | Some
(opaque
, _
, t
) ->
638 let params = x, y, w
, h
, tilex, tiley in
640 then GlTex.env
(`mode `blend
);
641 drawtile
params opaque
;
643 then GlTex.env
(`mode `modulate
);
647 let s = Printf.sprintf
651 let w = measurestr fstate
.fontsize
s in
652 GlDraw.color (0.0, 0.0, 0.0);
653 filledrect (float (x-2))
656 (float (y + fstate
.fontsize
+ 2));
658 drawstring fstate
.fontsize
x (y + fstate
.fontsize
- 1) s;
668 let lw = wadj + state
.winw
- x in
671 let lh = state
.winh
- y in
675 then GlTex.env
(`mode `blend
);
676 begin match state
.checkerstexid
with
678 Gl.enable `texture_2d
;
679 GlTex.bind_texture ~target
:`texture_2d id
;
683 and y1 = float (y+h
) in
685 let tw = float w /. 16.0
686 and th
= float h
/. 16.0 in
687 let tx0 = float tilex /. 16.0
688 and ty0
= float tiley /. 16.0 in
690 and ty1
= ty0
+. th
in
691 Raw.sets_float state
.vraw ~pos
:0
692 [| x0; y0; x0; y1; x1; y0; x1; y1 |];
693 Raw.sets_float state
.traw ~pos
:0
694 [| tx0; ty0
; tx0; ty1
; tx1; ty0
; tx1; ty1
|];
695 GlArray.vertex `two state
.vraw
;
696 GlArray.tex_coord `two state
.traw
;
697 GlArray.draw_arrays `triangle_strip ~first
:0 ~count
:4;
698 Gl.disable `texture_2d
;
701 GlDraw.color (1.0, 1.0, 1.0);
702 filledrect (float x) (float y) (float (x+w)) (float (y+h
));
705 then GlTex.env
(`mode `modulate
);
706 if w > 128 && h
> fstate
.fontsize
+ 10
708 let c = if conf
.invert
then 1.0 else 0.0 in
709 GlDraw.color (c, c, c);
712 then (col*conf
.tilew
, row*conf
.tileh
)
715 drawstring2 fstate
.fontsize
x y "Loading %d [%d,%d]" l.pageno
c r
;
724 let pagevisible layout n = List.exists
(fun l -> l.pageno
= n) layout;;
726 let tilevisible1 l x y =
728 and ax1
= l.pagex
+ l.pagevw
730 and ay1
= l.pagey + l.pagevh in
734 let bx1 = min
(bx0 + conf
.tilew
) l.pagew
735 and by1
= min
(by0
+ conf
.tileh
) l.pageh
in
737 let rx0 = max
ax0 bx0
738 and ry0
= max ay0 by0
739 and rx1
= min ax1
bx1
740 and ry1
= min ay1 by1
in
742 let nonemptyintersection = rx1
> rx0 && ry1
> ry0
in
746 let tilevisible layout n x y =
747 let rec findpageinlayout m
= function
748 | l :: rest
when l.pageno
= n ->
749 tilevisible1 l x y || (
750 match conf
.columns
with
751 | Csplit
(c, _
) when c > m
-> findpageinlayout (m
+1) rest
756 | _
:: rest
-> findpageinlayout 0 rest
759 findpageinlayout 0 layout;
762 let tileready l x y =
763 tilevisible1 l x y &&
764 gettileopaque l (x/conf
.tilew
) (y/conf
.tileh
) != None
767 let tilepage n p
layout =
768 let rec loop = function
772 let f col row _ _ _ _ _ _
=
773 if state
.currently
= Idle
775 match gettileopaque l col row with
778 let x = col*conf
.tilew
779 and y = row*conf
.tileh
in
781 let w = l.pagew
- x in
785 let h = l.pageh
- y in
790 then getpbo
w h conf
.colorspace
793 wcmd "tile %s %d %d %d %d %s"
794 (~
> p
) x y w h (~
> pbo);
797 l, p
, conf
.colorspace
, conf
.angle
,
798 state
.gen
, col, row, conf
.tilew
, conf
.tileh
807 if nogeomcmds state
.geomcmds
811 let preloadlayout x y sw
sh =
812 let y = if y < sh then 0 else y - sh in
813 let x = min
0 (x + sw
) in
821 if state
.currently
!= Idle
826 begin match getopaque l.pageno
with
828 wcmd "page %d %d" l.pageno
l.pagedimno
;
829 state
.currently
<- Loading
(l, state
.gen
);
831 tilepage l.pageno opaque pages
;
836 if nogeomcmds state
.geomcmds
842 if conf
.preload && state
.currently
= Idle
843 then load (preloadlayout state
.x state
.y state
.winw state
.winh
);
846 let layoutready layout =
847 let rec fold all ls
=
850 let seen = ref false in
851 let allvisible = ref true in
852 let foo col row _ _ _ _ _ _
=
854 allvisible := !allvisible &&
855 begin match gettileopaque l col row with
861 fold (!seen && !allvisible) rest
864 let alltilesvisible = fold true layout in
869 let y = bound
y 0 state
.maxy
in
870 let y, layout, proceed
=
871 match conf
.maxwait
with
872 | Some time
when state
.ghyll
== noghyll
->
873 begin match state
.throttle
with
875 let layout = layout state
.x y state
.winw state
.winh
in
876 let ready = layoutready layout in
880 state
.throttle
<- Some
(layout, y, now
());
882 else G.postRedisplay "gotoy showall (None)";
884 | Some
(_
, _
, started
) ->
885 let dt = now
() -. started
in
888 state
.throttle
<- None
;
889 let layout = layout state
.x y state
.winw state
.winh
in
891 G.postRedisplay "maxwait";
898 let layout = layout state
.x y state
.winw state
.winh
in
899 if not
!wtmode || layoutready layout
900 then G.postRedisplay "gotoy ready";
906 state
.layout <- layout;
907 begin match state
.mode
with
910 | Ltexact
(pageno
, linkno
) ->
911 let rec loop = function
913 state
.mode
<- LinkNav
(Ltgendir
0)
914 | l :: _
when l.pageno
= pageno
->
915 begin match getopaque pageno
with
916 | None
-> state
.mode
<- LinkNav
(Ltnotready
(pageno
, 0))
918 let x0, y0, x1, y1 = getlinkrect opaque linkno
in
919 if not
(x0 >= l.pagex
&& x1 <= l.pagex
+ l.pagevw
920 && y0 >= l.pagey && y1 <= l.pagey + l.pagevh)
921 then state
.mode
<- LinkNav
(Ltgendir
0)
923 | _
:: rest
-> loop rest
926 | Ltnotready _
| Ltgendir _
-> ()
932 begin match state
.mode
with
933 | Birdseye
(conf
, leftx
, pageno
, hooverpageno
, anchor
) ->
934 if not
(pagevisible layout pageno
)
936 match state
.layout with
939 state
.mode
<- Birdseye
(
940 conf
, leftx
, l.pageno
, hooverpageno
, anchor
945 | Ltnotready
(_
, dir
)
948 let rec loop = function
951 match getopaque l.pageno
with
952 | None
-> Ltnotready
(l.pageno
, dir
)
957 then LDfirstvisible
(l.pagex
, l.pagey, dir
)
959 if dir
> 0 then LDfirst
else LDlast
965 | Lnotfound
-> loop rest
967 showlinktype (getlink opaque
n);
968 Ltexact
(l.pageno
, n)
972 state
.mode
<- LinkNav
linknav
980 state
.ghyll
<- noghyll
;
983 let mx, my
= state
.mpos
in
988 let conttiling pageno opaque
=
989 tilepage pageno opaque
991 then preloadlayout state
.x state
.y state
.winw state
.winh
995 let gotoy_and_clear_text y =
996 if not conf
.verbose
then state
.text <- E.s;
1000 let getanchory (n, top
, dtop
) =
1001 let y, h = getpageyh
n in
1002 if conf
.presentation
1004 let ips = calcips
h in
1005 y + truncate
(top
*.float h -. dtop
*.float ips) + ips;
1007 y + truncate
(top
*.float h -. dtop
*.float conf
.interpagespace
)
1010 let gotoanchor anchor
=
1011 gotoy (getanchory anchor
);
1015 cbput state
.hists
.nav
(getanchor
());
1019 let anchor = cbgetc state
.hists
.nav dir
in
1023 let gotoghyll1 single
y =
1024 let scroll f n a
b =
1025 (* http://devmaster.net/forums/topic/9796-ease-in-ease-out-algorithm/ *)
1027 let s x = 3.0*.x**2.0 -. 2.0*.x**3.0 in
1029 then s (float f /. float a
)
1032 then 1.0 -. s ((float (f-b) /. float (n-b)))
1038 let ins = float a
*. 0.5
1039 and outs
= float (n-b) *. 0.5 in
1041 ins +. outs
+. float ones
1043 let rec set nab
y sy
=
1044 let (_N
, _A
, _B
), y =
1047 let scl = if y > sy
then 2 else -2 in
1048 let _N, _
, _
= nab
in
1049 (_N,0,_N), y+conf
.scrollstep
*scl
1051 let sum = summa
_N _A _B
in
1052 let dy = float (y - sy
) in
1056 then state
.ghyll
<- noghyll
1059 let s = scroll n _N _A _B
in
1060 let y1 = y1 +. ((s *. dy) /. sum) in
1061 gotoy_and_clear_text (truncate
y1);
1062 state
.ghyll
<- gf (n+1) y1;
1066 | Some
y'
when single
-> set nab
y' state
.y
1067 | Some
y'
-> set (_N/2, 1, 1) y' state
.y
1069 gf 0 (float state
.y)
1072 match conf
.ghyllscroll
with
1073 | Some nab
when not conf
.presentation
->
1074 if state
.ghyll
== noghyll
1075 then set nab
y state
.y
1076 else state
.ghyll
(Some
y)
1078 gotoy_and_clear_text y
1081 let gotoghyll = gotoghyll1 false;;
1083 let gotopage n top
=
1084 let y, h = getpageyh
n in
1085 let y = y + (truncate
(top
*. float h)) in
1089 let gotopage1 n top
=
1090 let y = getpagey
n in
1095 let invalidate s f =
1100 match state
.geomcmds
with
1101 | ps
, [] when emptystr ps
->
1103 state
.geomcmds
<- s, [];
1106 state
.geomcmds
<- ps
, [s, f];
1108 | ps
, (s'
, _
) :: rest
when s'
= s ->
1109 state
.geomcmds
<- ps
, ((s, f) :: rest
);
1112 state
.geomcmds
<- ps
, ((s, f) :: cmds
);
1116 Hashtbl.iter
(fun _ opaque
->
1117 wcmd "freepage %s" (~
> opaque
);
1119 Hashtbl.clear state
.pagemap
;
1123 if not
(Queue.is_empty state
.tilelru
)
1125 Queue.iter
(fun (k
, p
, s) ->
1126 wcmd "freetile %s" (~
> p
);
1127 state
.memused
<- state
.memused
- s;
1128 Hashtbl.remove state
.tilemap k
;
1130 state
.uioh#infochanged Memused
;
1131 Queue.clear state
.tilelru
;
1137 let h = truncate
(float h*.conf
.zoom
) in
1138 let d = conf
.interpagespace
lsl (if conf
.presentation
then 1 else 0) in
1142 let opendoc path password
=
1144 state
.password
<- password
;
1145 state
.gen
<- state
.gen
+ 1;
1146 state
.docinfo
<- [];
1147 state
.outlines
<- [||];
1150 setaalevel conf
.aalevel
;
1152 if emptystr state
.origin
1156 Wsi.settitle
("llpp " ^
(mbtoutf8
(Filename.basename
titlepath)));
1157 wcmd "open %d %d %s\000%s\000" (btod
!wtmode) (btod
!cxack) path password
;
1158 invalidate "reqlayout"
1160 wcmd "reqlayout %d %d %d %s\000"
1161 conf
.angle
(FMTE.to_int conf
.fitmodel
)
1162 (stateh state
.winh
) state
.nameddest
1167 state
.anchor <- getanchor
();
1168 opendoc state
.path state
.password
;
1172 let c = c *. conf
.colorscale
in
1176 let scalecolor2 (r
, g, b) =
1177 (r
*. conf
.colorscale
, g *. conf
.colorscale
, b *. conf
.colorscale
);
1180 let docolumns columns
=
1181 let wadj = wadjsb () in
1184 let a = Array.make state
.pagecount
(-1, -1, -1, (-1, -1, -1, -1)) in
1185 let wadj = wadjsb () in
1186 let rec loop pageno
pdimno pdim
y ph pdims
=
1187 if pageno
= state
.pagecount
1190 let pdimno, ((_
, w, h, xoff
) as pdim
), pdims
=
1192 | ((pageno'
, _
, _
, _
) as pdim
) :: rest
when pageno'
= pageno
->
1193 pdimno+1, pdim
, rest
1197 let x = max
0 (((wadj + state
.winw
- w) / 2) - xoff
) in
1199 (if conf
.presentation
1200 then (if pageno
= 0 then calcips
h else calcips ph
+ calcips
h)
1201 else (if pageno
= 0 then 0 else conf
.interpagespace
)
1204 a.(pageno
) <- (pdimno, x, y, pdim
);
1205 loop (pageno
+1) pdimno pdim
(y + h) h pdims
1207 loop 0 ~
-1 (-1,-1,-1,-1) 0 0 state
.pdims
;
1208 conf
.columns
<- Csingle
a;
1210 | Cmulti
((columns
, coverA
, coverB
), _
) ->
1211 let a = Array.make state
.pagecount
(-1, -1, -1, (-1, -1, -1, -1)) in
1212 let rec loop pageno
pdimno pdim
x y rowh pdims
=
1213 let rec fixrow m
= if m
= pageno
then () else
1214 let (pdimno, x, y, ((_
, _
, h, _
) as pdim
)) = a.(m
) in
1217 let y = y + (rowh
- h) / 2 in
1218 a.(m
) <- (pdimno, x, y, pdim
);
1222 if pageno
= state
.pagecount
1223 then fixrow (((pageno
- 1) / columns
) * columns
)
1225 let pdimno, ((_
, w, h, xoff
) as pdim
), pdims
=
1227 | ((pageno'
, _
, _
, _
) as pdim
) :: rest
when pageno'
= pageno
->
1228 pdimno+1, pdim
, rest
1233 if pageno
= coverA
- 1 || pageno
= state
.pagecount
- coverB
1235 let x = (wadj + state
.winw
- w) / 2 in
1237 if conf
.presentation
then calcips
h else conf
.interpagespace
in
1238 x, y + ips + rowh
, h
1241 if (pageno
- coverA
) mod columns
= 0
1243 let x = max
0 (wadj + state
.winw
- state
.w) / 2 in
1245 if conf
.presentation
1247 let ips = calcips
h in
1248 y + (if pageno
= 0 then 0 else calcips rowh
+ ips)
1250 y + (if pageno
= 0 then 0 else conf
.interpagespace
)
1254 else x, y, max rowh
h
1258 if pageno
> 1 && (pageno
- coverA
) mod columns
= 0
1261 if pageno
= columns
&& conf
.presentation
1263 let ips = calcips rowh
in
1264 for i
= 0 to pred columns
1266 let (pdimno, x, y, pdim
) = a.(i
) in
1267 a.(i
) <- (pdimno, x, y+ips, pdim
)
1273 fixrow (pageno
- columns
);
1278 a.(pageno
) <- (pdimno, x, y, pdim
);
1279 let x = x + w + xoff
*2 + conf
.interpagespace
in
1280 loop (pageno
+1) pdimno pdim
x y rowh' pdims
1282 loop 0 ~
-1 (-1,-1,-1,-1) 0 0 0 state
.pdims
;
1283 conf
.columns
<- Cmulti
((columns
, coverA
, coverB
), a);
1286 let a = Array.make
(state
.pagecount
*c) (-1, -1, -1, (-1, -1, -1, -1)) in
1287 let rec loop pageno
pdimno pdim
y pdims
=
1288 if pageno
= state
.pagecount
1291 let pdimno, ((_
, w, h, _
) as pdim
), pdims
=
1293 | ((pageno'
, _
, _
, _
) as pdim
) :: rest
when pageno'
= pageno
->
1294 pdimno+1, pdim
, rest
1299 let rec loop1 n x y =
1300 if n = c then y else (
1301 a.(pageno
*c + n) <- (pdimno, x, y, pdim
);
1302 loop1 (n+1) (x+cw) (y + h + conf
.interpagespace
)
1305 let y = loop1 0 0 y in
1306 loop (pageno
+1) pdimno pdim
y pdims
1308 loop 0 ~
-1 (-1,-1,-1,-1) 0 state
.pdims
;
1309 conf
.columns
<- Csplit
(c, a);
1313 docolumns conf
.columns
;
1314 state
.maxy
<- calcheight
();
1315 if state
.reprf
== noreprf
1317 match state
.mode
with
1318 | Birdseye
(_
, _
, pageno
, _
, _
) ->
1319 let y, h = getpageyh pageno
in
1320 let top = (state
.winh
- h) / 2 in
1321 gotoy (max
0 (y - top))
1325 let y = getanchory state
.anchor in
1326 let y = min
y (state
.maxy
- state
.winw
- hscrollh ()) in
1331 state
.reprf
<- noreprf
;
1335 let reshape ?
(firsttime
=false) w h =
1336 GlDraw.viewport ~
x:0 ~
y:0 ~
w:w ~
h:h;
1337 if not firsttime
&& nogeomcmds state
.geomcmds
1338 then state
.anchor <- getanchor
();
1341 let w = wadjsb () + (truncate
(float w *. conf
.zoom
)) in
1344 setfontsize fstate
.fontsize
;
1345 GlMat.mode `modelview
;
1346 GlMat.load_identity
();
1348 GlMat.mode `projection
;
1349 GlMat.load_identity
();
1350 GlMat.rotate ~
x:1.0 ~angle
:180.0 ();
1351 GlMat.translate ~
x:~
-.1.0 ~
y:~
-.1.0 ();
1352 GlMat.scale3
(2.0 /. float state
.winw
, 2.0 /. float state
.winh
, 1.0);
1357 else float state
.x /. float state
.w
1359 invalidate "geometry"
1363 then state
.x <- truncate
(relx *. float w);
1365 match conf
.columns
with
1367 | Cmulti
((c, _
, _
), _
) -> (w - (c-1)*conf
.interpagespace
) / c
1368 | Csplit
(c, _
) -> w * c
1370 wcmd "geometry %d %d %d"
1371 w (stateh h) (FMTE.to_int conf
.fitmodel
)
1376 let len = String.length state
.text in
1377 let x0 = xadjsb () in
1380 match state
.mode
with
1381 | Textentry _
| View
| LinkNav _
->
1382 let h, _
, _
= state
.uioh#scrollpw
in
1387 filledrect x (float (state
.winh
- (fstate
.fontsize
+ 4) - hscrollh))
1388 (x+.w) (float (state
.winh
- hscrollh))
1391 let w = float (wadjsb () + state
.winw
- 1) in
1392 if state
.progress
>= 0.0 && state
.progress
< 1.0
1394 GlDraw.color (0.3, 0.3, 0.3);
1395 let w1 = w *. state
.progress
in
1397 GlDraw.color (0.0, 0.0, 0.0);
1398 rect (float x0+.w1) (float x0+.w-.w1)
1401 GlDraw.color (0.0, 0.0, 0.0);
1405 GlDraw.color (1.0, 1.0, 1.0);
1406 drawstring fstate
.fontsize
1407 (if conf
.leftscroll
then x0 + 2 else x0 + if len > 0 then 8 else 2)
1408 (state
.winh
- hscrollh - 5) s;
1411 match state
.mode
with
1412 | Textentry
((prefix
, text, _
, _
, _
, _
), _
) ->
1416 Printf.sprintf
"%s%s_ [%s]" prefix
text state
.text
1418 Printf.sprintf
"%s%s_" prefix
text
1424 | LinkNav _
-> state
.text
1429 if not
(istextentry state
.mode
) && state
.uioh#eformsgs
1431 let s1 = "(press 'e' to review error messasges)" in
1432 if nonemptystr
s then s ^
" " ^
s1 else s1
1442 let len = Queue.length state
.tilelru
in
1444 match state
.throttle
with
1447 then preloadlayout state
.x state
.y state
.winw state
.winh
1449 | Some
(layout, _
, _
) ->
1453 if state
.memused
<= conf
.memlimit
1458 let (k
, p
, s) as lruitem
= Queue.pop state
.tilelru
in
1459 let n, gen
, colorspace
, angle
, pagew
, pageh
, col, row = k
in
1460 let (_
, pw, ph
, _
) = getpagedim
n in
1463 && colorspace
= conf
.colorspace
1464 && angle
= conf
.angle
1468 let x = col*conf
.tilew
1469 and y = row*conf
.tileh
in
1470 tilevisible (Lazy.force_val
layout) n x y
1472 then Queue.push lruitem state
.tilelru
1475 wcmd "freetile %s" (~
> p
);
1476 state
.memused
<- state
.memused
- s;
1477 state
.uioh#infochanged Memused
;
1478 Hashtbl.remove state
.tilemap k
;
1486 let onpagerect pageno
f =
1488 match conf
.columns
with
1489 | Cmulti
(_
, b) -> b
1491 | Csplit
(_
, b) -> b
1493 if pageno
>= 0 && pageno
< Array.length
b
1495 let (_
, _
, _
, (_
, w, h, _
)) = b.(pageno
) in
1499 let gotopagexy1 wtmode pageno
x y =
1500 let _,w1,h1
,leftx
= getpagedim pageno
in
1501 let top = y /. (float h1
) in
1502 let left = x /. (float w1) in
1503 let py, w, h = getpageywh pageno
in
1504 let wh = state
.winh
- hscrollh () in
1505 let x = left *. (float w) in
1506 let x = leftx
+ state
.x + truncate
x in
1507 let wadj = wadjsb () in
1509 if x < 0 || x >= wadj + state
.winw
1513 let pdy = truncate
(top *. float h) in
1514 let y'
= py + pdy in
1515 let dy = y'
- state
.y in
1517 if x != state
.x || not
(dy > 0 && dy < wh)
1519 if conf
.presentation
1521 if abs
(py - y'
) > wh
1528 if state
.x != sx || state
.y != sy
1533 let ww = wadj + state
.winw
in
1535 and qy
= pdy / wh in
1537 and y = py + qy
* wh in
1538 let x = if -x + ww > w1 then -(w1-ww) else x
1539 and y'
= if y + wh > state
.maxy
then state
.maxy
- wh else y in
1541 if conf
.presentation
1543 if abs
(py - y'
) > wh
1553 gotoy_and_clear_text y;
1555 else gotoy_and_clear_text state
.y;
1558 let gotopagexy wtmode pageno
x y =
1559 match state
.mode
with
1560 | Birdseye
_ -> gotopage pageno
0.0
1563 | LinkNav
_ -> gotopagexy1 wtmode pageno
x y
1566 let getpassword () =
1567 let passcmd = getenvwithdef
"LLPP_ASKPASS" conf
.passcmd in
1572 impmsg "error getting password: %s" s;
1573 dolog
"%s" s) passcmd;
1576 let pgoto opaque pageno
x y =
1577 let pdimno = getpdimno pageno
in
1578 let x, y = project opaque pageno
pdimno x y in
1579 gotopagexy false pageno
x y;
1583 (* dolog "%S" cmds; *)
1584 let spl = splitatspace cmds
in
1586 try Scanf.sscanf
s fmt
f
1588 dolog
"error processing '%S': %s" cmds
@@ exntos exn
;
1591 let addoutline outline
=
1592 match state
.currently
with
1593 | Outlining outlines
->
1594 state
.currently
<- Outlining
(outline
:: outlines
)
1595 | Idle
-> state
.currently
<- Outlining
[outline
]
1598 dolog
"invalid outlining state";
1599 logcurrently state
.currently
1603 state
.uioh#infochanged Pdim
;
1606 | "clearrects", "" ->
1607 state
.rects
<- state
.rects1
;
1608 G.postRedisplay "clearrects";
1610 | "continue", args
->
1611 let n = scan args
"%u" (fun n -> n) in
1612 state
.pagecount
<- n;
1613 begin match state
.currently
with
1615 state
.currently
<- Idle
;
1616 state
.outlines
<- Array.of_list
(List.rev
l)
1622 let cur, cmds
= state
.geomcmds
in
1624 then failwith
"umpossible";
1626 begin match List.rev cmds
with
1628 state
.geomcmds
<- E.s, [];
1629 state
.throttle
<- None
;
1633 state
.geomcmds
<- s, List.rev rest
;
1635 if conf
.maxwait
= None
&& not
!wtmode
1636 then G.postRedisplay "continue";
1643 then showtext ' ' args
1646 Buffer.add_string state
.errmsgs args
;
1647 state
.newerrmsgs
<- true;
1648 G.postRedisplay "error message"
1650 | "progress", args
->
1651 let progress, text =
1654 f, String.sub args pos
(String.length args
- pos
))
1657 state
.progress <- progress;
1658 G.postRedisplay "progress"
1660 | "firstmatch", args
->
1661 let pageno, c, x0, y0, x1, y1, x2
, y2
, x3
, y3
=
1662 scan args
"%u %d %f %f %f %f %f %f %f %f"
1663 (fun p
c x0 y0 x1 y1 x2 y2 x3 y3
->
1664 (p
, c, x0, y0, x1, y1, x2
, y2
, x3
, y3
))
1666 let xoff = float (xadjsb ()) in
1670 and x3
= x3
+. xoff in
1671 let y = (getpagey
pageno) + truncate
y0 in
1673 then state
.x <- truncate
(xoff -. x0) + state
.winw
/2;
1676 let color = (0.0, 0.0, 1.0 /. float c, 0.5) in
1677 state
.rects1
<- [pageno, color, (x0, y0, x1, y1, x2
, y2
, x3
, y3
)]
1680 let pageno, c, x0, y0, x1, y1, x2
, y2
, x3
, y3
=
1681 scan args
"%u %d %f %f %f %f %f %f %f %f"
1682 (fun p
c x0 y0 x1 y1 x2 y2 x3 y3
->
1683 (p
, c, x0, y0, x1, y1, x2
, y2
, x3
, y3
))
1685 let xoff = float (xadjsb ()) in
1689 and x3
= x3
+. xoff in
1690 let color = (0.0, 0.0, 1.0 /. float c, 0.5) in
1692 (pageno, color, (x0, y0, x1, y1, x2
, y2
, x3
, y3
)) :: state
.rects1
1695 let pageopaques, t
= scan args
"%s %f" (fun p t
-> p
, t
) in
1696 let pageopaque = ~
< pageopaques in
1697 begin match state
.currently
with
1698 | Loading
(l, gen
) ->
1699 vlog "page %d took %f sec" l.pageno t
;
1700 Hashtbl.replace state
.pagemap
(l.pageno, gen
) pageopaque;
1701 begin match state
.throttle
with
1703 let preloadedpages =
1705 then preloadlayout state
.x state
.y state
.winw state
.winh
1710 List.fold_left
(fun s l -> IntSet.add
l.pageno s)
1711 IntSet.empty
preloadedpages
1714 Hashtbl.fold (fun ((pageno, _) as key) opaque
accu ->
1715 if not
(IntSet.mem
pageno set)
1717 wcmd "freepage %s" (~
> opaque
);
1723 List.iter
(Hashtbl.remove state
.pagemap
) evictedpages;
1726 state
.currently
<- Idle
;
1729 tilepage l.pageno pageopaque state
.layout;
1731 load preloadedpages;
1732 let visible = pagevisible state
.layout l.pageno in
1735 match state
.mode
with
1736 | LinkNav
(Ltnotready
(pageno, dir
)) ->
1737 if pageno = l.pageno
1742 then LDfirstvisible
(l.pagex
, l.pagey, dir
)
1744 if dir
> 0 then LDfirst
else LDlast
1747 findlink
pageopaque ld
1752 showlinktype (getlink
pageopaque n);
1753 state
.mode
<- LinkNav
(Ltexact
(l.pageno, n))
1755 | LinkNav
(Ltgendir
_)
1756 | LinkNav
(Ltexact
_)
1762 if visible && layoutready state
.layout
1764 G.postRedisplay "page";
1768 | Some
(layout, _, _) ->
1769 state
.currently
<- Idle
;
1770 tilepage l.pageno pageopaque layout;
1777 dolog
"Inconsistent loading state";
1778 logcurrently state
.currently
;
1783 let (x, y, opaques
, size
, t
) =
1784 scan args
"%u %u %s %u %f"
1785 (fun x y p size t
-> (x, y, p
, size
, t
))
1787 let opaque = ~
< opaques
in
1788 begin match state
.currently
with
1789 | Tiling
(l, pageopaque, cs
, angle
, gen
, col, row, tilew
, tileh
) ->
1790 vlog "tile %d [%d,%d] took %f sec" l.pageno col row t
;
1793 if tilew
!= conf
.tilew
|| tileh
!= conf
.tileh
1795 wcmd "freetile %s" (~
> opaque);
1796 state
.currently
<- Idle
;
1800 puttileopaque l col row gen cs angle
opaque size t
;
1801 state
.memused
<- state
.memused
+ size
;
1802 state
.uioh#infochanged Memused
;
1804 Queue.push
((l.pageno, gen
, cs
, angle
, l.pagew
, l.pageh
, col, row),
1805 opaque, size
) state
.tilelru
;
1808 match state
.throttle
with
1809 | None
-> state
.layout
1810 | Some
(layout, _, _) -> layout
1813 state
.currently
<- Idle
;
1815 && conf
.colorspace
= cs
1816 && conf
.angle
= angle
1817 && tilevisible layout l.pageno x y
1818 then conttiling l.pageno pageopaque;
1820 begin match state
.throttle
with
1822 preload state
.layout;
1824 && conf
.colorspace
= cs
1825 && conf
.angle
= angle
1826 && tilevisible state
.layout l.pageno x y
1827 && (not
!wtmode || layoutready state
.layout)
1828 then G.postRedisplay "tile nothrottle";
1830 | Some
(layout, y, _) ->
1831 let ready = layoutready layout in
1835 state
.layout <- layout;
1836 state
.throttle
<- None
;
1837 G.postRedisplay "throttle";
1846 dolog
"Inconsistent tiling state";
1847 logcurrently state
.currently
;
1852 let (n, w, h, _) as pdim
=
1853 scan args
"%u %u %u %u" (fun n w h x -> n, w, h, x)
1856 match conf
.fitmodel
with
1858 | FitPage
| FitProportional
->
1859 match conf
.columns
with
1860 | Csplit
_ -> (n, w, h, 0)
1861 | Csingle
_ | Cmulti
_ -> pdim
1863 state
.uioh#infochanged Pdim
;
1864 state
.pdims
<- pdim :: state
.pdims
1867 let (l, n, t
, h, pos
) =
1868 scan args
"%u %u %d %u %n"
1869 (fun l n t
h pos
-> l, n, t
, h, pos
)
1871 let s = String.sub args pos
(String.length args
- pos
) in
1872 addoutline (s, l, Oanchor
(n, float t
/. float h, 0.0))
1875 let (l, len, pos
) = scan args
"%u %u %n" (fun l len pos
-> l, len, pos
) in
1876 let s = String.sub args pos
len in
1877 let pos2 = pos
+ len + 1 in
1878 let uri = String.sub args
pos2 (String.length args
- pos2) in
1879 addoutline (s, l, Ouri
uri)
1882 let (l, pos
) = scan args
"%u %n" (fun l pos
-> l, pos
) in
1883 let s = String.sub args pos
(String.length args
- pos
) in
1884 addoutline (s, l, Onone
)
1888 scan args
"%u %d %d" (fun n l t
-> n, l, t
)
1890 state
.reprf
<- (fun () -> gotopagexy !wtmode n (float l) (float t
))
1893 let pos = nindex args '
\t'
in
1894 if pos >= 0 && String.sub args
0 pos = "Title"
1896 let s = String.sub args
(pos+1) @@ String.length args
- pos - 1 in
1900 state
.docinfo
<- (1, args
) :: state
.docinfo
1903 state
.uioh#infochanged Docinfo
;
1904 state
.docinfo
<- List.rev state
.docinfo
1908 then Wsi.settitle
"Wrong password";
1909 let password = getpassword () in
1910 if emptystr
password
1911 then error
"document is password protected"
1912 else opendoc state
.path
password
1914 error
"unknown cmd `%S'" cmds
1919 let action = function
1920 | HCprev
-> cbget cb ~
-1
1921 | HCnext
-> cbget cb
1
1922 | HCfirst
-> cbget cb ~
-(cb
.rc)
1923 | HClast
-> cbget cb
(cb
.len - 1 - cb
.rc)
1924 and cancel
() = cb
.rc <- rc
1928 let search pattern forward
=
1929 match conf
.columns
with
1930 | Csplit
_ -> impmsg "searching does not work properly in split columns mode"
1933 if nonemptystr pattern
1936 match state
.layout with
1939 l.pageno, (l.pagey + if forward
then 0 else 0*l.pagevh)
1941 wcmd "search %d %d %d %d,%s\000"
1942 (btod conf
.icase
) pn py (btod forward
) pattern
;
1945 let intentry text key =
1947 if key >= 32 && key < 127
1953 let text = addchar
text c in
1957 state
.text <- Printf.sprintf
"invalid char (%d, `%c')" key c;
1965 let l = String.length
s in
1966 let rec loop pos n = if pos = l then n else
1967 let m = Char.code
s.[pos] - (if pos = 0 && l > 1 then 96 else 97) in
1968 loop (pos+1) (n*26 + m)
1971 let rec loop n = function
1974 match getopaque l.pageno with
1975 | None
-> loop n rest
1977 let m = getlinkcount
opaque in
1980 let under = getlink
opaque n in
1983 else loop (n-m) rest
1985 loop n state
.layout;
1989 let linknentry text key =
1990 if key >= 32 && key < 127
1992 let text = addchar
text (Char.chr
key) in
1993 linknact (fun under -> state
.text <- undertext ~nopath
:true under) text;
1996 state
.text <- Printf.sprintf
"invalid char %d" key;
2001 let textentry text key =
2002 if Wsi.isspecialkey
key
2004 else TEcont
(text ^ toutf8
key)
2007 let reqlayout angle fitmodel
=
2008 match state
.throttle
with
2010 if nogeomcmds state
.geomcmds
2011 then state
.anchor <- getanchor
();
2012 conf
.angle
<- angle
mod 360;
2015 match state
.mode
with
2016 | LinkNav
_ -> state
.mode
<- View
2021 conf
.fitmodel
<- fitmodel
;
2022 invalidate "reqlayout"
2024 wcmd "reqlayout %d %d %d"
2025 conf
.angle
(FMTE.to_int conf
.fitmodel
) (stateh state
.winh
)
2030 let settrim trimmargins trimfuzz
=
2031 if nogeomcmds state
.geomcmds
2032 then state
.anchor <- getanchor
();
2033 conf
.trimmargins
<- trimmargins
;
2034 conf
.trimfuzz
<- trimfuzz
;
2035 let x0, y0, x1, y1 = trimfuzz
in
2036 invalidate "settrim"
2038 wcmd "settrim %d %d %d %d %d" (btod conf
.trimmargins
) x0 y0 x1 y1);
2043 match state
.throttle
with
2045 let zoom = max
0.0001 zoom in
2046 if zoom <> conf
.zoom
2048 state
.prevzoom
<- (conf
.zoom, state
.x);
2050 reshape state
.winw state
.winh
;
2051 state
.text <- Printf.sprintf
"zoom is now %-5.2f" (zoom *. 100.0);
2054 | Some
(layout, y, started
) ->
2056 match conf
.maxwait
with
2060 let dt = now
() -. started
in
2068 let setcolumns mode columns coverA coverB
=
2069 state
.prevcolumns
<- Some
(conf
.columns
, conf
.zoom);
2073 then impmsg "split mode doesn't work in bird's eye"
2075 conf
.columns
<- Csplit
(-columns
, E.a);
2083 conf
.columns
<- Csingle
E.a;
2088 conf
.columns
<- Cmulti
((columns
, coverA
, coverB
), E.a);
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
2107 let rec fold best
= function
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
2119 state
.mode
<- Birdseye
(
2120 { conf
with zoom = conf
.zoom }, state
.x, birdseyepageno, -1, getanchor
()
2124 conf
.presentation
<- false;
2125 conf
.interpagespace
<- 10;
2126 conf
.hlinks
<- false;
2127 conf
.fitmodel
<- FitPage
;
2129 conf
.maxwait
<- None
;
2131 match conf
.beyecolumns
with
2134 Cmulti
((c, 0, 0), E.a)
2135 | None
-> Csingle
E.a
2139 state
.text <- Printf.sprintf
"birds eye mode on (zoom %3.1f%%)"
2144 reshape state
.winw state
.winh
;
2147 let leavebirdseye (c, leftx
, pageno, _, anchor) goback
=
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
2159 | Csplit
_ -> failwith
"leaving bird's eye split mode"
2162 match c.columns
with
2163 | Cmulti
(c, _) -> Cmulti
(c, E.a)
2164 | Csingle
_ -> Csingle
E.a
2165 | Csplit
(c, _) -> Csplit
(c, E.a)
2169 state
.text <- Printf.sprintf
"birds eye mode off (zoom %3.1f%%)"
2172 reshape state
.winw state
.winh
;
2173 state
.anchor <- if goback
then anchor else (pageno, 0.0, 1.0);
2177 let togglebirdseye () =
2178 match state
.mode
with
2179 | Birdseye vals
-> leavebirdseye vals
true
2180 | View
-> enterbirdseye ()
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
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
2205 let y, h = getpageyh
pageno in
2206 let dy = (y - state
.y) - (state
.winh
- h - conf
.interpagespace
) in
2208 | l :: _ when l.pageno = pageno ->
2209 if l.pagevh != l.pageh
2210 then gotoy (clamp (l.pageh
- l.pagevh + conf
.interpagespace
))
2211 else G.postRedisplay "downbirdseye"
2212 | _ :: rest
-> loop rest
2218 let optentry mode
_ key =
2219 let btos b = if b then "on" else "off" in
2220 if key >= 32 && key < 127
2222 let c = Char.chr
key in
2226 try conf
.scrollstep
<- int_of_string
s with exc
->
2227 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exc
2229 TEswitch
("scroll step: ", E.s, None
, intentry, ondone, true)
2234 conf
.autoscrollstep
<- boundastep state
.winh
(int_of_string
s);
2235 if state
.autoscroll
<> None
2236 then state
.autoscroll
<- Some conf
.autoscrollstep
2238 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exc
2240 TEswitch
("auto scroll step: ", E.s, None
, intentry, ondone, true)
2245 let n, a, b = multicolumns_of_string
s in
2246 setcolumns mode
n a b;
2248 state
.text <- Printf.sprintf
"bad columns `%s': %s" s @@ exntos exc
2250 TEswitch
("columns: ", E.s, None
, textentry, ondone, true)
2255 let zoom = float (int_of_string
s) /. 100.0 in
2258 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exc
2260 TEswitch
("zoom: ", E.s, None
, intentry, ondone, true)
2265 conf
.thumbw
<- bound
(int_of_string
s) 2 4096;
2267 Printf.sprintf
"thumbnail width is set to %d" conf
.thumbw
;
2268 begin match mode
with
2270 leavebirdseye beye
false;
2277 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exc
2279 TEswitch
("thumbnail width: ", E.s, None
, intentry, ondone, true)
2284 Some
(int_of_string
s)
2287 Printf.sprintf
"bad integer `%s': %s" s @@ exntos exc
;
2290 | Some angle
-> reqlayout angle conf
.fitmodel
2293 TEswitch
("rotation: ", E.s, None
, intentry, ondone, true)
2296 conf
.icase
<- not conf
.icase
;
2297 TEdone
("case insensitive search " ^
(btos conf
.icase
))
2300 conf
.preload <- not conf
.preload;
2302 TEdone
("preload " ^
(btos conf
.preload))
2305 conf
.verbose
<- not conf
.verbose
;
2306 TEdone
("verbose " ^
(btos conf
.verbose
))
2309 conf
.debug
<- not conf
.debug
;
2310 TEdone
("debug " ^
(btos conf
.debug
))
2313 conf
.maxhfit
<- not conf
.maxhfit
;
2314 state
.maxy
<- calcheight
();
2315 TEdone
("maxhfit " ^
(btos conf
.maxhfit
))
2318 conf
.crophack
<- not conf
.crophack
;
2319 TEdone
("crophack " ^
btos conf
.crophack
)
2323 match conf
.maxwait
with
2325 conf
.maxwait
<- Some infinity
;
2326 "always wait for page to complete"
2328 conf
.maxwait
<- None
;
2329 "show placeholder if page is not ready"
2334 conf
.underinfo
<- not conf
.underinfo
;
2335 TEdone
("underinfo " ^
btos conf
.underinfo
)
2338 conf
.savebmarks
<- not conf
.savebmarks
;
2339 TEdone
("persistent bookmarks " ^
btos conf
.savebmarks
)
2345 match state
.layout with
2350 conf
.interpagespace
<- int_of_string
s;
2351 docolumns conf
.columns
;
2352 state
.maxy
<- calcheight
();
2353 let y = getpagey
pageno in
2356 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exc
2358 TEswitch
("vertical margin: ", E.s, None
, intentry, ondone, true)
2362 match conf
.fitmodel
with
2363 | FitProportional
-> FitWidth
2364 | FitWidth
| FitPage
-> FitProportional
2366 reqlayout conf
.angle
fm;
2367 TEdone
("proportional display " ^
btos (fm == FitProportional
))
2370 settrim (not conf
.trimmargins
) conf
.trimfuzz
;
2371 TEdone
("trim margins " ^
btos conf
.trimmargins
)
2374 conf
.invert
<- not conf
.invert
;
2375 TEdone
("invert colors " ^
btos conf
.invert
)
2379 cbput state
.hists
.sel
s;
2382 TEswitch
("selection command: ", E.s, Some
(onhist state
.hists
.sel
),
2383 textentry, ondone, true)
2387 then conf
.pax
<- Some
(ref (0.0, 0, 0))
2388 else conf
.pax
<- None
;
2389 TEdone
("PAX " ^
btos (conf
.pax
!= None
))
2392 state
.text <- Printf.sprintf
"bad option %d `%c'" key c;
2398 class type lvsource
= object
2399 method getitemcount
: int
2400 method getitem
: int -> (string * int)
2401 method hasaction
: int -> bool
2409 method getactive
: int
2410 method getfirst
: int
2412 method getminfo
: (int * int) array
2415 class virtual lvsourcebase
= object
2416 val mutable m_active
= 0
2417 val mutable m_first
= 0
2418 val mutable m_pan
= 0
2419 method getactive
= m_active
2420 method getfirst
= m_first
2421 method getpan
= m_pan
2422 method getminfo
: (int * int) array
= E.a
2425 let textentrykeyboard
2426 key _mask
((c, text, opthist
, onkey
, ondone, cancelonempty
), onleave
) =
2428 let key = Wsi.keypadtodigitkey
key in
2430 state
.mode
<- Textentry
(te
, onleave
);
2432 G.postRedisplay "textentrykeyboard enttext";
2434 let histaction cmd
=
2437 | Some
(action, _) ->
2438 state
.mode
<- Textentry
(
2439 (c, action cmd
, opthist
, onkey
, ondone, cancelonempty
), onleave
2441 G.postRedisplay "textentry histaction"
2445 if emptystr
text && cancelonempty
2448 G.postRedisplay "textentrykeyboard after cancel";
2451 let s = withoutlastutf8
text in
2452 enttext (c, s, opthist
, onkey
, ondone, cancelonempty
)
2454 | @enter
| @kpenter
->
2457 G.postRedisplay "textentrykeyboard after confirm"
2459 | @up
| @kpup
-> histaction HCprev
2460 | @down
| @kpdown
-> histaction HCnext
2461 | @home
| @kphome
-> histaction HCfirst
2462 | @jend
| @kpend
-> histaction HClast
2467 begin match opthist
with
2469 | Some
(_, onhistcancel
) -> onhistcancel
()
2473 G.postRedisplay "textentrykeyboard after cancel2"
2476 enttext (c, E.s, opthist
, onkey
, ondone, cancelonempty
)
2479 | @delete
| @kpdelete
-> ()
2481 | _ when key != 0 && not
(Wsi.isspecialkey
key) ->
2482 begin match onkey
text key with
2486 G.postRedisplay "textentrykeyboard after confirm2";
2489 enttext (c, text, opthist
, onkey
, ondone, cancelonempty
);
2493 G.postRedisplay "textentrykeyboard after cancel3"
2496 state
.mode
<- Textentry
(te
, onleave
);
2497 G.postRedisplay "textentrykeyboard switch";
2501 vlog "unhandled key %s" (Wsi.keyname
key)
2504 let firstof first active
=
2505 if first
> active
|| abs
(first
- active
) > fstate
.maxrows
- 1
2506 then max
0 (active
- (fstate
.maxrows
/2))
2510 let calcfirst first active
=
2513 let rows = active
- first
in
2514 if rows > fstate
.maxrows
then active
- fstate
.maxrows
else first
2518 let scrollph y maxy
=
2519 let sh = float (maxy
+ state
.winh
) /. float state
.winh
in
2520 let sh = float state
.winh
/. sh in
2521 let sh = max
sh (float conf
.scrollh
) in
2523 let percent = float y /. float maxy
in
2524 let position = (float state
.winh
-. sh) *. percent in
2527 if position +. sh > float state
.winh
2528 then float state
.winh
-. sh
2534 let adderrmsg src msg
=
2535 Buffer.add_string state
.errmsgs msg
;
2536 state
.newerrmsgs
<- true;
2540 let adderrfmt src fmt
=
2541 Format.ksprintf
(fun s -> adderrmsg src
s) fmt
;
2544 let coe s = (s :> uioh
);;
2546 class listview ~zebra ~helpmode ~
(source
:lvsource
) ~trusted ~modehash
=
2548 val m_pan
= source#getpan
2549 val m_first
= source#getfirst
2550 val m_active
= source#getactive
2552 val m_prev_uioh
= state
.uioh
2554 method private elemunder
y =
2558 let n = y / (fstate
.fontsize
+1) in
2559 if m_first
+ n < source#getitemcount
2561 if source#hasaction
(m_first
+ n)
2562 then Some
(m_first
+ n)
2569 GlFunc.blend_func ~src
:`src_alpha ~dst
:`one_minus_src_alpha
;
2570 GlDraw.color (0., 0., 0.) ~alpha
:0.85;
2571 filledrect 0. 0. (float state
.winw
) (float state
.winh
);
2572 GlDraw.color (1., 1., 1.);
2573 Gl.enable `texture_2d
;
2574 let fs = fstate
.fontsize
in
2576 let hw = (wadjsb () + xadjsb () + state
.winw
)/3 in
2577 let ww = fstate
.wwidth
in
2578 let tabw = 17.0*.ww in
2579 let itemcount = source#getitemcount
in
2580 let minfo = source#getminfo
in
2583 then float (xadjsb ()), float (state
.winw
- 1)
2584 else 0.0, float (state
.winw
- conf
.scrollbw
- 1)
2586 let xadj = xadjsb () in
2588 if (row - m_first
) > fstate
.maxrows
2591 if row >= 0 && row < itemcount
2593 let (s, level
) = source#getitem
row in
2594 let y = (row - m_first
) * nfs in
2596 (if conf
.leftscroll
then float xadj else 5.0)
2597 +. (float (level
+ m_pan
)) *. ww in
2600 (let c = if row land 1 = 0 then 1.0 else 0.92 in (c,c,c));
2604 Gl.disable `texture_2d
;
2605 let alpha = if source#hasaction
row then 0.9 else 0.3 in
2606 GlDraw.color (1., 1., 1.) ~
alpha;
2607 linerect (x0 +. 1.) (float (y + 1)) (x1) (float (y + fs + 3));
2608 Gl.enable `texture_2d
;
2611 if zebra
&& row land 1 = 1
2615 GlDraw.color (c,c,c);
2616 let drawtabularstring s =
2618 let x'
= truncate
(x0 +. x) in
2619 let pos = nindex
s '
\000'
in
2621 then drawstring1 fs x'
(y+nfs) s
2623 let s1 = String.sub
s 0 pos
2624 and s2
= String.sub
s (pos+1) (String.length
s - pos - 1) in
2629 let s'
= withoutlastutf8
s in
2630 let s = s' ^
"@Uellipsis" in
2631 let w = measurestr
fs s in
2632 if float x'
+. w +. ww < float (hw + x'
)
2637 if float x'
+. ww +. measurestr
fs s1 > float (hw + x'
)
2641 ignore
(drawstring1 fs x'
(y+nfs) s1);
2642 drawstring1 fs (hw + x'
) (y+nfs) s2
2646 let x = if helpmode
&& row > 0 then x +. ww else x in
2647 let tabpos = nindex
s '
\t'
in
2650 let len = String.length
s - tabpos - 1 in
2651 let s1 = String.sub
s 0 tabpos
2652 and s2
= String.sub
s (tabpos + 1) len in
2653 let nx = drawstr x s1 in
2655 let x = x +. (max
tabw sw) in
2658 let len = String.length
s - 2 in
2659 if len > 0 && s.[0] = '
\xc2'
&& s.[1] = '
\xb7'
2661 let s = String.sub
s 2 len in
2662 let x = if not helpmode
then x +. ww else x in
2663 GlDraw.color (1.2, 1.2, 1.2);
2664 let vinc = drawstring1 (fs+fs/4)
2665 (truncate
(x -. ww)) (y+nfs) s in
2666 GlDraw.color (1., 1., 1.);
2667 vinc +. (float fs *. 0.8)
2673 ignore
(drawtabularstring s);
2679 GlDraw.color (1.0, 1.0, 1.0) ~
alpha:0.5;
2680 let xadj = float (xadjsb () + 5) in
2682 if (row - m_first
) > fstate
.maxrows
2685 if row >= 0 && row < itemcount
2687 let (s, level
) = source#getitem
row in
2688 let pos0 = nindex
s '
\000'
in
2689 let y = (row - m_first
) * nfs in
2690 let x = float (level
+ m_pan
) *. ww in
2691 let (first
, last
) = minfo.(row) in
2693 if pos0 > 0 && first
> pos0
2694 then String.sub
s (pos0+1) (first
-pos0-1)
2695 else String.sub
s 0 first
2697 let suffix = String.sub
s first
(last
- first
) in
2698 let w1 = measurestr fstate
.fontsize
prefix in
2699 let w2 = measurestr fstate
.fontsize
suffix in
2700 let x = x +. if conf
.leftscroll
then xadj else 5.0 in
2701 let x = if pos0 > 0 && first
> pos0 then x +. float hw else x in
2703 and y0 = float (y+2) in
2705 and y1 = float (y+fs+3) in
2706 filledrect x0 y0 x1 y1;
2711 Gl.disable `texture_2d
;
2712 if Array.length
minfo > 0 then loop m_first
;
2715 method updownlevel incr
=
2716 let len = source#getitemcount
in
2718 if m_active
>= 0 && m_active
< len
2719 then snd
(source#getitem m_active
)
2723 if i
= len then i
-1 else if i
= -1 then 0 else
2724 let _, l = source#getitem i
in
2725 if l != curlevel then i
else flow (i
+incr
)
2727 let active = flow m_active
in
2728 let first = calcfirst m_first
active in
2729 G.postRedisplay "outline updownlevel";
2730 {< m_active
= active; m_first
= first >}
2732 method private key1
key mask
=
2733 let set1 active first qsearch
=
2734 coe {< m_active
= active; m_first
= first; m_qsearch
= qsearch
>}
2736 let search active pattern incr
=
2737 let active = if active = -1 then m_first
else active in
2740 if n >= 0 && n < source#getitemcount
2742 let s, _ = source#getitem
n in
2743 match Str.search_forward re
s 0 with
2744 | (exception Not_found
) -> loop (n + incr
)
2751 let qpat = Str.quote pattern
in
2752 match Str.regexp_case_fold
qpat with
2755 adderrfmt "listview key1" "regexp_case_fold for `%S' failed: %S\n"
2756 qpat @@ Printexc.to_string exn
;
2759 let itemcount = source#getitemcount
in
2760 let find start incr
=
2762 if i
= -1 || i
= itemcount
2765 if source#hasaction i
2767 else find (i
+ incr
)
2772 let set active first =
2773 let first = bound
first 0 (itemcount - fstate
.maxrows
) in
2775 coe {< m_active
= active; m_first
= first; m_qsearch
= E.s >}
2778 let isvisible first n = n >= first && n - first <= fstate
.maxrows
in
2780 let incr1 = if incr
> 0 then 1 else -1 in
2781 if isvisible m_first m_active
2784 let next = m_active
+ incr
in
2786 if next < 0 || next >= itemcount
2788 else find next incr1
2790 if abs
(m_active
- next) > fstate
.maxrows
2796 let first = m_first
+ incr
in
2797 let first = bound
first 0 (itemcount - fstate
.maxrows
) in
2799 let next = m_active
+ incr
in
2800 let next = bound
next 0 (itemcount - 1) in
2807 if isvisible first next
2814 let first = min
next m_first
in
2816 if abs
(next - first) > fstate
.maxrows
2822 let first = m_first
+ incr
in
2823 let first = bound
first 0 (itemcount - 1) in
2825 let next = m_active
+ incr
in
2826 let next = bound
next 0 (itemcount - 1) in
2827 let next = find next incr1 in
2829 if next = -1 || abs
(m_active
- first) > fstate
.maxrows
2831 let active = if m_active
= -1 then next else m_active
in
2836 if isvisible first active
2842 G.postRedisplay "listview navigate";
2846 | (@r
|@s) when Wsi.withctrl mask
->
2847 let incr = if key = @r
then -1 else 1 in
2849 match search (m_active
+ incr) m_qsearch
incr with
2851 state
.text <- m_qsearch ^
" [not found]";
2854 state
.text <- m_qsearch
;
2855 active, firstof m_first
active
2857 G.postRedisplay "listview ctrl-r/s";
2858 set1 active first m_qsearch
;
2860 | @insert
when Wsi.withctrl mask
->
2861 if m_active
>= 0 && m_active
< source#getitemcount
2863 let s, _ = source#getitem m_active
in
2869 if emptystr m_qsearch
2872 let qsearch = withoutlastutf8 m_qsearch
in
2876 G.postRedisplay "listview empty qsearch";
2877 set1 m_active m_first
E.s;
2881 match search m_active
qsearch ~
-1 with
2883 state
.text <- qsearch ^
" [not found]";
2886 state
.text <- qsearch;
2887 active, firstof m_first
active
2889 G.postRedisplay "listview backspace qsearch";
2890 set1 active first qsearch
2893 | key when (key != 0 && not
(Wsi.isspecialkey
key)) ->
2894 let pattern = m_qsearch ^ toutf8
key in
2896 match search m_active
pattern 1 with
2898 state
.text <- pattern ^
" [not found]";
2901 state
.text <- pattern;
2902 active, firstof m_first
active
2904 G.postRedisplay "listview qsearch add";
2905 set1 active first pattern;
2909 if emptystr m_qsearch
2911 G.postRedisplay "list view escape";
2912 let mx, my
= state
.mpos
in
2916 source#exit ~uioh
:(coe self
)
2917 ~cancel
:true ~
active:m_active ~
first:m_first ~pan
:m_pan
2919 | None
-> m_prev_uioh
2924 G.postRedisplay "list view kill qsearch";
2925 coe {< m_qsearch
= E.s >}
2928 | @enter
| @kpenter
->
2930 let self = {< m_qsearch
= E.s >} in
2932 G.postRedisplay "listview enter";
2933 if m_active
>= 0 && m_active
< source#getitemcount
2935 source#exit ~uioh
:(coe self) ~cancel
:false
2936 ~
active:m_active ~
first:m_first ~pan
:m_pan
;
2939 source#exit ~uioh
:(coe self) ~cancel
:true
2940 ~
active:m_active ~
first:m_first ~pan
:m_pan
;
2943 begin match opt with
2944 | None
-> m_prev_uioh
2948 | @delete
| @kpdelete
->
2951 | @up
| @kpup
-> navigate ~
-1
2952 | @down
| @kpdown
-> navigate 1
2953 | @prior
| @kpprior
-> navigate ~
-(fstate
.maxrows
)
2954 | @next | @kpnext
-> navigate fstate
.maxrows
2956 | @right
| @kpright
->
2958 G.postRedisplay "listview right";
2959 coe {< m_pan
= m_pan
- 1 >}
2961 | @left | @kpleft
->
2963 G.postRedisplay "listview left";
2964 coe {< m_pan
= m_pan
+ 1 >}
2966 | @home
| @kphome
->
2967 let active = find 0 1 in
2968 G.postRedisplay "listview home";
2972 let first = max
0 (itemcount - fstate
.maxrows
) in
2973 let active = find (itemcount - 1) ~
-1 in
2974 G.postRedisplay "listview end";
2977 | key when (key = 0 || Wsi.isspecialkey
key) ->
2981 dolog
"listview unknown key %#x" key; coe self
2983 method key key mask
=
2984 match state
.mode
with
2985 | Textentry te
-> textentrykeyboard key mask te
; coe self
2988 | LinkNav
_ -> self#key1
key mask
2990 method button button down
x y _ =
2993 | 1 when vscrollhit x ->
2994 G.postRedisplay "listview scroll";
2997 let _, position, sh = self#
scrollph in
2998 if y > truncate
position && y < truncate
(position +. sh)
3000 state
.mstate
<- Mscrolly
;
3004 let s = float (max
0 (y - conf
.scrollh
)) /. float state
.winh
in
3005 let first = truncate
(s *. float source#getitemcount
) in
3006 let first = min source#getitemcount
first in
3007 Some
(coe {< m_first
= first; m_active
= first >})
3009 state
.mstate
<- Mnone
;
3013 begin match self#elemunder
y with
3015 G.postRedisplay "listview click";
3016 source#exit ~uioh
:(coe {< m_active
= n >})
3017 ~cancel
:false ~
active:n ~
first:m_first ~pan
:m_pan
3021 | n when (n == 4 || n == 5) && not down
->
3022 let len = source#getitemcount
in
3024 if n = 5 && m_first
+ fstate
.maxrows
>= len
3028 let first = m_first
+ (if n == 4 then -1 else 1) in
3029 bound
first 0 (len - 1)
3031 G.postRedisplay "listview wheel";
3032 Some
(coe {< m_first
= first >})
3033 | n when (n = 6 || n = 7) && not down
->
3034 let inc = if n = 7 then -1 else 1 in
3035 G.postRedisplay "listview hwheel";
3036 Some
(coe {< m_pan
= m_pan
+ inc >})
3041 | None
-> m_prev_uioh
3044 method multiclick
_ x y = self#button
1 true x y
3047 match state
.mstate
with
3049 let s = float (max
0 (y - conf
.scrollh
)) /. float state
.winh
in
3050 let first = truncate
(s *. float source#getitemcount
) in
3051 let first = min source#getitemcount
first in
3052 G.postRedisplay "listview motion";
3053 coe {< m_first
= first; m_active
= first >}
3061 method pmotion
x y =
3062 if x < state
.winw
- conf
.scrollbw
3065 match self#elemunder
y with
3066 | None
-> Wsi.setcursor
Wsi.CURSOR_INHERIT
; m_active
3067 | Some
n -> Wsi.setcursor
Wsi.CURSOR_INFO
; n
3071 then (G.postRedisplay "listview pmotion"; {< m_active
= n >})
3076 Wsi.setcursor
Wsi.CURSOR_INHERIT
;
3080 method infochanged
_ = ()
3082 method scrollpw
= (0, 0.0, 0.0)
3084 let nfs = fstate
.fontsize
+ 1 in
3085 let y = m_first
* nfs in
3086 let itemcount = source#getitemcount
in
3087 let maxi = max
0 (itemcount - fstate
.maxrows
) in
3088 let maxy = maxi * nfs in
3089 let p, h = scrollph y maxy in
3092 method modehash
= modehash
3093 method eformsgs
= false
3094 method alwaysscrolly
= true
3097 class outlinelistview ~zebra ~source
=
3098 let settext autonarrow
s =
3101 let ss = source#statestr
in
3105 else "{" ^
ss ^
"} [" ^
s ^
"]"
3106 else state
.text <- s
3112 ~source
:(source
:> lvsource
)
3114 ~modehash
:(findkeyhash conf
"outline")
3117 val m_autonarrow
= false
3119 method! key key mask
=
3121 if emptystr state
.text
3123 else fstate
.maxrows - 2
3125 let calcfirst first active =
3128 let rows = active - first in
3129 if rows > maxrows then active - maxrows else first
3133 let active = m_active
+ incr in
3134 let active = bound
active 0 (source#getitemcount
- 1) in
3135 let first = calcfirst m_first
active in
3136 G.postRedisplay "outline navigate";
3137 coe {< m_active
= active; m_first
= first >}
3139 let navscroll first =
3141 let dist = m_active
- first in
3147 else first + maxrows
3150 G.postRedisplay "outline navscroll";
3151 coe {< m_first
= first; m_active
= active >}
3153 let ctrl = Wsi.withctrl mask
in
3158 then (source#denarrow
; E.s)
3160 let pattern = source#renarrow
in
3161 if nonemptystr m_qsearch
3162 then (source#narrow m_qsearch
; m_qsearch
)
3166 settext (not m_autonarrow
) text;
3167 G.postRedisplay "toggle auto narrowing";
3168 coe {< m_first
= 0; m_active
= 0; m_autonarrow
= not m_autonarrow
>}
3170 | @slash
when emptystr m_qsearch
&& not m_autonarrow
->
3172 G.postRedisplay "toggle auto narrowing";
3173 coe {< m_first
= 0; m_active
= 0; m_autonarrow
= true >}
3176 source#narrow m_qsearch
;
3178 then source#add_narrow_pattern m_qsearch
;
3179 G.postRedisplay "outline ctrl-n";
3180 coe {< m_first
= 0; m_active
= 0 >}
3183 let active = source#calcactive
(getanchor
()) in
3184 let first = firstof m_first
active in
3185 G.postRedisplay "outline ctrl-s";
3186 coe {< m_first
= first; m_active
= active >}
3189 G.postRedisplay "outline ctrl-u";
3190 if m_autonarrow
&& nonemptystr m_qsearch
3192 ignore
(source#renarrow
);
3193 settext m_autonarrow
E.s;
3194 coe {< m_first
= 0; m_active
= 0; m_qsearch
= E.s >}
3197 source#del_narrow_pattern
;
3198 let pattern = source#renarrow
in
3200 if emptystr
pattern then E.s else "Narrowed to " ^
pattern
3202 settext m_autonarrow
text;
3203 coe {< m_first
= 0; m_active
= 0; m_qsearch
= E.s >}
3207 let first = max
0 (m_active
- (fstate
.maxrows / 2)) in
3208 G.postRedisplay "outline ctrl-l";
3209 coe {< m_first
= first >}
3211 | @tab
when m_autonarrow
->
3212 if nonemptystr m_qsearch
3214 G.postRedisplay "outline list view tab";
3215 source#add_narrow_pattern m_qsearch
;
3217 coe {< m_qsearch
= E.s >}
3221 | @escape
when m_autonarrow
->
3222 if nonemptystr m_qsearch
3223 then source#add_narrow_pattern m_qsearch
;
3226 | @enter
| @kpenter
when m_autonarrow
->
3227 if nonemptystr m_qsearch
3228 then source#add_narrow_pattern m_qsearch
;
3231 | key when m_autonarrow
&& (not
(Wsi.isspecialkey
key)) ->
3232 let pattern = m_qsearch ^ toutf8
key in
3233 G.postRedisplay "outlinelistview autonarrow add";
3234 source#narrow
pattern;
3235 settext true pattern;
3236 coe {< m_first
= 0; m_active
= 0; m_qsearch
= pattern >}
3238 | key when m_autonarrow
&& key = @backspace
->
3239 if emptystr m_qsearch
3242 let pattern = withoutlastutf8 m_qsearch
in
3243 G.postRedisplay "outlinelistview autonarrow backspace";
3244 ignore
(source#renarrow
);
3245 source#narrow
pattern;
3246 settext true pattern;
3247 coe {< m_first
= 0; m_active
= 0; m_qsearch
= pattern >}
3249 | @up
| @kpup
when ctrl ->
3250 navscroll (max
0 (m_first
- 1))
3252 | @down
| @kpdown
when ctrl ->
3253 navscroll (min
(source#getitemcount
- 1) (m_first
+ 1))
3255 | @up
| @kpup
-> navigate ~
-1
3256 | @down
| @kpdown
-> navigate 1
3257 | @prior
| @kpprior
-> navigate ~
-(fstate
.maxrows)
3258 | @next | @kpnext
-> navigate fstate
.maxrows
3260 | @right
| @kpright
->
3264 G.postRedisplay "outline ctrl right";
3265 {< m_pan
= m_pan
+ 1 >}
3267 else self#updownlevel
1
3271 | @left | @kpleft
->
3275 G.postRedisplay "outline ctrl left";
3276 {< m_pan
= m_pan
- 1 >}
3278 else self#updownlevel ~
-1
3282 | @home
| @kphome
->
3283 G.postRedisplay "outline home";
3284 coe {< m_first
= 0; m_active
= 0 >}
3287 let active = source#getitemcount
- 1 in
3288 let first = max
0 (active - fstate
.maxrows) in
3289 G.postRedisplay "outline end";
3290 coe {< m_active
= active; m_first
= first >}
3292 | _ -> super#
key key mask
3295 let genhistoutlines () =
3297 |> List.sort
(fun (_, c1
, _, _, _, _) (_, c2
, _, _, _, _) ->
3298 compare c2
.lastvisit c1
.lastvisit
)
3300 (fun ((path
, c, _, _, _, origin
) as hist
) ->
3301 let path = if nonemptystr origin
then origin
else path in
3302 let base = mbtoutf8
@@ Filename.basename
path in
3303 (base ^
"\000" ^
c.title
, 1, Ohistory hist
)
3308 let gotohist (path, c, bookmarks
, x, anchor, origin
) =
3309 Config.save
leavebirdseye;
3310 state
.anchor <- anchor;
3311 state
.bookmarks
<- bookmarks
;
3312 state
.origin
<- origin
;
3315 let x0, y0, x1, y1 = conf
.trimfuzz
in
3316 wcmd "trimset %d %d %d %d %d" (btod conf
.trimmargins
) x0 y0 x1 y1;
3317 reshape ~firsttime
:true state
.winw state
.winh
;
3318 opendoc path origin
;
3322 let makecheckers () =
3323 (* Based on lablGL-1.04/LablGlut/examples/lablGL/checker.ml which had
3325 converted by Issac Trotts. July 25, 2002 *)
3326 let image = GlPix.create `ubyte ~format
:`luminance ~width
:2 ~height
:2 in
3327 Raw.sets_string
(GlPix.to_raw
image) ~
pos:0 "\255\200\200\255";
3328 let id = GlTex.gen_texture
() in
3329 GlTex.bind_texture ~target
:`texture_2d
id;
3330 GlPix.store
(`unpack_alignment
1);
3331 GlTex.image2d
image;
3332 List.iter
(GlTex.parameter ~target
:`texture_2d
)
3333 [ `mag_filter `nearest
; `min_filter `nearest
];
3337 let setcheckers enabled
=
3338 match state
.checkerstexid
with
3340 if enabled
then state
.checkerstexid
<- Some
(makecheckers ())
3342 | Some checkerstexid
->
3345 GlTex.delete_texture checkerstexid
;
3346 state
.checkerstexid
<- None
;
3350 let describe_location () =
3351 let fn = page_of_y state
.y in
3352 let ln = page_of_y
(state
.y + state
.winh
- hscrollh () - 1) in
3353 let maxy = state
.maxy - (if conf
.maxhfit
then state
.winh
else 0) in
3357 else (100. *. (float state
.y /. float maxy))
3361 Printf.sprintf
"page %d of %d [%.2f%%]"
3362 (fn+1) state
.pagecount
percent
3365 "pages %d-%d of %d [%.2f%%]"
3366 (fn+1) (ln+1) state
.pagecount
percent
3369 let setpresentationmode v
=
3370 let n = page_of_y state
.y in
3371 state
.anchor <- (n, 0.0, 1.0);
3372 conf
.presentation
<- v
;
3373 if conf
.fitmodel
= FitPage
3374 then reqlayout conf
.angle conf
.fitmodel
;
3378 let setbgcol (r
, g, b) =
3380 let r = r *. 255.0 |> truncate
3381 and g = g *. 255.0 |> truncate
3382 and b = b *. 255.0 |> truncate
in
3383 r lsl 16 |> (lor) (g lsl 8) |> (lor) b
3385 Wsi.setwinbgcol
col;
3389 let btos b = if b then "@Uradical" else E.s in
3390 let showextended = ref false in
3391 let leave mode
_ = state
.mode
<- mode
in
3394 val mutable m_l
= []
3395 val mutable m_a
= E.a
3396 val mutable m_prev_uioh
= nouioh
3397 val mutable m_prev_mode
= View
3399 inherit lvsourcebase
3401 method reset prev_mode prev_uioh
=
3402 m_a
<- Array.of_list
(List.rev m_l
);
3404 m_prev_mode
<- prev_mode
;
3405 m_prev_uioh
<- prev_uioh
;
3407 method int name get
set =
3409 (name
, `
int get
, 1, Action
(
3412 try set (int_of_string
s)
3414 state
.text <- Printf.sprintf
"bad integer `%s': %s"
3418 let te = name ^
": ", E.s, None
, intentry, ondone, true in
3419 state
.mode
<- Textentry
(te, leave m_prev_mode
);
3423 method int_with_suffix name get
set =
3425 (name
, `intws get
, 1, Action
(
3428 try set (int_of_string_with_suffix
s)
3430 state
.text <- Printf.sprintf
"bad integer `%s': %s"
3435 name ^
": ", E.s, None
, intentry_with_suffix, ondone, true
3437 state
.mode
<- Textentry
(te, leave m_prev_mode
);
3441 method bool ?
(offset
=1) ?
(btos=btos) name get
set =
3443 (name
, `
bool (btos, get
), offset
, Action
(
3450 method color name get
set =
3452 (name
, `
color get
, 1, Action
(
3454 let invalid = (nan
, nan
, nan
) in
3457 try color_of_string
s
3459 state
.text <- Printf.sprintf
"bad color `%s': %s"
3466 let te = name ^
": ", E.s, None
, textentry, ondone, true in
3467 state
.text <- color_to_string
(get
());
3468 state
.mode
<- Textentry
(te, leave m_prev_mode
);
3472 method string name get
set =
3474 (name
, `
string get
, 1, Action
(
3476 let ondone s = set s in
3477 let te = name ^
": ", E.s, None
, textentry, ondone, true in
3478 state
.mode
<- Textentry
(te, leave m_prev_mode
);
3482 method colorspace name get
set =
3484 (name
, `
string get
, 1, Action
(
3488 inherit lvsourcebase
3491 m_active
<- CSTE.to_int conf
.colorspace
;
3494 method getitemcount
=
3495 Array.length
CSTE.names
3498 method exit ~uioh ~cancel ~
active ~
first ~pan
=
3499 ignore
(uioh
, first, pan
);
3500 if not cancel
then set active;
3502 method hasaction
_ = true
3506 let modehash = findkeyhash conf
"info" in
3507 coe (new listview ~zebra
:false ~helpmode
:false
3508 ~
source ~trusted
:true ~
modehash)
3511 method paxmark name get
set =
3513 (name
, `
string get
, 1, Action
(
3517 inherit lvsourcebase
3520 m_active
<- MTE.to_int conf
.paxmark
;
3523 method getitemcount
= Array.length
MTE.names
3524 method getitem
n = (MTE.names
.(n), 0)
3525 method exit ~uioh ~cancel ~
active ~
first ~pan
=
3526 ignore
(uioh
, first, pan
);
3527 if not cancel
then set active;
3529 method hasaction
_ = true
3533 let modehash = findkeyhash conf
"info" in
3534 coe (new listview ~zebra
:false ~helpmode
:false
3535 ~
source ~trusted
:true ~
modehash)
3538 method fitmodel name get
set =
3540 (name
, `
string get
, 1, Action
(
3544 inherit lvsourcebase
3547 m_active
<- FMTE.to_int conf
.fitmodel
;
3550 method getitemcount
= Array.length
FMTE.names
3551 method getitem
n = (FMTE.names
.(n), 0)
3552 method exit ~uioh ~cancel ~
active ~
first ~pan
=
3553 ignore
(uioh
, first, pan
);
3554 if not cancel
then set active;
3556 method hasaction
_ = true
3560 let modehash = findkeyhash conf
"info" in
3561 coe (new listview ~zebra
:false ~helpmode
:false
3562 ~
source ~trusted
:true ~
modehash)
3565 method caption
s offset
=
3566 m_l
<- (s, `empty
, offset
, Noaction
) :: m_l
3568 method caption2
s f offset
=
3569 m_l
<- (s, `
string f, offset
, Noaction
) :: m_l
3571 method getitemcount
= Array.length m_a
3574 let tostr = function
3575 | `
int f -> string_of_int
(f ())
3576 | `intws
f -> string_with_suffix_of_int
(f ())
3578 | `
color f -> color_to_string
(f ())
3579 | `
bool (btos, f) -> btos (f ())
3582 let name, t
, offset
, _ = m_a
.(n) in
3583 ((let s = tostr t
in
3585 then Printf.sprintf
"%s\t%s" name s
3589 method exit ~uioh ~cancel ~
active ~
first ~pan
=
3594 match m_a
.(active) with
3595 | _, _, _, Action
f -> f uioh
3596 | _, _, _, Noaction
-> uioh
3607 method hasaction
n =
3609 | _, _, _, Action
_ -> true
3610 | _, _, _, Noaction
-> false
3612 initializer m_active
<- 1
3615 let rec fillsrc prevmode prevuioh
=
3616 let sep () = src#caption
E.s 0 in
3617 let colorp name get
set =
3619 (fun () -> color_to_string
(get
()))
3622 let c = color_of_string
v in
3625 state
.text <- Printf.sprintf
"bad color `%s': %s" v @@ exntos exn
3628 let oldmode = state
.mode
in
3629 let birdseye = isbirdseye state
.mode
in
3631 src#caption
(if birdseye then "Setup (Bird's eye)" else "Setup") 0;
3633 src#
bool "presentation mode"
3634 (fun () -> conf
.presentation
)
3635 (fun v -> setpresentationmode v);
3637 src#
bool "ignore case in searches"
3638 (fun () -> conf
.icase
)
3639 (fun v -> conf
.icase
<- v);
3642 (fun () -> conf
.preload)
3643 (fun v -> conf
.preload <- v);
3645 src#
bool "highlight links"
3646 (fun () -> conf
.hlinks
)
3647 (fun v -> conf
.hlinks
<- v);
3649 src#
bool "under info"
3650 (fun () -> conf
.underinfo
)
3651 (fun v -> conf
.underinfo
<- v);
3653 src#
bool "persistent bookmarks"
3654 (fun () -> conf
.savebmarks
)
3655 (fun v -> conf
.savebmarks
<- v);
3657 src#fitmodel
"fit model"
3658 (fun () -> FMTE.to_string conf
.fitmodel
)
3659 (fun v -> reqlayout conf
.angle
(FMTE.of_int
v));
3661 src#
bool "trim margins"
3662 (fun () -> conf
.trimmargins
)
3663 (fun v -> settrim v conf
.trimfuzz
; fillsrc prevmode prevuioh
);
3665 src#
bool "persistent location"
3666 (fun () -> conf
.jumpback
)
3667 (fun v -> conf
.jumpback
<- v);
3670 src#
int "inter-page space"
3671 (fun () -> conf
.interpagespace
)
3673 conf
.interpagespace
<- n;
3674 docolumns conf
.columns
;
3676 match state
.layout with
3681 state
.maxy <- calcheight
();
3682 let y = getpagey
pageno in
3687 (fun () -> conf
.pagebias
)
3688 (fun v -> conf
.pagebias
<- v);
3690 src#
int "scroll step"
3691 (fun () -> conf
.scrollstep
)
3692 (fun n -> conf
.scrollstep
<- n);
3694 src#
int "horizontal scroll step"
3695 (fun () -> conf
.hscrollstep
)
3696 (fun v -> conf
.hscrollstep
<- v);
3698 src#
int "auto scroll step"
3700 match state
.autoscroll
with
3702 | _ -> conf
.autoscrollstep
)
3704 let n = boundastep state
.winh
n in
3705 if state
.autoscroll
<> None
3706 then state
.autoscroll
<- Some
n;
3707 conf
.autoscrollstep
<- n);
3710 (fun () -> truncate
(conf
.zoom *. 100.))
3711 (fun v -> setzoom ((float v) /. 100.));
3714 (fun () -> conf
.angle
)
3715 (fun v -> reqlayout v conf
.fitmodel
);
3717 src#
int "scroll bar width"
3718 (fun () -> conf
.scrollbw
)
3721 reshape state
.winw state
.winh
;
3724 src#
int "scroll handle height"
3725 (fun () -> conf
.scrollh
)
3726 (fun v -> conf
.scrollh
<- v;);
3728 src#
int "thumbnail width"
3729 (fun () -> conf
.thumbw
)
3731 conf
.thumbw
<- min
4096 v;
3734 leavebirdseye beye
false;
3741 let mode = state
.mode in
3742 src#
string "columns"
3744 match conf
.columns
with
3746 | Cmulti
(multi
, _) -> multicolumns_to_string multi
3747 | Csplit
(count
, _) -> "-" ^ string_of_int count
3750 let n, a, b = multicolumns_of_string
v in
3751 setcolumns mode n a b);
3754 src#caption
"Pixmap cache" 0;
3755 src#int_with_suffix
"size (advisory)"
3756 (fun () -> conf
.memlimit
)
3757 (fun v -> conf
.memlimit
<- v);
3760 (fun () -> Printf.sprintf
"%s bytes, %d tiles"
3761 (string_with_suffix_of_int state
.memused
)
3762 (Hashtbl.length state
.tilemap
)) 1;
3765 src#caption
"Layout" 0;
3766 src#caption2
"Dimension"
3768 Printf.sprintf
"%dx%d (virtual %dx%d)"
3769 state
.winw state
.winh
3774 src#caption2
"Position" (fun () ->
3775 Printf.sprintf
"%dx%d" state
.x state
.y
3778 src#caption2
"Position" (fun () -> describe_location ()) 1
3782 src#
bool ~offset
:0 ~
btos:(fun v -> if v then "(on)" else "(off)")
3783 "Save these parameters as global defaults at exit"
3784 (fun () -> conf
.bedefault
)
3785 (fun v -> conf
.bedefault
<- v)
3789 let btos b = if b then "@Ulguillemet" else "@Urguillemet" in
3790 src#
bool ~offset
:0 ~
btos "Extended parameters"
3791 (fun () -> !showextended)
3792 (fun v -> showextended := v; fillsrc prevmode prevuioh
);
3796 (fun () -> conf
.checkers
)
3797 (fun v -> conf
.checkers
<- v; setcheckers v);
3798 src#
bool "update cursor"
3799 (fun () -> conf
.updatecurs
)
3800 (fun v -> conf
.updatecurs
<- v);
3801 src#
bool "scroll-bar on the left"
3802 (fun () -> conf
.leftscroll
)
3803 (fun v -> conf
.leftscroll
<- v);
3805 (fun () -> conf
.verbose
)
3806 (fun v -> conf
.verbose
<- v);
3807 src#
bool "invert colors"
3808 (fun () -> conf
.invert
)
3809 (fun v -> conf
.invert
<- v);
3811 (fun () -> conf
.maxhfit
)
3812 (fun v -> conf
.maxhfit
<- v);
3814 (fun () -> conf
.pax
!= None
)
3817 then conf
.pax
<- Some
(ref (now
(), 0, 0))
3818 else conf
.pax
<- None
);
3819 src#
string "uri launcher"
3820 (fun () -> conf
.urilauncher
)
3821 (fun v -> conf
.urilauncher
<- v);
3822 src#
string "path launcher"
3823 (fun () -> conf
.pathlauncher
)
3824 (fun v -> conf
.pathlauncher
<- v);
3825 src#
string "tile size"
3826 (fun () -> Printf.sprintf
"%dx%d" conf
.tilew conf
.tileh
)
3829 let w, h = Scanf.sscanf
v "%dx%d" (fun w h -> w, h) in
3830 conf
.tilew
<- max
64 w;
3831 conf
.tileh
<- max
64 h;
3834 state
.text <- Printf.sprintf
"bad tile size `%s': %s"
3837 src#
int "texture count"
3838 (fun () -> conf
.texcount
)
3841 then conf
.texcount
<- v
3842 else impmsg "failed to set texture count please retry later"
3844 src#
int "slice height"
3845 (fun () -> conf
.sliceheight
)
3847 conf
.sliceheight
<- v;
3848 wcmd "sliceh %d" conf
.sliceheight
;
3850 src#
int "anti-aliasing level"
3851 (fun () -> conf
.aalevel
)
3853 conf
.aalevel
<- bound
v 0 8;
3854 state
.anchor <- getanchor
();
3855 opendoc state
.path state
.password;
3857 src#
string "page scroll scaling factor"
3858 (fun () -> string_of_float conf
.pgscale)
3861 let s = float_of_string
v in
3864 state
.text <- Printf.sprintf
3865 "bad page scroll scaling factor `%s': %s" v @@ exntos exn
3868 src#
int "ui font size"
3869 (fun () -> fstate
.fontsize
)
3870 (fun v -> setfontsize (bound
v 5 100));
3871 src#
int "hint font size"
3872 (fun () -> conf
.hfsize
)
3873 (fun v -> conf
.hfsize
<- bound
v 5 100);
3874 colorp "background color"
3875 (fun () -> conf
.bgcolor
)
3876 (fun v -> conf
.bgcolor
<- v; setbgcol v);
3877 src#
bool "crop hack"
3878 (fun () -> conf
.crophack
)
3879 (fun v -> conf
.crophack
<- v);
3880 src#
string "trim fuzz"
3881 (fun () -> irect_to_string conf
.trimfuzz
)
3884 conf
.trimfuzz
<- irect_of_string
v;
3886 then settrim true conf
.trimfuzz
;
3888 state
.text <- Printf.sprintf
"bad irect `%s': %s" v @@ exntos exn
3890 src#
string "throttle"
3892 match conf
.maxwait
with
3893 | None
-> "show place holder if page is not ready"
3896 then "wait for page to fully render"
3898 "wait " ^ string_of_float
time
3899 ^
" seconds before showing placeholder"
3903 let f = float_of_string
v in
3905 then conf
.maxwait
<- None
3906 else conf
.maxwait
<- Some
f
3908 state
.text <- Printf.sprintf
"bad time `%s': %s" v @@ exntos exn
3910 src#
string "ghyll scroll"
3912 match conf
.ghyllscroll
with
3914 | Some nab
-> ghyllscroll_to_string nab
3917 try conf
.ghyllscroll
<- ghyllscroll_of_string
v
3920 state
.text <- Printf.sprintf
"bad ghyll `%s': %s" v msg
3922 state
.text <- Printf.sprintf
"bad ghyll `%s': %s" v @@ exntos exn
3924 src#
string "selection command"
3925 (fun () -> conf
.selcmd
)
3926 (fun v -> conf
.selcmd
<- v);
3927 src#
string "synctex command"
3928 (fun () -> conf
.stcmd
)
3929 (fun v -> conf
.stcmd
<- v);
3930 src#
string "pax command"
3931 (fun () -> conf
.paxcmd
)
3932 (fun v -> conf
.paxcmd
<- v);
3933 src#
string "ask password command"
3934 (fun () -> conf
.passcmd)
3935 (fun v -> conf
.passcmd <- v);
3936 src#
string "save path command"
3937 (fun () -> conf
.savecmd
)
3938 (fun v -> conf
.savecmd
<- v);
3939 src#colorspace
"color space"
3940 (fun () -> CSTE.to_string conf
.colorspace
)
3942 conf
.colorspace
<- CSTE.of_int
v;
3946 src#paxmark
"pax mark method"
3947 (fun () -> MTE.to_string conf
.paxmark
)
3948 (fun v -> conf
.paxmark
<- MTE.of_int
v);
3949 if bousable
() && !opengl_has_pbo
3952 (fun () -> conf
.usepbo
)
3953 (fun v -> conf
.usepbo
<- v);
3954 src#
bool "mouse wheel scrolls pages"
3955 (fun () -> conf
.wheelbypage
)
3956 (fun v -> conf
.wheelbypage
<- v);
3957 src#
bool "open remote links in a new instance"
3958 (fun () -> conf
.riani
)
3959 (fun v -> conf
.riani
<- v);
3960 src#
bool "edit annotations inline"
3961 (fun () -> conf
.annotinline
)
3962 (fun v -> conf
.annotinline
<- v);
3963 src#
bool "coarse positioning in presentation mode"
3964 (fun () -> conf
.coarseprespos
)
3965 (fun v -> conf
.coarseprespos
<- v);
3969 src#caption
"Document" 0;
3970 List.iter
(fun (_, s) -> src#caption
s 1) state
.docinfo
;
3971 src#caption2
"Pages"
3972 (fun () -> string_of_int state
.pagecount
) 1;
3973 src#caption2
"Dimensions"
3974 (fun () -> string_of_int
(List.length state
.pdims
)) 1;
3978 src#caption
"Trimmed margins" 0;
3979 src#caption2
"Dimensions"
3980 (fun () -> string_of_int
(List.length state
.pdims
)) 1;
3984 src#caption
"OpenGL" 0;
3985 src#caption
(Printf.sprintf
"Vendor\t%s" (GlMisc.get_string `vendor
)) 1;
3986 src#caption
(Printf.sprintf
"Renderer\t%s" (GlMisc.get_string `renderer
)) 1;
3989 src#caption
"Location" 0;
3990 if nonemptystr state
.origin
3991 then src#caption
("Orign\t" ^ mbtoutf8 state
.origin
) 1;
3992 src#caption
("Path\t" ^ mbtoutf8 state
.path) 1;
3994 src#reset prevmode prevuioh
;
3999 let prevmode = state
.mode
4000 and prevuioh
= state
.uioh in
4001 fillsrc prevmode prevuioh
;
4002 let source = (src :> lvsource
) in
4003 let modehash = findkeyhash conf
"info" in
4004 state
.uioh <- coe (object (self)
4005 inherit listview ~zebra
:false ~helpmode
:false
4006 ~
source ~trusted
:true ~
modehash as super
4007 val mutable m_prevmemused
= 0
4008 method! infochanged
= function
4010 if m_prevmemused
!= state
.memused
4012 m_prevmemused
<- state
.memused
;
4013 G.postRedisplay "memusedchanged";
4015 | Pdim
-> G.postRedisplay "pdimchanged"
4016 | Docinfo
-> fillsrc prevmode prevuioh
4018 method! key key mask
=
4019 if not
(Wsi.withctrl mask
)
4022 | @left | @kpleft
-> coe (self#updownlevel ~
-1)
4023 | @right
| @kpright
-> coe (self#updownlevel
1)
4024 | _ -> super#
key key mask
4025 else super#
key key mask
4027 G.postRedisplay "info";
4033 inherit lvsourcebase
4034 method getitemcount
= Array.length state
.help
4036 let s, l, _ = state
.help
.(n) in
4039 method exit ~
uioh ~cancel ~
active ~
first ~pan
=
4043 match state
.help
.(active) with
4044 | _, _, Action
f -> Some
(f uioh)
4045 | _, _, Noaction
-> Some
uioh
4054 method hasaction
n =
4055 match state
.help
.(n) with
4056 | _, _, Action
_ -> true
4057 | _, _, Noaction
-> false
4063 let modehash = findkeyhash conf
"help" in
4065 state
.uioh <- coe (new listview
4066 ~zebra
:false ~helpmode
:true
4067 ~
source ~trusted
:true ~
modehash);
4068 G.postRedisplay "help";
4074 inherit lvsourcebase
4075 val mutable m_items
= E.a
4077 method getitemcount
= 1 + Array.length m_items
4082 else m_items
.(n-1), 0
4084 method exit ~
uioh ~cancel ~
active ~
first ~pan
=
4089 then Buffer.clear state
.errmsgs
;
4096 method hasaction
n =
4100 state
.newerrmsgs
<- false;
4101 let l = Str.split newlinere
(Buffer.contents state
.errmsgs
) in
4102 m_items
<- Array.of_list
l
4111 let source = (msgsource :> lvsource
) in
4112 let modehash = findkeyhash conf
"listview" in
4113 state
.uioh <- coe (object
4114 inherit listview ~zebra
:false ~helpmode
:false
4115 ~
source ~trusted
:false ~
modehash as super
4118 then msgsource#reset
;
4121 G.postRedisplay "msgs";
4125 let editor = getenvwithdef
"EDITOR" E.s in
4129 let tmppath = Filename.temp_file
"llpp" "note" in
4132 let oc = open_out
tmppath in
4136 let execstr = editor ^
" " ^
tmppath in
4138 match spawn
execstr [] with
4139 | (exception exn
) ->
4140 impmsg "spawn(%S) failed: %s" execstr @@ exntos exn
;
4143 match Unix.waitpid
[] pid with
4144 | (exception exn
) ->
4145 impmsg "waitpid(%d) failed: %s" pid @@ exntos exn
;
4149 | Unix.WEXITED
0 -> filecontents
tmppath
4151 impmsg "editor process(%s) exited abnormally: %d" execstr n;
4153 | Unix.WSIGNALED
n ->
4154 impmsg "editor process(%s) was killed by signal %d" execstr n;
4156 | Unix.WSTOPPED
n ->
4157 impmsg "editor(%s) process was stopped by signal %d" execstr n;
4160 match Unix.unlink
tmppath with
4161 | (exception exn
) ->
4162 impmsg "failed to ulink %S: %s" tmppath @@ exntos exn
;
4167 let enterannotmode opaque slinkindex
=
4170 inherit lvsourcebase
4171 val mutable m_text
= E.s
4172 val mutable m_items
= E.a
4174 method getitemcount
= Array.length m_items
4177 let label, _func
= m_items
.(n) in
4180 method exit ~
uioh ~cancel ~
active ~
first ~pan
=
4181 ignore
(uioh, first, pan
);
4184 let _label, func
= m_items
.(active) in
4189 method hasaction
n = nonemptystr
@@ fst m_items
.(n)
4192 let rec split accu b i
=
4194 if p = String.length
s
4195 then (String.sub
s b (p-b), unit) :: accu
4197 if (i
> 70 && s.[p] = ' '
) || s.[p] = '
\r'
|| s.[p] = '
\n'
4199 let ss = if i
= 0 then E.s else String.sub
s b i
in
4200 split ((ss, unit)::accu) (p+1) 0
4205 wcmd "freepage %s" (~
> opaque);
4207 Hashtbl.fold (fun key opaque'
accu ->
4208 if opaque'
= opaque'
4209 then key :: accu else accu) state
.pagemap
[]
4211 List.iter
(Hashtbl.remove state
.pagemap
) keys;
4216 delannot
opaque slinkindex
;
4219 let edit inline
() =
4224 modannot
opaque slinkindex
s;
4230 let mode = state
.mode in
4233 ("annotation: ", m_text
, None
, textentry, update, true),
4234 fun _ -> state
.mode <- mode);
4238 let s = getusertext m_text
in
4243 ( "[Copy]", fun () -> selstring m_text
)
4244 :: ("[Delete]", dele)
4245 :: ("[Edit]", edit conf
.annotinline
)
4247 :: split [] 0 0 |> List.rev
|> Array.of_list
4254 let s = getannotcontents
opaque slinkindex
in
4257 let source = (msgsource :> lvsource
) in
4258 let modehash = findkeyhash conf
"listview" in
4259 state
.uioh <- coe (object
4260 inherit listview ~zebra
:false ~helpmode
:false
4261 ~
source ~trusted
:false ~
modehash
4263 G.postRedisplay "enterannotmode";
4266 let gotounder under =
4267 let getpath filename
=
4269 if nonemptystr filename
4271 if Filename.is_relative filename
4273 let dir = Filename.dirname state
.path in
4275 if Filename.is_implicit
dir
4276 then Filename.concat
(Sys.getcwd
()) dir
4279 Filename.concat
dir filename
4283 if Sys.file_exists
path
4288 | Ulinkgoto
(pageno, top) ->
4293 if conf
.presentation
&& conf
.coarseprespos
4297 gotopage1 pageno top;
4300 | Ulinkuri
s -> gotouri
s
4302 | Uremote
(filename
, pageno) ->
4303 let path = getpath filename
in
4308 let command = Printf.sprintf
"%s -page %d %S" !selfexec pageno path in
4309 match spawn
command [] with
4311 | (exception exn
) ->
4312 dolog
"failed to execute `%s': %s" command @@ exntos exn
4314 let anchor = getanchor
() in
4315 let ranchor = state
.path, state
.password, anchor, state
.origin
in
4316 state
.origin
<- E.s;
4317 state
.anchor <- (pageno, 0.0, 0.0);
4318 state
.ranchors
<- ranchor :: state
.ranchors
;
4321 else impmsg "cannot find %s" filename
4323 | Uremotedest
(filename
, destname
) ->
4324 let path = getpath filename
in
4329 let command = !selfexec ^
" " ^
path ^
" -dest " ^ destname
in
4330 match spawn
command [] with
4331 | (exception exn
) ->
4332 dolog
"failed to execute `%s': %s" command @@ exntos exn
4335 let anchor = getanchor
() in
4336 let ranchor = state
.path, state
.password, anchor, state
.origin
in
4337 state
.origin
<- E.s;
4338 state
.nameddest
<- destname
;
4339 state
.ranchors
<- ranchor :: state
.ranchors
;
4342 else impmsg "cannot find %s" filename
4344 | Uunexpected
_ | Ulaunch
_ | Unamed
_ | Utext
_ | Unone
-> ()
4345 | Uannotation
(opaque, slinkindex
) -> enterannotmode opaque slinkindex
4348 let gotooutline (_, _, kind
) =
4352 let (pageno, y, _) = anchor in
4354 (if conf
.presentation
then (pageno, y, 1.0) else anchor)
4358 | Ouri
uri -> gotounder (Ulinkuri
uri)
4359 | Olaunch cmd
-> gotounder (Ulaunch cmd
)
4360 | Oremote remote
-> gotounder (Uremote remote
)
4361 | Ohistory hist
-> gotohist hist
4362 | Oremotedest remotedest
-> gotounder (Uremotedest remotedest
)
4365 class outlinesoucebase fetchoutlines
= object (self)
4366 inherit lvsourcebase
4367 val mutable m_items
= E.a
4368 val mutable m_minfo
= E.a
4369 val mutable m_orig_items
= E.a
4370 val mutable m_orig_minfo
= E.a
4371 val mutable m_narrow_patterns
= []
4372 val mutable m_gen
= -1
4374 method getitemcount
= Array.length m_items
4377 let s, n, _ = m_items
.(n) in
4380 method exit ~
(uioh:uioh) ~cancel ~
active ~
(first:int) ~pan
:
4382 ignore
(uioh, first);
4384 if m_narrow_patterns
= []
4385 then m_orig_items
, m_orig_minfo
4386 else m_items
, m_minfo
4393 gotooutline m_items
.(active);
4401 method hasaction
(_:int) = true
4404 if Array.length m_items
!= Array.length m_orig_items
4407 match m_narrow_patterns
with
4409 | many
-> String.concat
"@Uellipsis" (List.rev many
)
4411 "Narrowed to " ^
s ^
" (ctrl-u to restore)"
4415 match m_narrow_patterns
with
4418 | head
:: _ -> "@Uellipsis" ^ head
4420 method narrow
pattern =
4421 match Str.regexp_case_fold
pattern with
4422 | (exception _) -> ()
4424 let rec loop accu minfo n =
4427 m_items
<- Array.of_list
accu;
4428 m_minfo
<- Array.of_list
minfo;
4431 let (s, _, _) as o = m_items
.(n) in
4433 match Str.search_forward re
s 0 with
4434 | (exception Not_found
) -> accu, minfo
4435 | first -> o :: accu, (first, Str.match_end
()) :: minfo
4437 loop accu minfo (n-1)
4439 loop [] [] (Array.length m_items
- 1)
4441 method! getminfo
= m_minfo
4444 m_orig_items
<- fetchoutlines
();
4445 m_minfo
<- m_orig_minfo
;
4446 m_items
<- m_orig_items
4448 method add_narrow_pattern
pattern =
4449 m_narrow_patterns
<- pattern :: m_narrow_patterns
4451 method del_narrow_pattern
=
4452 match m_narrow_patterns
with
4453 | _ :: rest
-> m_narrow_patterns
<- rest
4458 match m_narrow_patterns
with
4459 | pattern :: [] -> self#narrow
pattern; pattern
4461 List.fold_left
(fun accu pattern ->
4462 self#narrow
pattern;
4463 pattern ^
"@Uellipsis" ^
accu) E.s list
4465 method calcactive
(_:anchor) = 0
4467 method reset
anchor items =
4468 if state
.gen
!= m_gen
4470 m_orig_items
<- items;
4472 m_narrow_patterns
<- [];
4474 m_orig_minfo
<- E.a;
4478 if items != m_orig_items
4480 m_orig_items
<- items;
4481 if m_narrow_patterns
== []
4482 then m_items
<- items;
4485 let active = self#calcactive
anchor in
4487 m_first
<- firstof m_first
active
4491 let outlinesource fetchoutlines
=
4493 inherit outlinesoucebase fetchoutlines
4494 method! calcactive
anchor =
4495 let rely = getanchory anchor in
4496 let rec loop n best bestd
=
4497 if n = Array.length m_items
4500 let _, _, kind
= m_items
.(n) in
4503 let orely = getanchory anchor in
4504 let d = abs
(orely - rely) in
4507 else loop (n+1) best bestd
4508 | Onone
| Oremote
_ | Olaunch
_
4509 | Oremotedest
_ | Ouri
_ | Ohistory
_ ->
4510 loop (n+1) best bestd
4516 let enteroutlinemode, enterbookmarkmode
, enterhistmode
=
4517 let mkselector sourcetype
=
4518 let fetchoutlines () =
4519 match sourcetype
with
4520 | `bookmarks
-> Array.of_list state
.bookmarks
4521 | `outlines
-> state
.outlines
4522 | `history
-> genhistoutlines ()
4525 if sourcetype
= `history
4526 then new outlinesoucebase
fetchoutlines
4527 else outlinesource fetchoutlines
4530 let outlines = fetchoutlines () in
4531 if Array.length
outlines = 0
4533 showtext ' ' errmsg
;
4537 Wsi.setcursor
Wsi.CURSOR_INHERIT
;
4538 let anchor = getanchor
() in
4539 source#reset
anchor outlines;
4540 state
.text <- source#greetmsg
;
4542 coe (new outlinelistview ~zebra
:(sourcetype
=`history
) ~
source);
4543 G.postRedisplay "enter selector";
4546 let mkenter sourcetype errmsg
=
4547 let enter = mkselector sourcetype
in
4548 fun () -> enter errmsg
4550 (**)mkenter `
outlines "document has no outline"
4551 , mkenter `bookmarks
"document has no bookmarks (yet)"
4552 , mkenter `history
"history is empty"
4555 let quickbookmark ?title
() =
4556 match state
.layout with
4562 let tm = Unix.localtime
(now
()) in
4564 "Quick (page %d) (bookmarked at %02d/%02d/%d %02d:%02d)"
4568 (tm.Unix.tm_year
+ 1900)
4571 | Some
title -> title
4573 state
.bookmarks
<- (title, 0, Oanchor
(getanchor1
l)) :: state
.bookmarks
4576 let setautoscrollspeed step goingdown
=
4577 let incr = max
1 ((abs step
) / 2) in
4578 let incr = if goingdown
then incr else -incr in
4579 let astep = boundastep state
.winh
(step
+ incr) in
4580 state
.autoscroll
<- Some
astep;
4584 match conf
.columns
with
4586 | Csingle
_ | Cmulti
_ -> state
.x != 0 || conf
.zoom > 1.0
4589 let panbound x = bound
x (-state
.w) (wadjsb () + state
.winw
);;
4591 let existsinrow pageno (columns
, coverA
, coverB
) p =
4592 let last = ((pageno - coverA
) mod columns
) + columns
in
4593 let rec any = function
4596 if l.pageno = coverA
- 1 || l.pageno = state
.pagecount
- coverB
4600 then (if l.pageno = last then false else any rest
)
4608 match state
.layout with
4610 let pageno = page_of_y state
.y in
4611 gotoghyll (getpagey
(pageno+1))
4613 match conf
.columns
with
4615 if conf
.presentation
&& rest
== [] && l.pageh
> l.pagey + l.pagevh
4617 let y = clamp (pgscale state
.winh
) in
4620 let pageno = min
(l.pageno+1) (state
.pagecount
-1) in
4621 gotoghyll (getpagey
pageno)
4622 | Cmulti
((c, _, _) as cl
, _) ->
4623 if conf
.presentation
4624 && (existsinrow l.pageno cl
4625 (fun l -> l.pageh
> l.pagey + l.pagevh))
4627 let y = clamp (pgscale state
.winh
) in
4630 let pageno = min
(l.pageno+c) (state
.pagecount
-1) in
4631 gotoghyll (getpagey
pageno)
4633 if l.pageno < state
.pagecount
- 1 || l.pagecol
< n - 1
4635 let pagey, pageh
= getpageyh
l.pageno in
4636 let pagey = pagey + pageh
* l.pagecol
in
4637 let ips = if l.pagecol
= 0 then 0 else conf
.interpagespace
in
4638 gotoghyll (pagey + pageh
+ ips)
4642 match state
.layout with
4644 let pageno = page_of_y state
.y in
4645 gotoghyll (getpagey
(pageno-1))
4647 match conf
.columns
with
4649 if conf
.presentation
&& l.pagey != 0
4651 gotoghyll (clamp (pgscale ~
-(state
.winh
)))
4653 let pageno = max
0 (l.pageno-1) in
4654 gotoghyll (getpagey
pageno)
4655 | Cmulti
((c, _, coverB
) as cl
, _) ->
4656 if conf
.presentation
&&
4657 (existsinrow l.pageno cl
(fun l -> l.pagey != 0))
4659 gotoghyll (clamp (pgscale ~
-(state
.winh
)))
4662 if l.pageno = state
.pagecount
- coverB
4666 let pageno = max
0 (l.pageno-decr) in
4667 gotoghyll (getpagey
pageno)
4675 let pageno = max
0 (l.pageno-1) in
4676 let pagey, pageh
= getpageyh
pageno in
4679 let pagey, pageh
= getpageyh
l.pageno in
4680 pagey + pageh
* (l.pagecol
-1) - conf
.interpagespace
4686 if emptystr conf
.savecmd
4687 then error
"don't know where to save modified document"
4689 let savecmd = Str.global_replace percentsre state
.path conf
.savecmd in
4692 (fun s -> error
"failed to obtain path to the saved copy: %s" s)
4697 let tmp = path ^
".tmp" in
4699 Unix.rename
tmp path;
4702 let viewkeyboard key mask
=
4704 let mode = state
.mode in
4705 state
.mode <- Textentry
(te, fun _ -> state
.mode <- mode);
4708 G.postRedisplay "view:enttext"
4710 let ctrl = Wsi.withctrl mask
in
4711 let key = Wsi.keypadtodigitkey
key in
4716 if hasunsavedchanges
()
4720 if conf
.angle
mod 360 = 0 && not
(isbirdseye state
.mode)
4722 state
.mode <- LinkNav
(Ltgendir
0);
4725 else impmsg "keyboard link navigation does not work under rotation"
4728 begin match state
.mstate
with
4731 G.postRedisplay "kill rect";
4734 | Mscrolly
| Mscrollx
4737 begin match state
.mode with
4740 G.postRedisplay "esc leave linknav"
4744 match state
.ranchors
with
4746 | (path, password, anchor, origin
) :: rest
->
4747 state
.ranchors
<- rest
;
4748 state
.anchor <- anchor;
4749 state
.origin
<- origin
;
4750 state
.nameddest
<- E.s;
4751 opendoc path password
4756 gotoghyll (getnav ~
-1)
4767 Hashtbl.iter
(fun _ opaque ->
4769 Hashtbl.clear state
.prects
) state
.pagemap
;
4770 G.postRedisplay "dehighlight";
4772 | @slash
| @question
->
4773 let ondone isforw
s =
4774 cbput state
.hists
.pat
s;
4775 state
.searchpattern
<- s;
4778 let s = String.make
1 (Char.chr
key) in
4779 enttext (s, E.s, Some
(onhist state
.hists
.pat
),
4780 textentry, ondone (key = @slash
), true)
4782 | @plus
| @kpplus
| @equals
when ctrl ->
4783 let incr = if conf
.zoom +. 0.01 > 0.1 then 0.1 else 0.01 in
4784 setzoom (conf
.zoom +. incr)
4786 | @plus
| @kpplus
->
4789 try int_of_string
s with exc
->
4790 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exc
;
4796 state
.text <- "page bias is now " ^ string_of_int
n;
4799 enttext ("page bias: ", E.s, None
, intentry, ondone, true)
4801 | @minus
| @kpminus
when ctrl ->
4802 let decr = if conf
.zoom -. 0.1 < 0.1 then 0.01 else 0.1 in
4803 setzoom (max
0.01 (conf
.zoom -. decr))
4805 | @minus
| @kpminus
->
4806 let ondone msg
= state
.text <- msg
in
4808 "option [acfhilpstvxACFPRSZTISM]: ", E.s, None
,
4809 optentry state
.mode, ondone, true
4820 | (@1 | @2) when ctrl && conf
.fitmodel
!= FitPage
-> (* ctrl-1/2 *)
4822 match conf
.columns
with
4823 | Csingle
_ | Cmulti
_ -> 1
4824 | Csplit
(n, _) -> n
4826 let h = state
.winh
-
4827 conf
.interpagespace
lsl (if conf
.presentation
then 1 else 0)
4829 let zoom = zoomforh state
.winw
h (vscrollw ()) cols in
4830 if zoom > 0.0 && (key = @2 || zoom < 1.0)
4835 match conf
.fitmodel
with
4836 | FitWidth
-> FitProportional
4837 | FitProportional
-> FitPage
4838 | FitPage
-> FitWidth
4840 state
.text <- "fit model: " ^
FMTE.to_string
fm;
4841 reqlayout conf
.angle
fm
4843 | @4 when ctrl -> (* ctrl-4 *)
4844 let zoom = getmaxw
() /. float state
.winw
in
4845 if zoom > 0.0 then setzoom zoom
4853 | (48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57)
4854 when not
ctrl -> (* 0..9 *)
4857 try int_of_string
s with exc
->
4858 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exc
;
4864 cbput state
.hists
.pag
(string_of_int
n);
4865 gotopage1 (n + conf
.pagebias
- 1) 0;
4868 let pageentry text key =
4869 match Char.unsafe_chr
key with
4870 | '
g'
-> TEdone
text
4871 | _ -> intentry text key
4873 let text = String.make
1 (Char.chr
key) in
4874 enttext (":", text, Some
(onhist state
.hists
.pag
),
4875 pageentry, ondone, true)
4878 conf
.scrollb
<- if conf
.scrollb
= 0 then (scrollbvv
lor scrollbhv
) else 0;
4879 reshape state
.winw state
.winh
;
4882 state
.bzoom
<- not state
.bzoom
;
4884 showtext ' '
("block zoom " ^
if state
.bzoom
then "on" else "off")
4887 conf
.hlinks
<- not conf
.hlinks
;
4888 state
.text <- "highlightlinks " ^
if conf
.hlinks
then "on" else "off";
4889 G.postRedisplay "toggle highlightlinks";
4892 if conf
.angle
mod 360 = 0
4894 state
.glinks
<- true;
4895 let mode = state
.mode in
4898 (":", E.s, None
, linknentry, linknact gotounder, false),
4900 state
.glinks
<- false;
4904 G.postRedisplay "view:linkent(F)"
4906 else impmsg "hint mode does not work under rotation"
4909 state
.glinks
<- true;
4910 let mode = state
.mode in
4911 state
.mode <- Textentry
(
4913 ":", E.s, None
, linknentry, linknact (fun under ->
4914 selstring (undertext under);
4918 state
.glinks
<- false;
4922 G.postRedisplay "view:linkent"
4925 begin match state
.autoscroll
with
4927 conf
.autoscrollstep
<- step
;
4928 state
.autoscroll
<- None
4930 if conf
.autoscrollstep
= 0
4931 then state
.autoscroll
<- Some
1
4932 else state
.autoscroll
<- Some conf
.autoscrollstep
4936 launchpath () (* XXX where do error messages go? *)
4939 setpresentationmode (not conf
.presentation
);
4940 showtext ' '
("presentation mode " ^
4941 if conf
.presentation
then "on" else "off");
4944 if List.mem
Wsi.Fullscreen state
.winstate
4945 then Wsi.reshape conf
.cwinw conf
.cwinh
4946 else Wsi.fullscreen
()
4949 search state
.searchpattern
false
4952 search state
.searchpattern
true
4955 begin match state
.layout with
4958 gotoghyll (getpagey
l.pageno)
4964 | @delete
| @kpdelete
-> (* delete *)
4968 showtext ' '
(describe_location ());
4971 begin match state
.layout with
4974 Wsi.reshape (l.pagew
+ vscrollw ()) l.pageh
;
4979 enterbookmarkmode
()
4987 | @e when Buffer.length state
.errmsgs
> 0 ->
4992 match state
.layout with
4997 (s, 0, Oanchor
(getanchor1
l)) :: state
.bookmarks
5000 enttext ("bookmark: ", E.s, None
, textentry, ondone, true)
5004 showtext ' '
"Quick bookmark added";
5007 begin match state
.layout with
5009 let rect = getpdimrect
l.pagedimno
in
5013 (truncate
(1.8 *. (rect.(1) -. rect.(0))),
5014 truncate
(1.2 *. (rect.(3) -. rect.(0))))
5016 (truncate
(rect.(1) -. rect.(0)),
5017 truncate
(rect.(3) -. rect.(0)))
5019 let w = truncate
((float w)*.conf
.zoom)
5020 and h = truncate
((float h)*.conf
.zoom) in
5023 state
.anchor <- getanchor
();
5024 Wsi.reshape (w + vscrollw ()) (h + conf
.interpagespace
)
5026 G.postRedisplay "z";
5031 | @x -> state
.roam
()
5034 reqlayout (conf
.angle
+
5035 (if key = @Gt
then 30 else -30)) conf
.fitmodel
5039 bound
(conf
.colorscale
+. (if key = 93 then 0.1 else -0.1)) 0.0 1.0
5041 G.postRedisplay "brightness";
5043 | @c when state
.mode = View
->
5048 let m = (wadjsb () + state
.winw
- state
.w) / 2 in
5050 gotoy_and_clear_text state
.y
5054 match state
.prevcolumns
with
5055 | None
-> (1, 0, 0), 1.0
5056 | Some
(columns
, z
) ->
5059 | Csplit
(c, _) -> -c, 0, 0
5060 | Cmulti
((c, a, b), _) -> c, a, b
5061 | Csingle
_ -> 1, 0, 0
5065 setcolumns View
c a b;
5068 | @down
| @up
when ctrl && Wsi.withshift mask
->
5069 let zoom, x = state
.prevzoom
in
5073 | @k
| @up
| @kpup
->
5074 begin match state
.autoscroll
with
5076 begin match state
.mode with
5077 | Birdseye beye
-> upbirdseye 1 beye
5082 then gotoy_and_clear_text (clamp ~
-(state
.winh
/2))
5084 if not
(Wsi.withshift mask
) && conf
.presentation
5086 else gotoghyll1 true (clamp (-conf
.scrollstep
))
5090 setautoscrollspeed n false
5093 | @j
| @down
| @kpdown
->
5094 begin match state
.autoscroll
with
5096 begin match state
.mode with
5097 | Birdseye beye
-> downbirdseye 1 beye
5102 then gotoy_and_clear_text (clamp (state
.winh
/2))
5104 if not
(Wsi.withshift mask
) && conf
.presentation
5106 else gotoghyll1 true (clamp (conf
.scrollstep
))
5110 setautoscrollspeed n true
5113 | @left | @right
| @kpleft
| @kpright
when not
(Wsi.withalt mask
) ->
5119 else conf
.hscrollstep
5121 let dx = if key = @left || key = @kpleft
then dx else -dx in
5122 state
.x <- panbound (state
.x + dx);
5123 gotoy_and_clear_text state
.y
5126 G.postRedisplay "left/right"
5129 | @prior
| @kpprior
->
5133 match state
.layout with
5135 | l :: _ -> state
.y - l.pagey
5137 clamp (pgscale (-state
.winh
))
5141 | @next | @kpnext
->
5145 match List.rev state
.layout with
5147 | l :: _ -> getpagey
l.pageno
5149 clamp (pgscale state
.winh
)
5153 | @g | @home
| @kphome
->
5156 | @G
| @jend
| @kpend
->
5158 gotoghyll (clamp state
.maxy)
5160 | @right
| @kpright
when Wsi.withalt mask
->
5161 gotoghyll (getnav 1)
5162 | @left | @kpleft
when Wsi.withalt mask
->
5163 gotoghyll (getnav ~
-1)
5168 | @v when conf
.debug
->
5171 match getopaque l.pageno with
5174 let x0, y0, x1, y1 = pagebbox
opaque in
5175 let rect = (float x0, float y0,
5178 float x0, float y1) in
5180 let color = (0.0, 0.0, 1.0 /. (l.pageno mod 3 |> float), 0.5) in
5181 state
.rects
<- (l.pageno, color, rect) :: state
.rects
;
5183 G.postRedisplay "v";
5186 let mode = state
.mode in
5187 let cmd = ref E.s in
5188 let onleave = function
5189 | Cancel
-> state
.mode <- mode
5192 match getopaque l.pageno with
5193 | Some
opaque -> pipesel opaque !cmd
5194 | None
-> ()) state
.layout;
5198 cbput state
.hists
.sel
s;
5202 "| ", !cmd, Some
(onhist state
.hists
.sel
), textentry, ondone, true
5204 G.postRedisplay "|";
5205 state
.mode <- Textentry
(te, onleave);
5208 vlog "huh? %s" (Wsi.keyname
key)
5211 let linknavkeyboard key mask
linknav =
5212 let getpage pageno =
5213 let rec loop = function
5215 | l :: _ when l.pageno = pageno -> Some
l
5216 | _ :: rest
-> loop rest
5217 in loop state
.layout
5219 let doexact (pageno, n) =
5220 match getopaque pageno, getpage pageno with
5221 | Some
opaque, Some
l ->
5222 if key = @enter || key = @kpenter
5224 let under = getlink
opaque n in
5225 G.postRedisplay "link gotounder";
5232 Some
(findlink
opaque LDfirst
), -1
5235 Some
(findlink
opaque LDlast
), 1
5238 Some
(findlink
opaque (LDleft
n)), -1
5241 Some
(findlink
opaque (LDright
n)), 1
5244 Some
(findlink
opaque (LDup
n)), -1
5247 Some
(findlink
opaque (LDdown
n)), 1
5252 begin match findpwl
l.pageno dir with
5256 state
.mode <- LinkNav
(Ltgendir
dir);
5257 let y, h = getpageyh
pageno in
5260 then y + h - state
.winh
5265 begin match getopaque pageno, getpage pageno with
5266 | Some
opaque, Some
_ ->
5268 let ld = if dir > 0 then LDfirst
else LDlast
in
5271 begin match link with
5273 showlinktype (getlink
opaque m);
5274 state
.mode <- LinkNav
(Ltexact
(pageno, m));
5275 G.postRedisplay "linknav jpage";
5276 | Lnotfound
-> notfound dir
5282 begin match opt with
5283 | Some Lnotfound
-> pwl l dir;
5284 | Some
(Lfound
m) ->
5288 let _, y0, _, y1 = getlinkrect
opaque m in
5290 then gotopage1 l.pageno y0
5292 let d = fstate
.fontsize
+ 1 in
5293 if y1 - l.pagey > l.pagevh - d
5294 then gotopage1 l.pageno (y1 - state
.winh
- hscrollh () + d)
5295 else G.postRedisplay "linknav";
5297 showlinktype (getlink
opaque m);
5298 state
.mode <- LinkNav
(Ltexact
(l.pageno, m));
5301 | None
-> viewkeyboard key mask
5303 | _ -> viewkeyboard key mask
5308 G.postRedisplay "leave linknav"
5312 | Ltgendir
_ | Ltnotready
_ -> viewkeyboard key mask
5313 | Ltexact exact
-> doexact exact
5316 let keyboard key mask
=
5317 if (key = @g && Wsi.withctrl mask
) && not
(istextentry state
.mode)
5318 then wcmd "interrupt"
5319 else state
.uioh <- state
.uioh#
key key mask
5322 let birdseyekeyboard key mask
5323 ((oconf
, leftx
, pageno, hooverpageno
, anchor) as beye
) =
5325 match conf
.columns
with
5327 | Cmulti
((c, _, _), _) -> c
5328 | Csplit
_ -> failwith
"bird's eye split mode"
5330 let pgh layout = List.fold_left
5331 (fun m l -> max
l.pageh
m) state
.winh
layout in
5333 | @l when Wsi.withctrl mask
->
5334 let y, h = getpageyh
pageno in
5335 let top = (state
.winh
- h) / 2 in
5336 gotoy (max
0 (y - top))
5337 | @enter | @kpenter
-> leavebirdseye beye
false
5338 | @escape
-> leavebirdseye beye
true
5339 | @up
-> upbirdseye incr beye
5340 | @down
-> downbirdseye incr beye
5341 | @left -> upbirdseye 1 beye
5342 | @right
-> downbirdseye 1 beye
5345 begin match state
.layout with
5349 state
.mode <- Birdseye
(
5350 oconf
, leftx
, l.pageno, hooverpageno
, anchor
5352 gotopage1 l.pageno 0;
5355 let layout = layout state
.x (state
.y-state
.winh
)
5357 (pgh state
.layout) in
5359 | [] -> gotoy (clamp (-state
.winh
))
5361 state
.mode <- Birdseye
(
5362 oconf
, leftx
, l.pageno, hooverpageno
, anchor
5364 gotopage1 l.pageno 0
5367 | [] -> gotoy (clamp (-state
.winh
))
5371 begin match List.rev state
.layout with
5373 let layout = layout state
.x
5374 (state
.y + (pgh state
.layout))
5375 state
.winw state
.winh
in
5376 begin match layout with
5378 let incr = l.pageh
- l.pagevh in
5383 oconf
, leftx
, state
.pagecount
- 1, hooverpageno
, anchor
5385 G.postRedisplay "birdseye pagedown";
5387 else gotoy (clamp (incr + conf
.interpagespace
*2));
5391 Birdseye
(oconf
, leftx
, l.pageno, hooverpageno
, anchor);
5392 gotopage1 l.pageno 0;
5395 | [] -> gotoy (clamp state
.winh
)
5399 state
.mode <- Birdseye
(oconf
, leftx
, 0, hooverpageno
, anchor);
5403 let pageno = state
.pagecount
- 1 in
5404 state
.mode <- Birdseye
(oconf
, leftx
, pageno, hooverpageno
, anchor);
5405 if not
(pagevisible state
.layout pageno)
5408 match List.rev state
.pdims
with
5410 | (_, _, h, _) :: _ -> h
5412 gotoy (max
0 (getpagey
pageno - (state
.winh
- h - conf
.interpagespace
)))
5413 else G.postRedisplay "birdseye end";
5415 | _ -> viewkeyboard key mask
5420 match state
.mode with
5421 | Textentry
_ -> scalecolor 0.4
5423 | View
-> scalecolor 1.0
5424 | Birdseye
(_, _, pageno, hooverpageno
, _) ->
5425 if l.pageno = hooverpageno
5428 if l.pageno = pageno
5430 let c = scalecolor 1.0 in
5432 GlDraw.line_width
3.0;
5433 let dispx = xadjsb () + l.pagedispx in
5435 (float (dispx-1)) (float (l.pagedispy-1))
5436 (float (dispx+l.pagevw+1))
5437 (float (l.pagedispy+l.pagevh+1))
5439 GlDraw.line_width
1.0;
5448 let postdrawpage l linkindexbase
=
5449 match getopaque l.pageno with
5451 if tileready l l.pagex
l.pagey
5453 let x = l.pagedispx - l.pagex
+ xadjsb ()
5454 and y = l.pagedispy - l.pagey in
5456 match conf
.columns
with
5457 | Csingle
_ | Cmulti
_ ->
5458 (if conf
.hlinks
then 1 else 0)
5460 && not
(isbirdseye state
.mode) then 2 else 0)
5464 match state
.mode with
5465 | Textentry
((_, s, _, _, _, _), _) when state
.glinks
-> s
5471 Hashtbl.find_all state
.prects
l.pageno |>
5472 List.iter
(fun vals
-> drawprect
opaque x y vals
);
5473 postprocess
opaque hlmask x y (linkindexbase
, s, conf
.hfsize
);
5478 let scrollindicator () =
5479 let sbw, ph
, sh = state
.uioh#
scrollph in
5480 let sbh, pw, sw = state
.uioh#scrollpw
in
5485 else ((state
.winw
- sbw), state
.winw
, 0)
5488 GlDraw.color (0.64, 0.64, 0.64);
5489 filledrect (float x0) 0. (float x1) (float state
.winh
);
5491 (float hx0
) (float (state
.winh
- sbh))
5492 (float (hx0
+ wadjsb () + state
.winw
)) (float state
.winh
)
5494 GlDraw.color (0.0, 0.0, 0.0);
5496 filledrect (float x0) ph
(float x1) (ph
+. sh);
5497 let pw = pw +. float hx0
in
5498 filledrect pw (float (state
.winh
- sbh)) (pw +. sw) (float state
.winh
);
5502 match state
.mstate
with
5503 | Mnone
| Mscrolly
| Mscrollx
| Mpan
_ | Mzoom
_ | Mzoomrect
_ ->
5506 | Msel
((x0, y0), (x1, y1)) ->
5507 let identify opaque l px py = Some
(opaque, l.pageno, px, py) in
5508 let o0,n0
,px0
,py0
= onppundermouse identify x0 y0 (~
< E.s, -1, 0, 0) in
5509 let _o1,n1
,px1
,py1
= onppundermouse identify x1 y1 (~
< E.s, -1, 0, 0) in
5510 if n0
!= -1 && n0
= n1
then seltext
o0 (px0
, py0
, px1
, py1
);
5513 let showrects = function [] -> () | rects
->
5515 GlDraw.color (0.0, 0.0, 1.0) ~
alpha:0.5;
5516 GlFunc.blend_func ~
src:`src_alpha ~dst
:`one_minus_src_alpha
;
5518 (fun (pageno, c, (x0, y0, x1, y1, x2
, y2
, x3
, y3
)) ->
5520 if l.pageno = pageno
5522 let dx = float (l.pagedispx - l.pagex
) in
5523 let dy = float (l.pagedispy - l.pagey) in
5524 let r, g, b, alpha = c in
5525 GlDraw.color (r, g, b) ~
alpha;
5526 filledrect2 (x0+.dx) (y0+.dy)
5538 begin match conf
.columns
, state
.layout with
5539 | Csingle
_, _ :: _ ->
5540 GlDraw.color (scalecolor2 conf
.bgcolor
);
5542 List.fold_left
(fun y l ->
5545 let x1 = l.pagedispx + xadjsb () in
5546 let y1 = (l.pagedispy + l.pagevh) in
5547 filledrect (float x0) (float y0) (float x1) (float y1);
5548 let x0 = x1 + l.pagevw in
5549 let x1 = state
.winw
in
5550 filledrect1 (float x0) (float y0) (float x1) (float y1);
5554 and x1 = state
.winw
in
5556 and y1 = l.pagedispy in
5557 filledrect1 (float x0) (float y0) (float x1) (float y1);
5559 l.pagedispy + l.pagevh) 0 state
.layout
5562 and x1 = state
.winw
in
5564 and y1 = state
.winh
in
5565 filledrect1 (float x0) (float y0) (float x1) (float y1)
5566 | (Cmulti
_ | Csplit
_), _ | Csingle
_, [] ->
5567 GlClear.color (scalecolor2 conf
.bgcolor
);
5568 GlClear.clear
[`
color];
5570 List.iter
drawpage state
.layout;
5572 match state
.mode with
5573 | LinkNav
(Ltexact
(pageno, linkno
)) ->
5574 begin match getopaque pageno with
5576 let dx = xadjsb () in
5577 let x0, y0, x1, y1 = getlinkrect
opaque linkno
in
5578 let x0 = x0 + dx and x1 = x1 + dx in
5579 let color = (0.0, 0.0, 0.5, 0.5) in
5586 | None
-> state
.rects
5588 | LinkNav
(Ltgendir
_) | LinkNav
(Ltnotready
_)
5591 | View
-> state
.rects
5594 let rec postloop linkindexbase
= function
5596 let linkindexbase = linkindexbase + postdrawpage l linkindexbase in
5597 postloop linkindexbase rest
5601 postloop 0 state
.layout;
5603 begin match state
.mstate
with
5604 | Mzoomrect
((x0, y0), (x1, y1)) ->
5606 GlDraw.color (0.3, 0.3, 0.3) ~
alpha:0.5;
5607 GlFunc.blend_func ~
src:`src_alpha ~dst
:`one_minus_src_alpha
;
5608 filledrect (float x0) (float y0) (float x1) (float y1);
5612 | Mscrolly
| Mscrollx
5621 let zoomrect x y x1 y1 =
5624 and y0 = min
y y1 in
5625 gotoy (state
.y + y0);
5626 state
.anchor <- getanchor
();
5627 let zoom = (float state
.w) /. float (x1 - x0) in
5630 let adjw = wadjsb () + state
.winw
in
5632 then (adjw - state
.w) / 2
5635 match conf
.fitmodel
with
5636 | FitWidth
| FitProportional
-> simple ()
5638 match conf
.columns
with
5640 onppundermouse (fun _ l _ _ -> Some
l.pagedispx) x0 y0 x0
5641 | Cmulti
_ | Csingle
_ -> simple ()
5643 state
.x <- (state
.x + margin) - x0;
5648 let annot inline
x y =
5649 match unproject x y with
5650 | Some
(opaque, n, ux
, uy
) ->
5652 addannot
opaque ux uy
text;
5653 wcmd "freepage %s" (~
> opaque);
5654 Hashtbl.remove state
.pagemap
(n, state
.gen
);
5660 let ondone s = add s in
5661 let mode = state
.mode in
5662 state
.mode <- Textentry
(
5663 ("annotation: ", E.s, None
, textentry, ondone, true),
5664 fun _ -> state
.mode <- mode);
5667 G.postRedisplay "annot"
5669 add @@ getusertext E.s
5674 let g opaque l px py =
5675 match rectofblock
opaque px py with
5677 let x0 = a.(0) -. 20. in
5678 let x1 = a.(1) +. 20. in
5679 let y0 = a.(2) -. 20. in
5680 let zoom = (float state
.w) /. (x1 -. x0) in
5681 let pagey = getpagey
l.pageno in
5682 gotoy_and_clear_text (pagey + truncate
y0);
5683 state
.anchor <- getanchor
();
5684 let margin = (state
.w - l.pagew
)/2 in
5685 state
.x <- -truncate
x0 - margin;
5690 match conf
.columns
with
5692 impmsg "block zooming does not work properly in split columns mode"
5693 | Cmulti
_ | Csingle
_ -> onppundermouse g x y ()
5697 let winw = wadjsb () + state
.winw - 1 in
5698 let s = float x /. float winw in
5699 let destx = truncate
(float (state
.w + winw) *. s) in
5700 state
.x <- winw - destx;
5701 gotoy_and_clear_text state
.y;
5702 state
.mstate
<- Mscrollx
;
5706 let s = float y /. float state
.winh
in
5707 let desty = truncate
(float (state
.maxy - state
.winh
) *. s) in
5708 gotoy_and_clear_text desty;
5709 state
.mstate
<- Mscrolly
;
5712 let viewmulticlick clicks
x y mask
=
5713 let g opaque l px py =
5721 if markunder
opaque px py mark
5725 match getopaque l.pageno with
5727 | Some
opaque -> pipesel opaque cmd
5729 state
.roam
<- (fun () -> dopipe conf
.paxcmd
);
5730 if not
(Wsi.withctrl mask
) then dopipe conf
.selcmd
;
5735 G.postRedisplay "viewmulticlick";
5736 onppundermouse g x y (fun () -> impmsg "nothing to select") ();
5740 match conf
.columns
with
5742 | Csingle
_ | Cmulti
_ -> conf
.angle
mod 360 = 0
5745 let viewmouse button down
x y mask
=
5747 | n when (n == 4 || n == 5) && not down
->
5748 if Wsi.withctrl mask
5750 match state
.mstate
with
5751 | Mzoom
(oldn
, i
) ->
5759 if conf
.zoom +. 0.01 > 0.1 then 0.1 else 0.01
5761 if conf
.zoom -. 0.1 < 0.1 then -0.01 else -0.1
5763 let zoom = conf
.zoom -. incr in
5765 state
.mstate
<- Mzoom
(n, 0);
5767 state
.mstate
<- Mzoom
(n, i
+1);
5769 else state
.mstate
<- Mzoom
(n, 0)
5773 | Mscrolly
| Mscrollx
5775 | Mnone
-> state
.mstate
<- Mzoom
(n, 0)
5778 match state
.autoscroll
with
5779 | Some step
-> setautoscrollspeed step
(n=4)
5781 if conf
.wheelbypage
|| conf
.presentation
5790 then -conf
.scrollstep
5791 else conf
.scrollstep
5793 let incr = incr * 2 in
5794 let y = clamp incr in
5795 gotoy_and_clear_text y
5798 | n when (n = 6 || n = 7) && not down
&& canpan () ->
5800 panbound (state
.x + (if n = 7 then -2 else 2) * conf
.hscrollstep
);
5801 gotoy_and_clear_text state
.y
5803 | 1 when Wsi.withshift mask
->
5804 state
.mstate
<- Mnone
;
5807 match unproject x y with
5809 | Some
(_, pageno, ux
, uy
) ->
5810 let cmd = Printf.sprintf
5812 conf
.stcmd state
.path pageno ux uy
5814 match spawn
cmd [] with
5815 | (exception exn
) ->
5816 impmsg "execution of synctex command(%S) failed: %S"
5817 conf
.stcmd
@@ exntos exn
5821 | 1 when Wsi.withctrl mask
->
5824 Wsi.setcursor
Wsi.CURSOR_FLEUR
;
5825 state
.mstate
<- Mpan
(x, y)
5828 state
.mstate
<- Mnone
5833 if Wsi.withshift mask
5835 annot conf
.annotinline
x y;
5836 G.postRedisplay "addannot"
5840 Wsi.setcursor
Wsi.CURSOR_CYCLE
;
5841 state
.mstate
<- Mzoomrect
(p, p)
5844 match state
.mstate
with
5845 | Mzoomrect
((x0, y0), _) ->
5846 if abs
(x-x0) > 10 && abs
(y - y0) > 10
5847 then zoomrect x0 y0 x y
5850 G.postRedisplay "kill accidental zoom rect";
5854 | Mscrolly
| Mscrollx
5860 | 1 when vscrollhit x ->
5863 let _, position, sh = state
.uioh#
scrollph in
5864 if y > truncate
position && y < truncate
(position +. sh)
5865 then state
.mstate
<- Mscrolly
5868 state
.mstate
<- Mnone
5870 | 1 when y > state
.winh
- hscrollh () ->
5873 let _, position, sw = state
.uioh#scrollpw
in
5874 if x > truncate
position && x < truncate
(position +. sw)
5875 then state
.mstate
<- Mscrollx
5878 state
.mstate
<- Mnone
5880 | 1 when state
.bzoom
-> if not down
then zoomblock x y
5883 let dest = if down
then getunder x y else Unone
in
5884 begin match dest with
5887 | Uremote
_ | Uremotedest
_
5888 | Uunexpected
_ | Ulaunch
_ | Unamed
_ ->
5891 | Unone
when down
->
5892 Wsi.setcursor
Wsi.CURSOR_FLEUR
;
5893 state
.mstate
<- Mpan
(x, y);
5895 | Uannotation
(opaque, slinkindex
) -> enterannotmode opaque slinkindex
5897 | Unone
| Utext
_ ->
5902 state
.mstate
<- Msel
((x, y), (x, y));
5903 G.postRedisplay "mouse select";
5907 match state
.mstate
with
5910 | Mzoom
_ | Mscrollx
| Mscrolly
->
5911 state
.mstate
<- Mnone
5913 | Mzoomrect
((x0, y0), _) ->
5917 Wsi.setcursor
Wsi.CURSOR_INHERIT
;
5918 state
.mstate
<- Mnone
5920 | Msel
((x0, y0), (x1, y1)) ->
5921 let rec loop = function
5925 let a0 = l.pagedispy in
5926 let a1 = a0 + l.pagevh in
5927 let b0 = l.pagedispx in
5928 let b1 = b0 + l.pagevw in
5929 ((y0 >= a0 && y0 <= a1) || (y1 >= a0 && y1 <= a1))
5930 && ((x0 >= b0 && x0 <= b1) || (x1 >= b0 && x1 <= b1))
5934 match getopaque l.pageno with
5937 match Unix.pipe
() with
5938 | (exception exn
) ->
5939 impmsg "cannot create sel pipe: %s" @@
5943 Ne.clo fd
(fun msg
->
5944 dolog
"%s close failed: %s" what msg
)
5947 try spawn
cmd [r, 0; w, -1]
5949 dolog
"cannot execute %S: %s"
5956 G.postRedisplay "copysel";
5958 else clo "Msel pipe/w" w;
5959 clo "Msel pipe/r" r;
5961 dosel conf
.selcmd
();
5962 state
.roam
<- dosel conf
.paxcmd
;
5974 let birdseyemouse button down
x y mask
5975 (conf
, leftx
, _, hooverpageno
, anchor) =
5978 let rec loop = function
5981 if y > l.pagedispy && y < l.pagedispy + l.pagevh
5982 && x > l.pagedispx && x < l.pagedispx + l.pagevw
5984 leavebirdseye (conf
, leftx
, l.pageno, hooverpageno
, anchor) false;
5990 | _ -> viewmouse button down
x y mask
5996 method key key mask
=
5997 begin match state
.mode with
5998 | Textentry
textentry -> textentrykeyboard key mask
textentry
5999 | Birdseye
birdseye -> birdseyekeyboard key mask
birdseye
6000 | View
-> viewkeyboard key mask
6001 | LinkNav
linknav -> linknavkeyboard key mask
linknav
6005 method button button bstate
x y mask
=
6006 begin match state
.mode with
6008 | View
-> viewmouse button bstate
x y mask
6009 | Birdseye beye
-> birdseyemouse button bstate
x y mask beye
6014 method multiclick clicks
x y mask
=
6015 begin match state
.mode with
6017 | View
-> viewmulticlick clicks
x y mask
6024 begin match state
.mode with
6026 | View
| Birdseye
_ | LinkNav
_ ->
6027 match state
.mstate
with
6028 | Mzoom
_ | Mnone
-> ()
6033 state
.mstate
<- Mpan
(x, y);
6035 then state
.x <- panbound (state
.x + dx);
6037 gotoy_and_clear_text y
6040 state
.mstate
<- Msel
(a, (x, y));
6041 G.postRedisplay "motion select";
6044 let y = min state
.winh
(max
0 y) in
6048 let x = min state
.winw (max
0 x) in
6051 | Mzoomrect
(p0
, _) ->
6052 state
.mstate
<- Mzoomrect
(p0
, (x, y));
6053 G.postRedisplay "motion zoomrect";
6057 method pmotion
x y =
6058 begin match state
.mode with
6059 | Birdseye
(conf
, leftx
, pageno, hooverpageno
, anchor) ->
6060 let rec loop = function
6062 if hooverpageno
!= -1
6064 state
.mode <- Birdseye
(conf
, leftx
, pageno, -1, anchor);
6065 G.postRedisplay "pmotion birdseye no hoover";
6068 if y > l.pagedispy && y < l.pagedispy + l.pagevh
6069 && x > l.pagedispx && x < l.pagedispx + l.pagevw
6071 state
.mode <- Birdseye
(conf
, leftx
, pageno, l.pageno, anchor);
6072 G.postRedisplay "pmotion birdseye hoover";
6082 match state
.mstate
with
6083 | Mpan
_ | Msel
_ | Mzoom
_ | Mscrolly
| Mscrollx
| Mzoomrect
_ -> ()
6091 let past, _, _ = !r in
6093 let delta = now -. past in
6096 else r := (now, x, y)
6100 method infochanged
_ = ()
6103 let maxy = state
.maxy - (if conf
.maxhfit
then state
.winh
else 0) in
6106 then 0.0, float state
.winh
6107 else scrollph state
.y maxy
6112 let winw = wadjsb () + state
.winw in
6113 let fwinw = float winw in
6115 let sw = fwinw /. float state
.w in
6116 let sw = fwinw *. sw in
6117 max
sw (float conf
.scrollh
)
6120 let maxx = state
.w + winw in
6121 let x = winw - state
.x in
6122 let percent = float x /. float maxx in
6123 (fwinw -. sw) *. percent
6125 hscrollh (), position, sw
6129 match state
.mode with
6130 | LinkNav
_ -> "links"
6131 | Textentry
_ -> "textentry"
6132 | Birdseye
_ -> "birdseye"
6135 findkeyhash conf
modename
6137 method eformsgs
= true
6138 method alwaysscrolly
= false
6141 let addrect pageno r g b a x0 y0 x1 y1 =
6142 Hashtbl.add state
.prects
pageno [|r; g; b; a; x0; y0; x1; y1|];
6146 let cl = splitatspace cmds
in
6148 try Scanf.sscanf
s fmt
f
6150 adderrfmt "remote exec"
6151 "error processing '%S': %s\n" cmds
@@ exntos exn
6153 let rectx s pageno (r, g, b, a) x0 y0 x1 y1 =
6154 vlog "%s page %d color (%f %f %f %f) x0,y0,x1,y1 = %f %f %f %f"
6155 s pageno r g b a x0 y0 x1 y1;
6159 let _,w1,h1
,_ = getpagedim
pageno in
6160 let sw = float w1 /. float w
6161 and sh = float h1
/. float h in
6165 and y1s
= y1 *. sh in
6166 let rect = (x0s,y0s
,x1s
,y0s
,x1s
,y1s
,x0s,y1s
) in
6167 let color = (r, g, b, a) in
6168 if conf
.verbose
then debugrect rect;
6169 state
.rects <- (pageno, color, rect) :: state
.rects;
6174 | "reload", "" -> reload ()
6176 scan args
"%u %f %f"
6178 let cmd, _ = state
.geomcmds
in
6180 then gotopagexy !wtmode pageno x y
6183 gotopagexy !wtmode pageno x y;
6186 state
.reprf
<- f state
.reprf
6188 | "goto1", args
-> scan args
"%u %f" gotopage
6191 (fun filename
pageno -> gotounder (Uremote
(filename
, pageno)))
6194 (fun filename
dest -> gotounder (Uremotedest
(filename
, dest)))
6196 scan args
"%u %u %f %f %f %f"
6197 (fun pageno c x0 y0 x1 y1 ->
6198 let color = (0.0, 0.0, 1.0 /. float c, 0.5) in
6199 rectx "rect" pageno color x0 y0 x1 y1;
6202 scan args
"%u %f %f %f %f %f %f %f %f"
6203 (fun pageno r g b alpha x0 y0 x1 y1 ->
6204 addrect pageno r g b alpha x0 y0 x1 y1;
6205 G.postRedisplay "prect"
6208 scan args
"%u %f %f"
6211 match getopaque pageno with
6212 | Some
opaque -> opaque
6215 pgoto optopaque pageno x y;
6216 let rec fixx = function
6219 if l.pageno = pageno
6221 state
.x <- state
.x - l.pagedispx;
6228 match conf
.columns
with
6229 | Csingle
_ | Csplit
_ -> 1
6230 | Cmulti
((n, _, _), _) -> n
6232 layout 0 state
.y (state
.winw * mult) state
.winh
6236 | "activatewin", "" -> Wsi.activatewin
()
6237 | "quit", "" -> raise Quit
6240 let l = Config.keys_of_string
keys in
6241 List.iter
(fun (k
, m) -> keyboard k
m) l
6243 adderrfmt "error processing keys" "`%S': %s\n" cmds
@@ exntos exn
6245 | "clearrects", "" ->
6246 Hashtbl.clear state
.prects
;
6247 G.postRedisplay "clearrects"
6249 adderrfmt "remote command"
6250 "error processing remote command: %S\n" cmds
;
6254 let scratch = Bytes.create
80 in
6255 let buf = Buffer.create
80 in
6257 match tempfailureretry
(Unix.read fd
scratch 0) 80 with
6258 | (exception Unix.Unix_error
(Unix.EAGAIN
, _, _)) -> None
6261 if Buffer.length
buf > 0
6263 let s = Buffer.contents
buf in
6271 match Bytes.index_from
scratch ppos '
\n'
with
6272 | pos -> if pos >= n then -1 else pos
6273 | (exception Not_found
) -> -1
6277 Buffer.add_subbytes
buf scratch ppos
(nlpos-ppos
);
6278 let s = Buffer.contents
buf in
6284 Buffer.add_subbytes
buf scratch ppos
(n-ppos
);
6290 let remoteopen path =
6291 try Some
(Unix.openfile
path [Unix.O_NONBLOCK
; Unix.O_RDONLY
] 0o0)
6293 adderrfmt "remoteopen" "error opening %S: %s" path @@ exntos exn
;
6298 let gcconfig = ref E.s in
6299 let trimcachepath = ref E.s in
6300 let rcmdpath = ref E.s in
6301 let pageno = ref None
in
6302 let rootwid = ref 0 in
6303 let openlast = ref false in
6304 let nofc = ref false in
6305 let doreap = ref false in
6306 selfexec := Sys.executable_name
;
6309 [("-p", Arg.String
(fun s -> state
.password <- s),
6310 "<password> Set password");
6314 Config.fontpath
:= s;
6315 selfexec := !selfexec ^
" -f " ^
Filename.quote
s;
6317 "<path> Set path to the user interface font");
6321 selfexec := !selfexec ^
" -c " ^
Filename.quote
s;
6322 Config.confpath
:= s),
6323 "<path> Set path to the configuration file");
6325 ("-last", Arg.Set
openlast, " Open last document");
6327 ("-page", Arg.Int
(fun pageno1
-> pageno := Some
(pageno1
-1)),
6328 "<page-number> Jump to page");
6330 ("-tcf", Arg.String
(fun s -> trimcachepath := s),
6331 "<path> Set path to the trim cache file");
6333 ("-dest", Arg.String
(fun s -> state
.nameddest
<- s),
6334 "<named-destination> Set named destination");
6336 ("-wtmode", Arg.Set
wtmode, " Operate in wt mode");
6337 ("-cxack", Arg.Set
cxack, " Cut corners");
6339 ("-remote", Arg.String
(fun s -> rcmdpath := s),
6340 "<path> Set path to the remote commands source");
6342 ("-origin", Arg.String
(fun s -> state
.origin
<- s),
6343 "<original-path> Set original path");
6345 ("-gc", Arg.Set_string
gcconfig,
6346 "<script-path> Collect garbage with the help of a script");
6348 ("-nofc", Arg.Set
nofc, " Do not use fontconfig");
6350 ("-v", Arg.Unit
(fun () ->
6352 "%s\nconfiguration path: %s\n"
6356 exit
0), " Print version and exit");
6358 ("-embed", Arg.Set_int
rootwid,
6359 "<window-id> Embed into window")
6362 (fun s -> state
.path <- s)
6363 ("Usage: " ^
Sys.argv
.(0) ^
" [options] some.pdf\nOptions:")
6366 then selfexec := !selfexec ^
" -wtmode";
6368 let histmode = emptystr state
.path && not
!openlast in
6370 if not
(Config.load !openlast)
6371 then dolog
"failed to load configuration";
6373 begin match !pageno with
6374 | Some
pageno -> state
.anchor <- (pageno, 0.0, 0.0)
6378 if nonemptystr
!gcconfig
6381 match Unix.socketpair
Unix.PF_UNIX
Unix.SOCK_STREAM
0 with
6382 | (exception exn
) -> error
"socketpair for gc failed: %s" @@ exntos exn
6385 match spawn
!gcconfig [(c, 0); (c, 1); (s, -1)] with
6386 | (exception exn
) -> error
"failed to execute gc script: %s" @@ exntos exn
6388 Ne.clo c @@ (fun s -> error
"failed to close gc fd %s" s);
6393 let wsfd, winw, winh
= Wsi.init
(object (self)
6394 val mutable m_clicks
= 0
6395 val mutable m_click_x
= 0
6396 val mutable m_click_y
= 0
6397 val mutable m_lastclicktime
= infinity
6399 method private cleanup =
6400 state
.roam
<- noroam
;
6401 Hashtbl.iter
(fun _ opaque -> clearmark
opaque) state
.pagemap
6402 method expose
= G.postRedisplay "expose"
6406 | Wsi.Unobscured
-> "unobscured"
6407 | Wsi.PartiallyObscured
-> "partiallyobscured"
6408 | Wsi.FullyObscured
-> "fullyobscured"
6410 vlog "visibility change %s" name
6411 method display = display ()
6412 method map mapped
= vlog "mapped %b" mapped
6413 method reshape w h =
6416 method mouse
b d x y m =
6417 if d && canselect ()
6419 (* http://blogs.msdn.com/b/oldnewthing/archive/2004/10/18/243925.aspx *)
6425 if abs
x - m_click_x
> 10
6426 || abs
y - m_click_y
> 10
6427 || abs_float
(t -. m_lastclicktime
) > 0.3
6429 m_clicks
<- m_clicks
+ 1;
6430 m_lastclicktime
<- t;
6434 G.postRedisplay "cleanup";
6435 state
.uioh <- state
.uioh#button
b d x y m;
6437 else state
.uioh <- state
.uioh#multiclick m_clicks
x y m
6442 m_lastclicktime
<- infinity
;
6443 state
.uioh <- state
.uioh#button
b d x y m
6447 state
.uioh <- state
.uioh#button
b d x y m
6450 state
.mpos
<- (x, y);
6451 state
.uioh <- state
.uioh#motion
x y
6452 method pmotion
x y =
6453 state
.mpos
<- (x, y);
6454 state
.uioh <- state
.uioh#pmotion
x y
6456 let mascm = m land (
6457 Wsi.altmask
+ Wsi.shiftmask
+ Wsi.ctrlmask
+ Wsi.metamask
6460 let x = state
.x and y = state
.y in
6462 if x != state
.x || y != state
.y then self#
cleanup
6464 match state
.keystate
with
6466 let km = k
, mascm in
6469 let modehash = state
.uioh#
modehash in
6470 try Hashtbl.find modehash km
6472 try Hashtbl.find (findkeyhash conf
"global") km
6473 with Not_found
-> KMinsrt
(k
, m)
6475 | KMinsrt
(k
, m) -> keyboard k
m
6476 | KMinsrl
l -> List.iter
(fun (k
, m) -> keyboard k
m) l
6477 | KMmulti
(l, r) -> state
.keystate
<- KSinto
(l, r)
6479 | KSinto
((k'
, m'
) :: [], insrt
) when k'
=k
&& m'
land mascm = m'
->
6480 List.iter
(fun (k
, m) -> keyboard k
m) insrt
;
6481 state
.keystate
<- KSnone
6482 | KSinto
((k'
, m'
) :: keys, insrt
) when k'
=k
&& m'
land mascm = m'
->
6483 state
.keystate
<- KSinto
(keys, insrt
)
6484 | KSinto
_ -> state
.keystate
<- KSnone
6487 state
.mpos
<- (x, y);
6488 state
.uioh <- state
.uioh#pmotion
x y
6489 method leave = state
.mpos
<- (-1, -1)
6490 method winstate wsl
= state
.winstate
<- wsl
6491 method quit
= raise Quit
6492 end) !rootwid conf
.cwinw conf
.cwinh platform
in
6494 setbgcol conf
.bgcolor
;
6498 List.exists
GlMisc.check_extension
6499 [ "GL_ARB_texture_rectangle"
6500 ; "GL_EXT_texture_recangle"
6501 ; "GL_NV_texture_rectangle" ]
6503 then (dolog
"OpenGL does not suppport rectangular textures"; exit
1);
6506 let r = GlMisc.get_string `renderer
in
6507 let p = "Mesa DRI Intel(" in
6508 let l = String.length
p in
6509 String.length
r > l && String.sub
r 0 l = p
6512 defconf
.sliceheight
<- 1024;
6513 defconf
.texcount
<- 32;
6514 defconf
.usepbo
<- true;
6518 match Unix.socketpair
Unix.PF_UNIX
Unix.SOCK_STREAM
0 with
6519 | (exception exn
) ->
6520 dolog
"socketpair failed: %s" @@ exntos exn
;
6528 setcheckers conf
.checkers
;
6530 opengl_has_pbo := GlMisc.check_extension
"GL_ARB_pixel_buffer_object";
6533 conf
.angle
, conf
.fitmodel
, (conf
.trimmargins
, conf
.trimfuzz
),
6534 conf
.texcount
, conf
.sliceheight
, conf
.mustoresize
, conf
.colorspace
,
6535 !Config.fontpath
, !trimcachepath,
6539 List.iter
GlArray.enable
[`texture_coord
; `vertex
];
6541 reshape ~firsttime
:true winw winh
;
6545 Wsi.settitle
"llpp (history)";
6549 state
.text <- "Opening " ^
(mbtoutf8 state
.path);
6550 opendoc state
.path state
.password;
6554 Wsi.setcursor
Wsi.CURSOR_INHERIT
;
6555 Sys.set_signal
Sys.sighup
(Sys.Signal_handle
(fun _ -> reload ()));
6558 match Unix.waitpid
[Unix.WNOHANG
] ~
-1 with
6559 | (exception (Unix.Unix_error
(Unix.ECHILD
, _, _))) -> ()
6560 | (exception exn
) -> dolog
"Unix.waitpid: %s" @@ exntos exn
6562 | _pid
, _status
-> reap ()
6564 Sys.set_signal
Sys.sigchld
(Sys.Signal_handle
(fun _ -> doreap := true));
6568 if nonemptystr
!rcmdpath
6569 then remoteopen !rcmdpath
6574 let rec loop deadline
=
6580 let r = [state
.ss; state
.wsfd] in
6584 | Some fd
-> fd
:: r
6588 state
.redisplay
<- false;
6595 if deadline
= infinity
6597 else max
0.0 (deadline
-. now)
6602 try Unix.select
r [] [] timeout
6603 with Unix.Unix_error
(Unix.EINTR
, _, _) -> [], [], []
6609 if state
.ghyll
== noghyll
6611 match state
.autoscroll
with
6612 | Some step
when step
!= 0 ->
6613 let y = state
.y + step
in
6614 let fy = if conf
.maxhfit
then state
.winh
else 0 in
6617 then state
.maxy - fy
6618 else if y >= state
.maxy - fy then 0 else y
6620 if state
.mode = View
6621 then gotoy_and_clear_text y
6625 else deadline
+. 0.01
6630 let rec checkfds = function
6632 | fd
:: rest
when fd
= state
.ss ->
6633 let cmd = rcmd state
.ss in
6637 | fd
:: rest
when fd
= state
.wsfd ->
6641 | fd
:: rest
when Some fd
= !optrfd ->
6642 begin match remote fd
with
6643 | None
-> optrfd := remoteopen !rcmdpath;
6644 | opt -> optrfd := opt
6649 dolog
"select returned unknown descriptor";
6655 if deadline
= infinity
6659 match state
.autoscroll
with
6660 | Some step
when step
!= 0 -> deadline1
6661 | _ -> if state
.ghyll
== noghyll
then infinity
else deadline1
6669 Config.save leavebirdseye;
6670 if hasunsavedchanges
()