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 exn
->
2227 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exn
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 exn
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 exn
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 exn
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 exn
2279 TEswitch
("thumbnail width: ", E.s, None
, intentry, ondone, true)
2283 match int_of_string
s with
2284 | angle
-> reqlayout angle conf
.fitmodel
2287 Printf.sprintf
"bad integer `%s': %s" s @@ exntos exn
2289 TEswitch
("rotation: ", E.s, None
, intentry, ondone, true)
2292 conf
.icase
<- not conf
.icase
;
2293 TEdone
("case insensitive search " ^
(btos conf
.icase
))
2296 conf
.preload <- not conf
.preload;
2298 TEdone
("preload " ^
(btos conf
.preload))
2301 conf
.verbose
<- not conf
.verbose
;
2302 TEdone
("verbose " ^
(btos conf
.verbose
))
2305 conf
.debug
<- not conf
.debug
;
2306 TEdone
("debug " ^
(btos conf
.debug
))
2309 conf
.maxhfit
<- not conf
.maxhfit
;
2310 state
.maxy
<- calcheight
();
2311 TEdone
("maxhfit " ^
(btos conf
.maxhfit
))
2314 conf
.crophack
<- not conf
.crophack
;
2315 TEdone
("crophack " ^
btos conf
.crophack
)
2319 match conf
.maxwait
with
2321 conf
.maxwait
<- Some infinity
;
2322 "always wait for page to complete"
2324 conf
.maxwait
<- None
;
2325 "show placeholder if page is not ready"
2330 conf
.underinfo
<- not conf
.underinfo
;
2331 TEdone
("underinfo " ^
btos conf
.underinfo
)
2334 conf
.savebmarks
<- not conf
.savebmarks
;
2335 TEdone
("persistent bookmarks " ^
btos conf
.savebmarks
)
2341 match state
.layout with
2346 conf
.interpagespace
<- int_of_string
s;
2347 docolumns conf
.columns
;
2348 state
.maxy
<- calcheight
();
2349 let y = getpagey
pageno in
2352 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exn
2354 TEswitch
("vertical margin: ", E.s, None
, intentry, ondone, true)
2358 match conf
.fitmodel
with
2359 | FitProportional
-> FitWidth
2360 | FitWidth
| FitPage
-> FitProportional
2362 reqlayout conf
.angle
fm;
2363 TEdone
("proportional display " ^
btos (fm == FitProportional
))
2366 settrim (not conf
.trimmargins
) conf
.trimfuzz
;
2367 TEdone
("trim margins " ^
btos conf
.trimmargins
)
2370 conf
.invert
<- not conf
.invert
;
2371 TEdone
("invert colors " ^
btos conf
.invert
)
2375 cbput state
.hists
.sel
s;
2378 TEswitch
("selection command: ", E.s, Some
(onhist state
.hists
.sel
),
2379 textentry, ondone, true)
2383 then conf
.pax
<- Some
(ref (0.0, 0, 0))
2384 else conf
.pax
<- None
;
2385 TEdone
("PAX " ^
btos (conf
.pax
!= None
))
2388 state
.text <- Printf.sprintf
"bad option %d `%c'" key c;
2394 class type lvsource
= object
2395 method getitemcount
: int
2396 method getitem
: int -> (string * int)
2397 method hasaction
: int -> bool
2405 method getactive
: int
2406 method getfirst
: int
2408 method getminfo
: (int * int) array
2411 class virtual lvsourcebase
= object
2412 val mutable m_active
= 0
2413 val mutable m_first
= 0
2414 val mutable m_pan
= 0
2415 method getactive
= m_active
2416 method getfirst
= m_first
2417 method getpan
= m_pan
2418 method getminfo
: (int * int) array
= E.a
2421 let textentrykeyboard
2422 key _mask
((c, text, opthist
, onkey
, ondone, cancelonempty
), onleave
) =
2424 let key = Wsi.keypadtodigitkey
key in
2426 state
.mode
<- Textentry
(te
, onleave
);
2428 G.postRedisplay "textentrykeyboard enttext";
2430 let histaction cmd
=
2433 | Some
(action, _) ->
2434 state
.mode
<- Textentry
(
2435 (c, action cmd
, opthist
, onkey
, ondone, cancelonempty
), onleave
2437 G.postRedisplay "textentry histaction"
2441 if emptystr
text && cancelonempty
2444 G.postRedisplay "textentrykeyboard after cancel";
2447 let s = withoutlastutf8
text in
2448 enttext (c, s, opthist
, onkey
, ondone, cancelonempty
)
2450 | @enter
| @kpenter
->
2453 G.postRedisplay "textentrykeyboard after confirm"
2455 | @up
| @kpup
-> histaction HCprev
2456 | @down
| @kpdown
-> histaction HCnext
2457 | @home
| @kphome
-> histaction HCfirst
2458 | @jend
| @kpend
-> histaction HClast
2463 begin match opthist
with
2465 | Some
(_, onhistcancel
) -> onhistcancel
()
2469 G.postRedisplay "textentrykeyboard after cancel2"
2472 enttext (c, E.s, opthist
, onkey
, ondone, cancelonempty
)
2475 | @delete
| @kpdelete
-> ()
2477 | _ when key != 0 && not
(Wsi.isspecialkey
key) ->
2478 begin match onkey
text key with
2482 G.postRedisplay "textentrykeyboard after confirm2";
2485 enttext (c, text, opthist
, onkey
, ondone, cancelonempty
);
2489 G.postRedisplay "textentrykeyboard after cancel3"
2492 state
.mode
<- Textentry
(te
, onleave
);
2493 G.postRedisplay "textentrykeyboard switch";
2497 vlog "unhandled key %s" (Wsi.keyname
key)
2500 let firstof first active
=
2501 if first
> active
|| abs
(first
- active
) > fstate
.maxrows
- 1
2502 then max
0 (active
- (fstate
.maxrows
/2))
2506 let calcfirst first active
=
2509 let rows = active
- first
in
2510 if rows > fstate
.maxrows
then active
- fstate
.maxrows
else first
2514 let scrollph y maxy
=
2515 let sh = float (maxy
+ state
.winh
) /. float state
.winh
in
2516 let sh = float state
.winh
/. sh in
2517 let sh = max
sh (float conf
.scrollh
) in
2519 let percent = float y /. float maxy
in
2520 let position = (float state
.winh
-. sh) *. percent in
2523 if position +. sh > float state
.winh
2524 then float state
.winh
-. sh
2530 let adderrmsg src msg
=
2531 Buffer.add_string state
.errmsgs msg
;
2532 state
.newerrmsgs
<- true;
2536 let adderrfmt src fmt
=
2537 Format.ksprintf
(fun s -> adderrmsg src
s) fmt
;
2540 let coe s = (s :> uioh
);;
2542 class listview ~zebra ~helpmode ~
(source
:lvsource
) ~trusted ~modehash
=
2544 val m_pan
= source#getpan
2545 val m_first
= source#getfirst
2546 val m_active
= source#getactive
2548 val m_prev_uioh
= state
.uioh
2550 method private elemunder
y =
2554 let n = y / (fstate
.fontsize
+1) in
2555 if m_first
+ n < source#getitemcount
2557 if source#hasaction
(m_first
+ n)
2558 then Some
(m_first
+ n)
2565 GlFunc.blend_func ~src
:`src_alpha ~dst
:`one_minus_src_alpha
;
2566 GlDraw.color (0., 0., 0.) ~alpha
:0.85;
2567 filledrect 0. 0. (float state
.winw
) (float state
.winh
);
2568 GlDraw.color (1., 1., 1.);
2569 Gl.enable `texture_2d
;
2570 let fs = fstate
.fontsize
in
2572 let hw = (wadjsb () + xadjsb () + state
.winw
)/3 in
2573 let ww = fstate
.wwidth
in
2574 let tabw = 17.0*.ww in
2575 let itemcount = source#getitemcount
in
2576 let minfo = source#getminfo
in
2579 then float (xadjsb ()), float (state
.winw
- 1)
2580 else 0.0, float (state
.winw
- conf
.scrollbw
- 1)
2582 let xadj = xadjsb () in
2584 if (row - m_first
) > fstate
.maxrows
2587 if row >= 0 && row < itemcount
2589 let (s, level
) = source#getitem
row in
2590 let y = (row - m_first
) * nfs in
2592 (if conf
.leftscroll
then float xadj else 5.0)
2593 +. (float (level
+ m_pan
)) *. ww in
2596 (let c = if row land 1 = 0 then 1.0 else 0.92 in (c,c,c));
2600 Gl.disable `texture_2d
;
2601 let alpha = if source#hasaction
row then 0.9 else 0.3 in
2602 GlDraw.color (1., 1., 1.) ~
alpha;
2603 linerect (x0 +. 1.) (float (y + 1)) (x1) (float (y + fs + 3));
2604 Gl.enable `texture_2d
;
2607 if zebra
&& row land 1 = 1
2611 GlDraw.color (c,c,c);
2612 let drawtabularstring s =
2614 let x'
= truncate
(x0 +. x) in
2615 let pos = nindex
s '
\000'
in
2617 then drawstring1 fs x'
(y+nfs) s
2619 let s1 = String.sub
s 0 pos
2620 and s2
= String.sub
s (pos+1) (String.length
s - pos - 1) in
2625 let s'
= withoutlastutf8
s in
2626 let s = s' ^
"@Uellipsis" in
2627 let w = measurestr
fs s in
2628 if float x'
+. w +. ww < float (hw + x'
)
2633 if float x'
+. ww +. measurestr
fs s1 > float (hw + x'
)
2637 ignore
(drawstring1 fs x'
(y+nfs) s1);
2638 drawstring1 fs (hw + x'
) (y+nfs) s2
2642 let x = if helpmode
&& row > 0 then x +. ww else x in
2643 let tabpos = nindex
s '
\t'
in
2646 let len = String.length
s - tabpos - 1 in
2647 let s1 = String.sub
s 0 tabpos
2648 and s2
= String.sub
s (tabpos + 1) len in
2649 let nx = drawstr x s1 in
2651 let x = x +. (max
tabw sw) in
2654 let len = String.length
s - 2 in
2655 if len > 0 && s.[0] = '
\xc2'
&& s.[1] = '
\xb7'
2657 let s = String.sub
s 2 len in
2658 let x = if not helpmode
then x +. ww else x in
2659 GlDraw.color (1.2, 1.2, 1.2);
2660 let vinc = drawstring1 (fs+fs/4)
2661 (truncate
(x -. ww)) (y+nfs) s in
2662 GlDraw.color (1., 1., 1.);
2663 vinc +. (float fs *. 0.8)
2669 ignore
(drawtabularstring s);
2675 GlDraw.color (1.0, 1.0, 1.0) ~
alpha:0.5;
2676 let xadj = float (xadjsb () + 5) in
2678 if (row - m_first
) > fstate
.maxrows
2681 if row >= 0 && row < itemcount
2683 let (s, level
) = source#getitem
row in
2684 let pos0 = nindex
s '
\000'
in
2685 let y = (row - m_first
) * nfs in
2686 let x = float (level
+ m_pan
) *. ww in
2687 let (first
, last
) = minfo.(row) in
2689 if pos0 > 0 && first
> pos0
2690 then String.sub
s (pos0+1) (first
-pos0-1)
2691 else String.sub
s 0 first
2693 let suffix = String.sub
s first
(last
- first
) in
2694 let w1 = measurestr fstate
.fontsize
prefix in
2695 let w2 = measurestr fstate
.fontsize
suffix in
2696 let x = x +. if conf
.leftscroll
then xadj else 5.0 in
2697 let x = if pos0 > 0 && first
> pos0 then x +. float hw else x in
2699 and y0 = float (y+2) in
2701 and y1 = float (y+fs+3) in
2702 filledrect x0 y0 x1 y1;
2707 Gl.disable `texture_2d
;
2708 if Array.length
minfo > 0 then loop m_first
;
2711 method updownlevel incr
=
2712 let len = source#getitemcount
in
2714 if m_active
>= 0 && m_active
< len
2715 then snd
(source#getitem m_active
)
2719 if i
= len then i
-1 else if i
= -1 then 0 else
2720 let _, l = source#getitem i
in
2721 if l != curlevel then i
else flow (i
+incr
)
2723 let active = flow m_active
in
2724 let first = calcfirst m_first
active in
2725 G.postRedisplay "outline updownlevel";
2726 {< m_active
= active; m_first
= first >}
2728 method private key1
key mask
=
2729 let set1 active first qsearch
=
2730 coe {< m_active
= active; m_first
= first; m_qsearch
= qsearch
>}
2732 let search active pattern incr
=
2733 let active = if active = -1 then m_first
else active in
2736 if n >= 0 && n < source#getitemcount
2738 let s, _ = source#getitem
n in
2739 match Str.search_forward re
s 0 with
2740 | (exception Not_found
) -> loop (n + incr
)
2747 let qpat = Str.quote pattern
in
2748 match Str.regexp_case_fold
qpat with
2751 adderrfmt "listview key1" "regexp_case_fold for `%S' failed: %S\n"
2752 qpat @@ Printexc.to_string exn
;
2755 let itemcount = source#getitemcount
in
2756 let find start incr
=
2758 if i
= -1 || i
= itemcount
2761 if source#hasaction i
2763 else find (i
+ incr
)
2768 let set active first =
2769 let first = bound
first 0 (itemcount - fstate
.maxrows
) in
2771 coe {< m_active
= active; m_first
= first; m_qsearch
= E.s >}
2774 let isvisible first n = n >= first && n - first <= fstate
.maxrows
in
2776 let incr1 = if incr
> 0 then 1 else -1 in
2777 if isvisible m_first m_active
2780 let next = m_active
+ incr
in
2782 if next < 0 || next >= itemcount
2784 else find next incr1
2786 if abs
(m_active
- next) > fstate
.maxrows
2792 let first = m_first
+ incr
in
2793 let first = bound
first 0 (itemcount - fstate
.maxrows
) in
2795 let next = m_active
+ incr
in
2796 let next = bound
next 0 (itemcount - 1) in
2803 if isvisible first next
2810 let first = min
next m_first
in
2812 if abs
(next - first) > fstate
.maxrows
2818 let first = m_first
+ incr
in
2819 let first = bound
first 0 (itemcount - 1) in
2821 let next = m_active
+ incr
in
2822 let next = bound
next 0 (itemcount - 1) in
2823 let next = find next incr1 in
2825 if next = -1 || abs
(m_active
- first) > fstate
.maxrows
2827 let active = if m_active
= -1 then next else m_active
in
2832 if isvisible first active
2838 G.postRedisplay "listview navigate";
2842 | (@r
|@s) when Wsi.withctrl mask
->
2843 let incr = if key = @r
then -1 else 1 in
2845 match search (m_active
+ incr) m_qsearch
incr with
2847 state
.text <- m_qsearch ^
" [not found]";
2850 state
.text <- m_qsearch
;
2851 active, firstof m_first
active
2853 G.postRedisplay "listview ctrl-r/s";
2854 set1 active first m_qsearch
;
2856 | @insert
when Wsi.withctrl mask
->
2857 if m_active
>= 0 && m_active
< source#getitemcount
2859 let s, _ = source#getitem m_active
in
2865 if emptystr m_qsearch
2868 let qsearch = withoutlastutf8 m_qsearch
in
2872 G.postRedisplay "listview empty qsearch";
2873 set1 m_active m_first
E.s;
2877 match search m_active
qsearch ~
-1 with
2879 state
.text <- qsearch ^
" [not found]";
2882 state
.text <- qsearch;
2883 active, firstof m_first
active
2885 G.postRedisplay "listview backspace qsearch";
2886 set1 active first qsearch
2889 | key when (key != 0 && not
(Wsi.isspecialkey
key)) ->
2890 let pattern = m_qsearch ^ toutf8
key in
2892 match search m_active
pattern 1 with
2894 state
.text <- pattern ^
" [not found]";
2897 state
.text <- pattern;
2898 active, firstof m_first
active
2900 G.postRedisplay "listview qsearch add";
2901 set1 active first pattern;
2905 if emptystr m_qsearch
2907 G.postRedisplay "list view escape";
2908 let mx, my
= state
.mpos
in
2912 source#exit ~uioh
:(coe self
)
2913 ~cancel
:true ~
active:m_active ~
first:m_first ~pan
:m_pan
2915 | None
-> m_prev_uioh
2920 G.postRedisplay "list view kill qsearch";
2921 coe {< m_qsearch
= E.s >}
2924 | @enter
| @kpenter
->
2926 let self = {< m_qsearch
= E.s >} in
2928 G.postRedisplay "listview enter";
2929 if m_active
>= 0 && m_active
< source#getitemcount
2931 source#exit ~uioh
:(coe self) ~cancel
:false
2932 ~
active:m_active ~
first:m_first ~pan
:m_pan
;
2935 source#exit ~uioh
:(coe self) ~cancel
:true
2936 ~
active:m_active ~
first:m_first ~pan
:m_pan
;
2939 begin match opt with
2940 | None
-> m_prev_uioh
2944 | @delete
| @kpdelete
->
2947 | @up
| @kpup
-> navigate ~
-1
2948 | @down
| @kpdown
-> navigate 1
2949 | @prior
| @kpprior
-> navigate ~
-(fstate
.maxrows
)
2950 | @next | @kpnext
-> navigate fstate
.maxrows
2952 | @right
| @kpright
->
2954 G.postRedisplay "listview right";
2955 coe {< m_pan
= m_pan
- 1 >}
2957 | @left | @kpleft
->
2959 G.postRedisplay "listview left";
2960 coe {< m_pan
= m_pan
+ 1 >}
2962 | @home
| @kphome
->
2963 let active = find 0 1 in
2964 G.postRedisplay "listview home";
2968 let first = max
0 (itemcount - fstate
.maxrows
) in
2969 let active = find (itemcount - 1) ~
-1 in
2970 G.postRedisplay "listview end";
2973 | key when (key = 0 || Wsi.isspecialkey
key) ->
2977 dolog
"listview unknown key %#x" key; coe self
2979 method key key mask
=
2980 match state
.mode
with
2981 | Textentry te
-> textentrykeyboard key mask te
; coe self
2984 | LinkNav
_ -> self#key1
key mask
2986 method button button down
x y _ =
2989 | 1 when vscrollhit x ->
2990 G.postRedisplay "listview scroll";
2993 let _, position, sh = self#
scrollph in
2994 if y > truncate
position && y < truncate
(position +. sh)
2996 state
.mstate
<- Mscrolly
;
3000 let s = float (max
0 (y - conf
.scrollh
)) /. float state
.winh
in
3001 let first = truncate
(s *. float source#getitemcount
) in
3002 let first = min source#getitemcount
first in
3003 Some
(coe {< m_first
= first; m_active
= first >})
3005 state
.mstate
<- Mnone
;
3009 begin match self#elemunder
y with
3011 G.postRedisplay "listview click";
3012 source#exit ~uioh
:(coe {< m_active
= n >})
3013 ~cancel
:false ~
active:n ~
first:m_first ~pan
:m_pan
3017 | n when (n == 4 || n == 5) && not down
->
3018 let len = source#getitemcount
in
3020 if n = 5 && m_first
+ fstate
.maxrows
>= len
3024 let first = m_first
+ (if n == 4 then -1 else 1) in
3025 bound
first 0 (len - 1)
3027 G.postRedisplay "listview wheel";
3028 Some
(coe {< m_first
= first >})
3029 | n when (n = 6 || n = 7) && not down
->
3030 let inc = if n = 7 then -1 else 1 in
3031 G.postRedisplay "listview hwheel";
3032 Some
(coe {< m_pan
= m_pan
+ inc >})
3037 | None
-> m_prev_uioh
3040 method multiclick
_ x y = self#button
1 true x y
3043 match state
.mstate
with
3045 let s = float (max
0 (y - conf
.scrollh
)) /. float state
.winh
in
3046 let first = truncate
(s *. float source#getitemcount
) in
3047 let first = min source#getitemcount
first in
3048 G.postRedisplay "listview motion";
3049 coe {< m_first
= first; m_active
= first >}
3057 method pmotion
x y =
3058 if x < state
.winw
- conf
.scrollbw
3061 match self#elemunder
y with
3062 | None
-> Wsi.setcursor
Wsi.CURSOR_INHERIT
; m_active
3063 | Some
n -> Wsi.setcursor
Wsi.CURSOR_INFO
; n
3067 then (G.postRedisplay "listview pmotion"; {< m_active
= n >})
3072 Wsi.setcursor
Wsi.CURSOR_INHERIT
;
3076 method infochanged
_ = ()
3078 method scrollpw
= (0, 0.0, 0.0)
3080 let nfs = fstate
.fontsize
+ 1 in
3081 let y = m_first
* nfs in
3082 let itemcount = source#getitemcount
in
3083 let maxi = max
0 (itemcount - fstate
.maxrows
) in
3084 let maxy = maxi * nfs in
3085 let p, h = scrollph y maxy in
3088 method modehash
= modehash
3089 method eformsgs
= false
3090 method alwaysscrolly
= true
3093 class outlinelistview ~zebra ~source
=
3094 let settext autonarrow
s =
3097 let ss = source#statestr
in
3101 else "{" ^
ss ^
"} [" ^
s ^
"]"
3102 else state
.text <- s
3108 ~source
:(source
:> lvsource
)
3110 ~modehash
:(findkeyhash conf
"outline")
3113 val m_autonarrow
= false
3115 method! key key mask
=
3117 if emptystr state
.text
3119 else fstate
.maxrows - 2
3121 let calcfirst first active =
3124 let rows = active - first in
3125 if rows > maxrows then active - maxrows else first
3129 let active = m_active
+ incr in
3130 let active = bound
active 0 (source#getitemcount
- 1) in
3131 let first = calcfirst m_first
active in
3132 G.postRedisplay "outline navigate";
3133 coe {< m_active
= active; m_first
= first >}
3135 let navscroll first =
3137 let dist = m_active
- first in
3143 else first + maxrows
3146 G.postRedisplay "outline navscroll";
3147 coe {< m_first
= first; m_active
= active >}
3149 let ctrl = Wsi.withctrl mask
in
3154 then (source#denarrow
; E.s)
3156 let pattern = source#renarrow
in
3157 if nonemptystr m_qsearch
3158 then (source#narrow m_qsearch
; m_qsearch
)
3162 settext (not m_autonarrow
) text;
3163 G.postRedisplay "toggle auto narrowing";
3164 coe {< m_first
= 0; m_active
= 0; m_autonarrow
= not m_autonarrow
>}
3166 | @slash
when emptystr m_qsearch
&& not m_autonarrow
->
3168 G.postRedisplay "toggle auto narrowing";
3169 coe {< m_first
= 0; m_active
= 0; m_autonarrow
= true >}
3172 source#narrow m_qsearch
;
3174 then source#add_narrow_pattern m_qsearch
;
3175 G.postRedisplay "outline ctrl-n";
3176 coe {< m_first
= 0; m_active
= 0 >}
3179 let active = source#calcactive
(getanchor
()) in
3180 let first = firstof m_first
active in
3181 G.postRedisplay "outline ctrl-s";
3182 coe {< m_first
= first; m_active
= active >}
3185 G.postRedisplay "outline ctrl-u";
3186 if m_autonarrow
&& nonemptystr m_qsearch
3188 ignore
(source#renarrow
);
3189 settext m_autonarrow
E.s;
3190 coe {< m_first
= 0; m_active
= 0; m_qsearch
= E.s >}
3193 source#del_narrow_pattern
;
3194 let pattern = source#renarrow
in
3196 if emptystr
pattern then E.s else "Narrowed to " ^
pattern
3198 settext m_autonarrow
text;
3199 coe {< m_first
= 0; m_active
= 0; m_qsearch
= E.s >}
3203 let first = max
0 (m_active
- (fstate
.maxrows / 2)) in
3204 G.postRedisplay "outline ctrl-l";
3205 coe {< m_first
= first >}
3207 | @tab
when m_autonarrow
->
3208 if nonemptystr m_qsearch
3210 G.postRedisplay "outline list view tab";
3211 source#add_narrow_pattern m_qsearch
;
3213 coe {< m_qsearch
= E.s >}
3217 | @escape
when m_autonarrow
->
3218 if nonemptystr m_qsearch
3219 then source#add_narrow_pattern m_qsearch
;
3222 | @enter
| @kpenter
when m_autonarrow
->
3223 if nonemptystr m_qsearch
3224 then source#add_narrow_pattern m_qsearch
;
3227 | key when m_autonarrow
&& (not
(Wsi.isspecialkey
key)) ->
3228 let pattern = m_qsearch ^ toutf8
key in
3229 G.postRedisplay "outlinelistview autonarrow add";
3230 source#narrow
pattern;
3231 settext true pattern;
3232 coe {< m_first
= 0; m_active
= 0; m_qsearch
= pattern >}
3234 | key when m_autonarrow
&& key = @backspace
->
3235 if emptystr m_qsearch
3238 let pattern = withoutlastutf8 m_qsearch
in
3239 G.postRedisplay "outlinelistview autonarrow backspace";
3240 ignore
(source#renarrow
);
3241 source#narrow
pattern;
3242 settext true pattern;
3243 coe {< m_first
= 0; m_active
= 0; m_qsearch
= pattern >}
3245 | @up
| @kpup
when ctrl ->
3246 navscroll (max
0 (m_first
- 1))
3248 | @down
| @kpdown
when ctrl ->
3249 navscroll (min
(source#getitemcount
- 1) (m_first
+ 1))
3251 | @up
| @kpup
-> navigate ~
-1
3252 | @down
| @kpdown
-> navigate 1
3253 | @prior
| @kpprior
-> navigate ~
-(fstate
.maxrows)
3254 | @next | @kpnext
-> navigate fstate
.maxrows
3256 | @right
| @kpright
->
3260 G.postRedisplay "outline ctrl right";
3261 {< m_pan
= m_pan
+ 1 >}
3263 else self#updownlevel
1
3267 | @left | @kpleft
->
3271 G.postRedisplay "outline ctrl left";
3272 {< m_pan
= m_pan
- 1 >}
3274 else self#updownlevel ~
-1
3278 | @home
| @kphome
->
3279 G.postRedisplay "outline home";
3280 coe {< m_first
= 0; m_active
= 0 >}
3283 let active = source#getitemcount
- 1 in
3284 let first = max
0 (active - fstate
.maxrows) in
3285 G.postRedisplay "outline end";
3286 coe {< m_active
= active; m_first
= first >}
3288 | _ -> super#
key key mask
3291 let genhistoutlines () =
3293 |> List.sort
(fun (_, c1
, _, _, _, _) (_, c2
, _, _, _, _) ->
3294 compare c2
.lastvisit c1
.lastvisit
)
3296 (fun ((path
, c, _, _, _, origin
) as hist
) ->
3297 let path = if nonemptystr origin
then origin
else path in
3298 let base = mbtoutf8
@@ Filename.basename
path in
3299 (base ^
"\000" ^
c.title
, 1, Ohistory hist
)
3304 let gotohist (path, c, bookmarks
, x, anchor, origin
) =
3305 Config.save
leavebirdseye;
3306 state
.anchor <- anchor;
3307 state
.bookmarks
<- bookmarks
;
3308 state
.origin
<- origin
;
3311 let x0, y0, x1, y1 = conf
.trimfuzz
in
3312 wcmd "trimset %d %d %d %d %d" (btod conf
.trimmargins
) x0 y0 x1 y1;
3313 reshape ~firsttime
:true state
.winw state
.winh
;
3314 opendoc path origin
;
3318 let makecheckers () =
3319 (* Based on lablGL-1.04/LablGlut/examples/lablGL/checker.ml which had
3321 converted by Issac Trotts. July 25, 2002 *)
3322 let image = GlPix.create `ubyte ~format
:`luminance ~width
:2 ~height
:2 in
3323 Raw.sets_string
(GlPix.to_raw
image) ~
pos:0 "\255\200\200\255";
3324 let id = GlTex.gen_texture
() in
3325 GlTex.bind_texture ~target
:`texture_2d
id;
3326 GlPix.store
(`unpack_alignment
1);
3327 GlTex.image2d
image;
3328 List.iter
(GlTex.parameter ~target
:`texture_2d
)
3329 [ `mag_filter `nearest
; `min_filter `nearest
];
3333 let setcheckers enabled
=
3334 match state
.checkerstexid
with
3336 if enabled
then state
.checkerstexid
<- Some
(makecheckers ())
3338 | Some checkerstexid
->
3341 GlTex.delete_texture checkerstexid
;
3342 state
.checkerstexid
<- None
;
3346 let describe_location () =
3347 let fn = page_of_y state
.y in
3348 let ln = page_of_y
(state
.y + state
.winh
- hscrollh () - 1) in
3349 let maxy = state
.maxy - (if conf
.maxhfit
then state
.winh
else 0) in
3353 else (100. *. (float state
.y /. float maxy))
3357 Printf.sprintf
"page %d of %d [%.2f%%]"
3358 (fn+1) state
.pagecount
percent
3361 "pages %d-%d of %d [%.2f%%]"
3362 (fn+1) (ln+1) state
.pagecount
percent
3365 let setpresentationmode v
=
3366 let n = page_of_y state
.y in
3367 state
.anchor <- (n, 0.0, 1.0);
3368 conf
.presentation
<- v
;
3369 if conf
.fitmodel
= FitPage
3370 then reqlayout conf
.angle conf
.fitmodel
;
3374 let setbgcol (r
, g, b) =
3376 let r = r *. 255.0 |> truncate
3377 and g = g *. 255.0 |> truncate
3378 and b = b *. 255.0 |> truncate
in
3379 r lsl 16 |> (lor) (g lsl 8) |> (lor) b
3381 Wsi.setwinbgcol
col;
3385 let btos b = if b then "@Uradical" else E.s in
3386 let showextended = ref false in
3387 let leave mode
_ = state
.mode
<- mode
in
3390 val mutable m_l
= []
3391 val mutable m_a
= E.a
3392 val mutable m_prev_uioh
= nouioh
3393 val mutable m_prev_mode
= View
3395 inherit lvsourcebase
3397 method reset prev_mode prev_uioh
=
3398 m_a
<- Array.of_list
(List.rev m_l
);
3400 m_prev_mode
<- prev_mode
;
3401 m_prev_uioh
<- prev_uioh
;
3403 method int name get
set =
3405 (name
, `
int get
, 1, Action
(
3408 try set (int_of_string
s)
3410 state
.text <- Printf.sprintf
"bad integer `%s': %s"
3414 let te = name ^
": ", E.s, None
, intentry, ondone, true in
3415 state
.mode
<- Textentry
(te, leave m_prev_mode
);
3419 method int_with_suffix name get
set =
3421 (name
, `intws get
, 1, Action
(
3424 try set (int_of_string_with_suffix
s)
3426 state
.text <- Printf.sprintf
"bad integer `%s': %s"
3431 name ^
": ", E.s, None
, intentry_with_suffix, ondone, true
3433 state
.mode
<- Textentry
(te, leave m_prev_mode
);
3437 method bool ?
(offset
=1) ?
(btos=btos) name get
set =
3439 (name
, `
bool (btos, get
), offset
, Action
(
3446 method color name get
set =
3448 (name
, `
color get
, 1, Action
(
3450 let invalid = (nan
, nan
, nan
) in
3453 try color_of_string
s
3455 state
.text <- Printf.sprintf
"bad color `%s': %s"
3462 let te = name ^
": ", E.s, None
, textentry, ondone, true in
3463 state
.text <- color_to_string
(get
());
3464 state
.mode
<- Textentry
(te, leave m_prev_mode
);
3468 method string name get
set =
3470 (name
, `
string get
, 1, Action
(
3472 let ondone s = set s in
3473 let te = name ^
": ", E.s, None
, textentry, ondone, true in
3474 state
.mode
<- Textentry
(te, leave m_prev_mode
);
3478 method colorspace name get
set =
3480 (name
, `
string get
, 1, Action
(
3484 inherit lvsourcebase
3487 m_active
<- CSTE.to_int conf
.colorspace
;
3490 method getitemcount
=
3491 Array.length
CSTE.names
3494 method exit ~uioh ~cancel ~
active ~
first ~pan
=
3495 ignore
(uioh
, first, pan
);
3496 if not cancel
then set active;
3498 method hasaction
_ = true
3502 let modehash = findkeyhash conf
"info" in
3503 coe (new listview ~zebra
:false ~helpmode
:false
3504 ~
source ~trusted
:true ~
modehash)
3507 method paxmark name get
set =
3509 (name
, `
string get
, 1, Action
(
3513 inherit lvsourcebase
3516 m_active
<- MTE.to_int conf
.paxmark
;
3519 method getitemcount
= Array.length
MTE.names
3520 method getitem
n = (MTE.names
.(n), 0)
3521 method exit ~uioh ~cancel ~
active ~
first ~pan
=
3522 ignore
(uioh
, first, pan
);
3523 if not cancel
then set active;
3525 method hasaction
_ = true
3529 let modehash = findkeyhash conf
"info" in
3530 coe (new listview ~zebra
:false ~helpmode
:false
3531 ~
source ~trusted
:true ~
modehash)
3534 method fitmodel name get
set =
3536 (name
, `
string get
, 1, Action
(
3540 inherit lvsourcebase
3543 m_active
<- FMTE.to_int conf
.fitmodel
;
3546 method getitemcount
= Array.length
FMTE.names
3547 method getitem
n = (FMTE.names
.(n), 0)
3548 method exit ~uioh ~cancel ~
active ~
first ~pan
=
3549 ignore
(uioh
, first, pan
);
3550 if not cancel
then set active;
3552 method hasaction
_ = true
3556 let modehash = findkeyhash conf
"info" in
3557 coe (new listview ~zebra
:false ~helpmode
:false
3558 ~
source ~trusted
:true ~
modehash)
3561 method caption
s offset
=
3562 m_l
<- (s, `empty
, offset
, Noaction
) :: m_l
3564 method caption2
s f offset
=
3565 m_l
<- (s, `
string f, offset
, Noaction
) :: m_l
3567 method getitemcount
= Array.length m_a
3570 let tostr = function
3571 | `
int f -> string_of_int
(f ())
3572 | `intws
f -> string_with_suffix_of_int
(f ())
3574 | `
color f -> color_to_string
(f ())
3575 | `
bool (btos, f) -> btos (f ())
3578 let name, t
, offset
, _ = m_a
.(n) in
3579 ((let s = tostr t
in
3581 then Printf.sprintf
"%s\t%s" name s
3585 method exit ~uioh ~cancel ~
active ~
first ~pan
=
3590 match m_a
.(active) with
3591 | _, _, _, Action
f -> f uioh
3592 | _, _, _, Noaction
-> uioh
3603 method hasaction
n =
3605 | _, _, _, Action
_ -> true
3606 | _, _, _, Noaction
-> false
3608 initializer m_active
<- 1
3611 let rec fillsrc prevmode prevuioh
=
3612 let sep () = src#caption
E.s 0 in
3613 let colorp name get
set =
3615 (fun () -> color_to_string
(get
()))
3618 let c = color_of_string
v in
3621 state
.text <- Printf.sprintf
"bad color `%s': %s" v @@ exntos exn
3624 let oldmode = state
.mode
in
3625 let birdseye = isbirdseye state
.mode
in
3627 src#caption
(if birdseye then "Setup (Bird's eye)" else "Setup") 0;
3629 src#
bool "presentation mode"
3630 (fun () -> conf
.presentation
)
3631 (fun v -> setpresentationmode v);
3633 src#
bool "ignore case in searches"
3634 (fun () -> conf
.icase
)
3635 (fun v -> conf
.icase
<- v);
3638 (fun () -> conf
.preload)
3639 (fun v -> conf
.preload <- v);
3641 src#
bool "highlight links"
3642 (fun () -> conf
.hlinks
)
3643 (fun v -> conf
.hlinks
<- v);
3645 src#
bool "under info"
3646 (fun () -> conf
.underinfo
)
3647 (fun v -> conf
.underinfo
<- v);
3649 src#
bool "persistent bookmarks"
3650 (fun () -> conf
.savebmarks
)
3651 (fun v -> conf
.savebmarks
<- v);
3653 src#fitmodel
"fit model"
3654 (fun () -> FMTE.to_string conf
.fitmodel
)
3655 (fun v -> reqlayout conf
.angle
(FMTE.of_int
v));
3657 src#
bool "trim margins"
3658 (fun () -> conf
.trimmargins
)
3659 (fun v -> settrim v conf
.trimfuzz
; fillsrc prevmode prevuioh
);
3661 src#
bool "persistent location"
3662 (fun () -> conf
.jumpback
)
3663 (fun v -> conf
.jumpback
<- v);
3666 src#
int "inter-page space"
3667 (fun () -> conf
.interpagespace
)
3669 conf
.interpagespace
<- n;
3670 docolumns conf
.columns
;
3672 match state
.layout with
3677 state
.maxy <- calcheight
();
3678 let y = getpagey
pageno in
3683 (fun () -> conf
.pagebias
)
3684 (fun v -> conf
.pagebias
<- v);
3686 src#
int "scroll step"
3687 (fun () -> conf
.scrollstep
)
3688 (fun n -> conf
.scrollstep
<- n);
3690 src#
int "horizontal scroll step"
3691 (fun () -> conf
.hscrollstep
)
3692 (fun v -> conf
.hscrollstep
<- v);
3694 src#
int "auto scroll step"
3696 match state
.autoscroll
with
3698 | _ -> conf
.autoscrollstep
)
3700 let n = boundastep state
.winh
n in
3701 if state
.autoscroll
<> None
3702 then state
.autoscroll
<- Some
n;
3703 conf
.autoscrollstep
<- n);
3706 (fun () -> truncate
(conf
.zoom *. 100.))
3707 (fun v -> setzoom ((float v) /. 100.));
3710 (fun () -> conf
.angle
)
3711 (fun v -> reqlayout v conf
.fitmodel
);
3713 src#
int "scroll bar width"
3714 (fun () -> conf
.scrollbw
)
3717 reshape state
.winw state
.winh
;
3720 src#
int "scroll handle height"
3721 (fun () -> conf
.scrollh
)
3722 (fun v -> conf
.scrollh
<- v;);
3724 src#
int "thumbnail width"
3725 (fun () -> conf
.thumbw
)
3727 conf
.thumbw
<- min
4096 v;
3730 leavebirdseye beye
false;
3737 let mode = state
.mode in
3738 src#
string "columns"
3740 match conf
.columns
with
3742 | Cmulti
(multi
, _) -> multicolumns_to_string multi
3743 | Csplit
(count
, _) -> "-" ^ string_of_int count
3746 let n, a, b = multicolumns_of_string
v in
3747 setcolumns mode n a b);
3750 src#caption
"Pixmap cache" 0;
3751 src#int_with_suffix
"size (advisory)"
3752 (fun () -> conf
.memlimit
)
3753 (fun v -> conf
.memlimit
<- v);
3756 (fun () -> Printf.sprintf
"%s bytes, %d tiles"
3757 (string_with_suffix_of_int state
.memused
)
3758 (Hashtbl.length state
.tilemap
)) 1;
3761 src#caption
"Layout" 0;
3762 src#caption2
"Dimension"
3764 Printf.sprintf
"%dx%d (virtual %dx%d)"
3765 state
.winw state
.winh
3770 src#caption2
"Position" (fun () ->
3771 Printf.sprintf
"%dx%d" state
.x state
.y
3774 src#caption2
"Position" (fun () -> describe_location ()) 1
3778 src#
bool ~offset
:0 ~
btos:(fun v -> if v then "(on)" else "(off)")
3779 "Save these parameters as global defaults at exit"
3780 (fun () -> conf
.bedefault
)
3781 (fun v -> conf
.bedefault
<- v)
3785 let btos b = if b then "@Ulguillemet" else "@Urguillemet" in
3786 src#
bool ~offset
:0 ~
btos "Extended parameters"
3787 (fun () -> !showextended)
3788 (fun v -> showextended := v; fillsrc prevmode prevuioh
);
3792 (fun () -> conf
.checkers
)
3793 (fun v -> conf
.checkers
<- v; setcheckers v);
3794 src#
bool "update cursor"
3795 (fun () -> conf
.updatecurs
)
3796 (fun v -> conf
.updatecurs
<- v);
3797 src#
bool "scroll-bar on the left"
3798 (fun () -> conf
.leftscroll
)
3799 (fun v -> conf
.leftscroll
<- v);
3801 (fun () -> conf
.verbose
)
3802 (fun v -> conf
.verbose
<- v);
3803 src#
bool "invert colors"
3804 (fun () -> conf
.invert
)
3805 (fun v -> conf
.invert
<- v);
3807 (fun () -> conf
.maxhfit
)
3808 (fun v -> conf
.maxhfit
<- v);
3810 (fun () -> conf
.pax
!= None
)
3813 then conf
.pax
<- Some
(ref (now
(), 0, 0))
3814 else conf
.pax
<- None
);
3815 src#
string "uri launcher"
3816 (fun () -> conf
.urilauncher
)
3817 (fun v -> conf
.urilauncher
<- v);
3818 src#
string "path launcher"
3819 (fun () -> conf
.pathlauncher
)
3820 (fun v -> conf
.pathlauncher
<- v);
3821 src#
string "tile size"
3822 (fun () -> Printf.sprintf
"%dx%d" conf
.tilew conf
.tileh
)
3825 let w, h = Scanf.sscanf
v "%dx%d" (fun w h -> w, h) in
3826 conf
.tilew
<- max
64 w;
3827 conf
.tileh
<- max
64 h;
3830 state
.text <- Printf.sprintf
"bad tile size `%s': %s"
3833 src#
int "texture count"
3834 (fun () -> conf
.texcount
)
3837 then conf
.texcount
<- v
3838 else impmsg "failed to set texture count please retry later"
3840 src#
int "slice height"
3841 (fun () -> conf
.sliceheight
)
3843 conf
.sliceheight
<- v;
3844 wcmd "sliceh %d" conf
.sliceheight
;
3846 src#
int "anti-aliasing level"
3847 (fun () -> conf
.aalevel
)
3849 conf
.aalevel
<- bound
v 0 8;
3850 state
.anchor <- getanchor
();
3851 opendoc state
.path state
.password;
3853 src#
string "page scroll scaling factor"
3854 (fun () -> string_of_float conf
.pgscale)
3857 let s = float_of_string
v in
3860 state
.text <- Printf.sprintf
3861 "bad page scroll scaling factor `%s': %s" v @@ exntos exn
3864 src#
int "ui font size"
3865 (fun () -> fstate
.fontsize
)
3866 (fun v -> setfontsize (bound
v 5 100));
3867 src#
int "hint font size"
3868 (fun () -> conf
.hfsize
)
3869 (fun v -> conf
.hfsize
<- bound
v 5 100);
3870 colorp "background color"
3871 (fun () -> conf
.bgcolor
)
3872 (fun v -> conf
.bgcolor
<- v; setbgcol v);
3873 src#
bool "crop hack"
3874 (fun () -> conf
.crophack
)
3875 (fun v -> conf
.crophack
<- v);
3876 src#
string "trim fuzz"
3877 (fun () -> irect_to_string conf
.trimfuzz
)
3880 conf
.trimfuzz
<- irect_of_string
v;
3882 then settrim true conf
.trimfuzz
;
3884 state
.text <- Printf.sprintf
"bad irect `%s': %s" v @@ exntos exn
3886 src#
string "throttle"
3888 match conf
.maxwait
with
3889 | None
-> "show place holder if page is not ready"
3892 then "wait for page to fully render"
3894 "wait " ^ string_of_float
time
3895 ^
" seconds before showing placeholder"
3899 let f = float_of_string
v in
3901 then conf
.maxwait
<- None
3902 else conf
.maxwait
<- Some
f
3904 state
.text <- Printf.sprintf
"bad time `%s': %s" v @@ exntos exn
3906 src#
string "ghyll scroll"
3908 match conf
.ghyllscroll
with
3910 | Some nab
-> ghyllscroll_to_string nab
3913 try conf
.ghyllscroll
<- ghyllscroll_of_string
v
3916 state
.text <- Printf.sprintf
"bad ghyll `%s': %s" v msg
3918 state
.text <- Printf.sprintf
"bad ghyll `%s': %s" v @@ exntos exn
3920 src#
string "selection command"
3921 (fun () -> conf
.selcmd
)
3922 (fun v -> conf
.selcmd
<- v);
3923 src#
string "synctex command"
3924 (fun () -> conf
.stcmd
)
3925 (fun v -> conf
.stcmd
<- v);
3926 src#
string "pax command"
3927 (fun () -> conf
.paxcmd
)
3928 (fun v -> conf
.paxcmd
<- v);
3929 src#
string "ask password command"
3930 (fun () -> conf
.passcmd)
3931 (fun v -> conf
.passcmd <- v);
3932 src#
string "save path command"
3933 (fun () -> conf
.savecmd
)
3934 (fun v -> conf
.savecmd
<- v);
3935 src#colorspace
"color space"
3936 (fun () -> CSTE.to_string conf
.colorspace
)
3938 conf
.colorspace
<- CSTE.of_int
v;
3942 src#paxmark
"pax mark method"
3943 (fun () -> MTE.to_string conf
.paxmark
)
3944 (fun v -> conf
.paxmark
<- MTE.of_int
v);
3945 if bousable
() && !opengl_has_pbo
3948 (fun () -> conf
.usepbo
)
3949 (fun v -> conf
.usepbo
<- v);
3950 src#
bool "mouse wheel scrolls pages"
3951 (fun () -> conf
.wheelbypage
)
3952 (fun v -> conf
.wheelbypage
<- v);
3953 src#
bool "open remote links in a new instance"
3954 (fun () -> conf
.riani
)
3955 (fun v -> conf
.riani
<- v);
3956 src#
bool "edit annotations inline"
3957 (fun () -> conf
.annotinline
)
3958 (fun v -> conf
.annotinline
<- v);
3959 src#
bool "coarse positioning in presentation mode"
3960 (fun () -> conf
.coarseprespos
)
3961 (fun v -> conf
.coarseprespos
<- v);
3965 src#caption
"Document" 0;
3966 List.iter
(fun (_, s) -> src#caption
s 1) state
.docinfo
;
3967 src#caption2
"Pages"
3968 (fun () -> string_of_int state
.pagecount
) 1;
3969 src#caption2
"Dimensions"
3970 (fun () -> string_of_int
(List.length state
.pdims
)) 1;
3974 src#caption
"Trimmed margins" 0;
3975 src#caption2
"Dimensions"
3976 (fun () -> string_of_int
(List.length state
.pdims
)) 1;
3980 src#caption
"OpenGL" 0;
3981 src#caption
(Printf.sprintf
"Vendor\t%s" (GlMisc.get_string `vendor
)) 1;
3982 src#caption
(Printf.sprintf
"Renderer\t%s" (GlMisc.get_string `renderer
)) 1;
3985 src#caption
"Location" 0;
3986 if nonemptystr state
.origin
3987 then src#caption
("Orign\t" ^ mbtoutf8 state
.origin
) 1;
3988 src#caption
("Path\t" ^ mbtoutf8 state
.path) 1;
3990 src#reset prevmode prevuioh
;
3995 let prevmode = state
.mode
3996 and prevuioh
= state
.uioh in
3997 fillsrc prevmode prevuioh
;
3998 let source = (src :> lvsource
) in
3999 let modehash = findkeyhash conf
"info" in
4000 state
.uioh <- coe (object (self)
4001 inherit listview ~zebra
:false ~helpmode
:false
4002 ~
source ~trusted
:true ~
modehash as super
4003 val mutable m_prevmemused
= 0
4004 method! infochanged
= function
4006 if m_prevmemused
!= state
.memused
4008 m_prevmemused
<- state
.memused
;
4009 G.postRedisplay "memusedchanged";
4011 | Pdim
-> G.postRedisplay "pdimchanged"
4012 | Docinfo
-> fillsrc prevmode prevuioh
4014 method! key key mask
=
4015 if not
(Wsi.withctrl mask
)
4018 | @left | @kpleft
-> coe (self#updownlevel ~
-1)
4019 | @right
| @kpright
-> coe (self#updownlevel
1)
4020 | _ -> super#
key key mask
4021 else super#
key key mask
4023 G.postRedisplay "info";
4029 inherit lvsourcebase
4030 method getitemcount
= Array.length state
.help
4032 let s, l, _ = state
.help
.(n) in
4035 method exit ~
uioh ~cancel ~
active ~
first ~pan
=
4039 match state
.help
.(active) with
4040 | _, _, Action
f -> Some
(f uioh)
4041 | _, _, Noaction
-> Some
uioh
4050 method hasaction
n =
4051 match state
.help
.(n) with
4052 | _, _, Action
_ -> true
4053 | _, _, Noaction
-> false
4059 let modehash = findkeyhash conf
"help" in
4061 state
.uioh <- coe (new listview
4062 ~zebra
:false ~helpmode
:true
4063 ~
source ~trusted
:true ~
modehash);
4064 G.postRedisplay "help";
4070 inherit lvsourcebase
4071 val mutable m_items
= E.a
4073 method getitemcount
= 1 + Array.length m_items
4078 else m_items
.(n-1), 0
4080 method exit ~
uioh ~cancel ~
active ~
first ~pan
=
4085 then Buffer.clear state
.errmsgs
;
4092 method hasaction
n =
4096 state
.newerrmsgs
<- false;
4097 let l = Str.split newlinere
(Buffer.contents state
.errmsgs
) in
4098 m_items
<- Array.of_list
l
4107 let source = (msgsource :> lvsource
) in
4108 let modehash = findkeyhash conf
"listview" in
4109 state
.uioh <- coe (object
4110 inherit listview ~zebra
:false ~helpmode
:false
4111 ~
source ~trusted
:false ~
modehash as super
4114 then msgsource#reset
;
4117 G.postRedisplay "msgs";
4121 let editor = getenvwithdef
"EDITOR" E.s in
4125 let tmppath = Filename.temp_file
"llpp" "note" in
4128 let oc = open_out
tmppath in
4132 let execstr = editor ^
" " ^
tmppath in
4134 match spawn
execstr [] with
4135 | (exception exn
) ->
4136 impmsg "spawn(%S) failed: %s" execstr @@ exntos exn
;
4139 match Unix.waitpid
[] pid with
4140 | (exception exn
) ->
4141 impmsg "waitpid(%d) failed: %s" pid @@ exntos exn
;
4145 | Unix.WEXITED
0 -> filecontents
tmppath
4147 impmsg "editor process(%s) exited abnormally: %d" execstr n;
4149 | Unix.WSIGNALED
n ->
4150 impmsg "editor process(%s) was killed by signal %d" execstr n;
4152 | Unix.WSTOPPED
n ->
4153 impmsg "editor(%s) process was stopped by signal %d" execstr n;
4156 match Unix.unlink
tmppath with
4157 | (exception exn
) ->
4158 impmsg "failed to ulink %S: %s" tmppath @@ exntos exn
;
4163 let enterannotmode opaque slinkindex
=
4166 inherit lvsourcebase
4167 val mutable m_text
= E.s
4168 val mutable m_items
= E.a
4170 method getitemcount
= Array.length m_items
4173 let label, _func
= m_items
.(n) in
4176 method exit ~
uioh ~cancel ~
active ~
first ~pan
=
4177 ignore
(uioh, first, pan
);
4180 let _label, func
= m_items
.(active) in
4185 method hasaction
n = nonemptystr
@@ fst m_items
.(n)
4188 let rec split accu b i
=
4190 if p = String.length
s
4191 then (String.sub
s b (p-b), unit) :: accu
4193 if (i
> 70 && s.[p] = ' '
) || s.[p] = '
\r'
|| s.[p] = '
\n'
4195 let ss = if i
= 0 then E.s else String.sub
s b i
in
4196 split ((ss, unit)::accu) (p+1) 0
4201 wcmd "freepage %s" (~
> opaque);
4203 Hashtbl.fold (fun key opaque'
accu ->
4204 if opaque'
= opaque'
4205 then key :: accu else accu) state
.pagemap
[]
4207 List.iter
(Hashtbl.remove state
.pagemap
) keys;
4212 delannot
opaque slinkindex
;
4215 let edit inline
() =
4220 modannot
opaque slinkindex
s;
4226 let mode = state
.mode in
4229 ("annotation: ", m_text
, None
, textentry, update, true),
4230 fun _ -> state
.mode <- mode);
4234 let s = getusertext m_text
in
4239 ( "[Copy]", fun () -> selstring m_text
)
4240 :: ("[Delete]", dele)
4241 :: ("[Edit]", edit conf
.annotinline
)
4243 :: split [] 0 0 |> List.rev
|> Array.of_list
4250 let s = getannotcontents
opaque slinkindex
in
4253 let source = (msgsource :> lvsource
) in
4254 let modehash = findkeyhash conf
"listview" in
4255 state
.uioh <- coe (object
4256 inherit listview ~zebra
:false ~helpmode
:false
4257 ~
source ~trusted
:false ~
modehash
4259 G.postRedisplay "enterannotmode";
4262 let gotounder under =
4263 let getpath filename
=
4265 if nonemptystr filename
4267 if Filename.is_relative filename
4269 let dir = Filename.dirname state
.path in
4271 if Filename.is_implicit
dir
4272 then Filename.concat
(Sys.getcwd
()) dir
4275 Filename.concat
dir filename
4279 if Sys.file_exists
path
4284 | Ulinkgoto
(pageno, top) ->
4289 if conf
.presentation
&& conf
.coarseprespos
4293 gotopage1 pageno top;
4296 | Ulinkuri
s -> gotouri
s
4298 | Uremote
(filename
, pageno) ->
4299 let path = getpath filename
in
4304 let command = Printf.sprintf
"%s -page %d %S" !selfexec pageno path in
4305 match spawn
command [] with
4307 | (exception exn
) ->
4308 dolog
"failed to execute `%s': %s" command @@ exntos exn
4310 let anchor = getanchor
() in
4311 let ranchor = state
.path, state
.password, anchor, state
.origin
in
4312 state
.origin
<- E.s;
4313 state
.anchor <- (pageno, 0.0, 0.0);
4314 state
.ranchors
<- ranchor :: state
.ranchors
;
4317 else impmsg "cannot find %s" filename
4319 | Uremotedest
(filename
, destname
) ->
4320 let path = getpath filename
in
4325 let command = !selfexec ^
" " ^
path ^
" -dest " ^ destname
in
4326 match spawn
command [] with
4327 | (exception exn
) ->
4328 dolog
"failed to execute `%s': %s" command @@ exntos exn
4331 let anchor = getanchor
() in
4332 let ranchor = state
.path, state
.password, anchor, state
.origin
in
4333 state
.origin
<- E.s;
4334 state
.nameddest
<- destname
;
4335 state
.ranchors
<- ranchor :: state
.ranchors
;
4338 else impmsg "cannot find %s" filename
4340 | Uunexpected
_ | Ulaunch
_ | Unamed
_ | Utext
_ | Unone
-> ()
4341 | Uannotation
(opaque, slinkindex
) -> enterannotmode opaque slinkindex
4344 let gotooutline (_, _, kind
) =
4348 let (pageno, y, _) = anchor in
4350 (if conf
.presentation
then (pageno, y, 1.0) else anchor)
4354 | Ouri
uri -> gotounder (Ulinkuri
uri)
4355 | Olaunch cmd
-> gotounder (Ulaunch cmd
)
4356 | Oremote remote
-> gotounder (Uremote remote
)
4357 | Ohistory hist
-> gotohist hist
4358 | Oremotedest remotedest
-> gotounder (Uremotedest remotedest
)
4361 class outlinesoucebase fetchoutlines
= object (self)
4362 inherit lvsourcebase
4363 val mutable m_items
= E.a
4364 val mutable m_minfo
= E.a
4365 val mutable m_orig_items
= E.a
4366 val mutable m_orig_minfo
= E.a
4367 val mutable m_narrow_patterns
= []
4368 val mutable m_gen
= -1
4370 method getitemcount
= Array.length m_items
4373 let s, n, _ = m_items
.(n) in
4376 method exit ~
(uioh:uioh) ~cancel ~
active ~
(first:int) ~pan
:
4378 ignore
(uioh, first);
4380 if m_narrow_patterns
= []
4381 then m_orig_items
, m_orig_minfo
4382 else m_items
, m_minfo
4389 gotooutline m_items
.(active);
4397 method hasaction
(_:int) = true
4400 if Array.length m_items
!= Array.length m_orig_items
4403 match m_narrow_patterns
with
4405 | many
-> String.concat
"@Uellipsis" (List.rev many
)
4407 "Narrowed to " ^
s ^
" (ctrl-u to restore)"
4411 match m_narrow_patterns
with
4414 | head
:: _ -> "@Uellipsis" ^ head
4416 method narrow
pattern =
4417 match Str.regexp_case_fold
pattern with
4418 | (exception _) -> ()
4420 let rec loop accu minfo n =
4423 m_items
<- Array.of_list
accu;
4424 m_minfo
<- Array.of_list
minfo;
4427 let (s, _, _) as o = m_items
.(n) in
4429 match Str.search_forward re
s 0 with
4430 | (exception Not_found
) -> accu, minfo
4431 | first -> o :: accu, (first, Str.match_end
()) :: minfo
4433 loop accu minfo (n-1)
4435 loop [] [] (Array.length m_items
- 1)
4437 method! getminfo
= m_minfo
4440 m_orig_items
<- fetchoutlines
();
4441 m_minfo
<- m_orig_minfo
;
4442 m_items
<- m_orig_items
4444 method add_narrow_pattern
pattern =
4445 m_narrow_patterns
<- pattern :: m_narrow_patterns
4447 method del_narrow_pattern
=
4448 match m_narrow_patterns
with
4449 | _ :: rest
-> m_narrow_patterns
<- rest
4454 match m_narrow_patterns
with
4455 | pattern :: [] -> self#narrow
pattern; pattern
4457 List.fold_left
(fun accu pattern ->
4458 self#narrow
pattern;
4459 pattern ^
"@Uellipsis" ^
accu) E.s list
4461 method calcactive
(_:anchor) = 0
4463 method reset
anchor items =
4464 if state
.gen
!= m_gen
4466 m_orig_items
<- items;
4468 m_narrow_patterns
<- [];
4470 m_orig_minfo
<- E.a;
4474 if items != m_orig_items
4476 m_orig_items
<- items;
4477 if m_narrow_patterns
== []
4478 then m_items
<- items;
4481 let active = self#calcactive
anchor in
4483 m_first
<- firstof m_first
active
4487 let outlinesource fetchoutlines
=
4489 inherit outlinesoucebase fetchoutlines
4490 method! calcactive
anchor =
4491 let rely = getanchory anchor in
4492 let rec loop n best bestd
=
4493 if n = Array.length m_items
4496 let _, _, kind
= m_items
.(n) in
4499 let orely = getanchory anchor in
4500 let d = abs
(orely - rely) in
4503 else loop (n+1) best bestd
4504 | Onone
| Oremote
_ | Olaunch
_
4505 | Oremotedest
_ | Ouri
_ | Ohistory
_ ->
4506 loop (n+1) best bestd
4512 let enteroutlinemode, enterbookmarkmode
, enterhistmode
=
4513 let mkselector sourcetype
=
4514 let fetchoutlines () =
4515 match sourcetype
with
4516 | `bookmarks
-> Array.of_list state
.bookmarks
4517 | `outlines
-> state
.outlines
4518 | `history
-> genhistoutlines ()
4521 if sourcetype
= `history
4522 then new outlinesoucebase
fetchoutlines
4523 else outlinesource fetchoutlines
4526 let outlines = fetchoutlines () in
4527 if Array.length
outlines = 0
4529 showtext ' ' errmsg
;
4533 Wsi.setcursor
Wsi.CURSOR_INHERIT
;
4534 let anchor = getanchor
() in
4535 source#reset
anchor outlines;
4536 state
.text <- source#greetmsg
;
4538 coe (new outlinelistview ~zebra
:(sourcetype
=`history
) ~
source);
4539 G.postRedisplay "enter selector";
4542 let mkenter sourcetype errmsg
=
4543 let enter = mkselector sourcetype
in
4544 fun () -> enter errmsg
4546 (**)mkenter `
outlines "document has no outline"
4547 , mkenter `bookmarks
"document has no bookmarks (yet)"
4548 , mkenter `history
"history is empty"
4551 let quickbookmark ?title
() =
4552 match state
.layout with
4558 let tm = Unix.localtime
(now
()) in
4560 "Quick (page %d) (bookmarked at %02d/%02d/%d %02d:%02d)"
4564 (tm.Unix.tm_year
+ 1900)
4567 | Some
title -> title
4569 state
.bookmarks
<- (title, 0, Oanchor
(getanchor1
l)) :: state
.bookmarks
4572 let setautoscrollspeed step goingdown
=
4573 let incr = max
1 ((abs step
) / 2) in
4574 let incr = if goingdown
then incr else -incr in
4575 let astep = boundastep state
.winh
(step
+ incr) in
4576 state
.autoscroll
<- Some
astep;
4580 match conf
.columns
with
4582 | Csingle
_ | Cmulti
_ -> state
.x != 0 || conf
.zoom > 1.0
4585 let panbound x = bound
x (-state
.w) (wadjsb () + state
.winw
);;
4587 let existsinrow pageno (columns
, coverA
, coverB
) p =
4588 let last = ((pageno - coverA
) mod columns
) + columns
in
4589 let rec any = function
4592 if l.pageno = coverA
- 1 || l.pageno = state
.pagecount
- coverB
4596 then (if l.pageno = last then false else any rest
)
4604 match state
.layout with
4606 let pageno = page_of_y state
.y in
4607 gotoghyll (getpagey
(pageno+1))
4609 match conf
.columns
with
4611 if conf
.presentation
&& rest
== [] && l.pageh
> l.pagey + l.pagevh
4613 let y = clamp (pgscale state
.winh
) in
4616 let pageno = min
(l.pageno+1) (state
.pagecount
-1) in
4617 gotoghyll (getpagey
pageno)
4618 | Cmulti
((c, _, _) as cl
, _) ->
4619 if conf
.presentation
4620 && (existsinrow l.pageno cl
4621 (fun l -> l.pageh
> l.pagey + l.pagevh))
4623 let y = clamp (pgscale state
.winh
) in
4626 let pageno = min
(l.pageno+c) (state
.pagecount
-1) in
4627 gotoghyll (getpagey
pageno)
4629 if l.pageno < state
.pagecount
- 1 || l.pagecol
< n - 1
4631 let pagey, pageh
= getpageyh
l.pageno in
4632 let pagey = pagey + pageh
* l.pagecol
in
4633 let ips = if l.pagecol
= 0 then 0 else conf
.interpagespace
in
4634 gotoghyll (pagey + pageh
+ ips)
4638 match state
.layout with
4640 let pageno = page_of_y state
.y in
4641 gotoghyll (getpagey
(pageno-1))
4643 match conf
.columns
with
4645 if conf
.presentation
&& l.pagey != 0
4647 gotoghyll (clamp (pgscale ~
-(state
.winh
)))
4649 let pageno = max
0 (l.pageno-1) in
4650 gotoghyll (getpagey
pageno)
4651 | Cmulti
((c, _, coverB
) as cl
, _) ->
4652 if conf
.presentation
&&
4653 (existsinrow l.pageno cl
(fun l -> l.pagey != 0))
4655 gotoghyll (clamp (pgscale ~
-(state
.winh
)))
4658 if l.pageno = state
.pagecount
- coverB
4662 let pageno = max
0 (l.pageno-decr) in
4663 gotoghyll (getpagey
pageno)
4671 let pageno = max
0 (l.pageno-1) in
4672 let pagey, pageh
= getpageyh
pageno in
4675 let pagey, pageh
= getpageyh
l.pageno in
4676 pagey + pageh
* (l.pagecol
-1) - conf
.interpagespace
4682 if emptystr conf
.savecmd
4683 then error
"don't know where to save modified document"
4685 let savecmd = Str.global_replace percentsre state
.path conf
.savecmd in
4688 (fun s -> error
"failed to obtain path to the saved copy: %s" s)
4693 let tmp = path ^
".tmp" in
4695 Unix.rename
tmp path;
4698 let viewkeyboard key mask
=
4700 let mode = state
.mode in
4701 state
.mode <- Textentry
(te, fun _ -> state
.mode <- mode);
4704 G.postRedisplay "view:enttext"
4706 let ctrl = Wsi.withctrl mask
in
4707 let key = Wsi.keypadtodigitkey
key in
4712 if hasunsavedchanges
()
4716 if conf
.angle
mod 360 = 0 && not
(isbirdseye state
.mode)
4718 state
.mode <- LinkNav
(Ltgendir
0);
4721 else impmsg "keyboard link navigation does not work under rotation"
4724 begin match state
.mstate
with
4727 G.postRedisplay "kill rect";
4730 | Mscrolly
| Mscrollx
4733 begin match state
.mode with
4736 G.postRedisplay "esc leave linknav"
4740 match state
.ranchors
with
4742 | (path, password, anchor, origin
) :: rest
->
4743 state
.ranchors
<- rest
;
4744 state
.anchor <- anchor;
4745 state
.origin
<- origin
;
4746 state
.nameddest
<- E.s;
4747 opendoc path password
4752 gotoghyll (getnav ~
-1)
4763 Hashtbl.iter
(fun _ opaque ->
4765 Hashtbl.clear state
.prects
) state
.pagemap
;
4766 G.postRedisplay "dehighlight";
4768 | @slash
| @question
->
4769 let ondone isforw
s =
4770 cbput state
.hists
.pat
s;
4771 state
.searchpattern
<- s;
4774 let s = String.make
1 (Char.chr
key) in
4775 enttext (s, E.s, Some
(onhist state
.hists
.pat
),
4776 textentry, ondone (key = @slash
), true)
4778 | @plus
| @kpplus
| @equals
when ctrl ->
4779 let incr = if conf
.zoom +. 0.01 > 0.1 then 0.1 else 0.01 in
4780 setzoom (conf
.zoom +. incr)
4782 | @plus
| @kpplus
->
4785 try int_of_string
s with exn
->
4786 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exn
;
4792 state
.text <- "page bias is now " ^ string_of_int
n;
4795 enttext ("page bias: ", E.s, None
, intentry, ondone, true)
4797 | @minus
| @kpminus
when ctrl ->
4798 let decr = if conf
.zoom -. 0.1 < 0.1 then 0.01 else 0.1 in
4799 setzoom (max
0.01 (conf
.zoom -. decr))
4801 | @minus
| @kpminus
->
4802 let ondone msg
= state
.text <- msg
in
4804 "option [acfhilpstvxACFPRSZTISM]: ", E.s, None
,
4805 optentry state
.mode, ondone, true
4816 | (@1 | @2) when ctrl && conf
.fitmodel
!= FitPage
-> (* ctrl-1/2 *)
4818 match conf
.columns
with
4819 | Csingle
_ | Cmulti
_ -> 1
4820 | Csplit
(n, _) -> n
4822 let h = state
.winh
-
4823 conf
.interpagespace
lsl (if conf
.presentation
then 1 else 0)
4825 let zoom = zoomforh state
.winw
h (vscrollw ()) cols in
4826 if zoom > 0.0 && (key = @2 || zoom < 1.0)
4831 match conf
.fitmodel
with
4832 | FitWidth
-> FitProportional
4833 | FitProportional
-> FitPage
4834 | FitPage
-> FitWidth
4836 state
.text <- "fit model: " ^
FMTE.to_string
fm;
4837 reqlayout conf
.angle
fm
4839 | @4 when ctrl -> (* ctrl-4 *)
4840 let zoom = getmaxw
() /. float state
.winw
in
4841 if zoom > 0.0 then setzoom zoom
4849 | (48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57)
4850 when not
ctrl -> (* 0..9 *)
4853 try int_of_string
s with exn
->
4854 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exn
;
4860 cbput state
.hists
.pag
(string_of_int
n);
4861 gotopage1 (n + conf
.pagebias
- 1) 0;
4864 let pageentry text key =
4865 match Char.unsafe_chr
key with
4866 | '
g'
-> TEdone
text
4867 | _ -> intentry text key
4869 let text = String.make
1 (Char.chr
key) in
4870 enttext (":", text, Some
(onhist state
.hists
.pag
),
4871 pageentry, ondone, true)
4874 conf
.scrollb
<- if conf
.scrollb
= 0 then (scrollbvv
lor scrollbhv
) else 0;
4875 reshape state
.winw state
.winh
;
4878 state
.bzoom
<- not state
.bzoom
;
4880 showtext ' '
("block zoom " ^
if state
.bzoom
then "on" else "off")
4883 conf
.hlinks
<- not conf
.hlinks
;
4884 state
.text <- "highlightlinks " ^
if conf
.hlinks
then "on" else "off";
4885 G.postRedisplay "toggle highlightlinks";
4888 if conf
.angle
mod 360 = 0
4890 state
.glinks
<- true;
4891 let mode = state
.mode in
4894 (":", E.s, None
, linknentry, linknact gotounder, false),
4896 state
.glinks
<- false;
4900 G.postRedisplay "view:linkent(F)"
4902 else impmsg "hint mode does not work under rotation"
4905 state
.glinks
<- true;
4906 let mode = state
.mode in
4907 state
.mode <- Textentry
(
4909 ":", E.s, None
, linknentry, linknact (fun under ->
4910 selstring (undertext under);
4914 state
.glinks
<- false;
4918 G.postRedisplay "view:linkent"
4921 begin match state
.autoscroll
with
4923 conf
.autoscrollstep
<- step
;
4924 state
.autoscroll
<- None
4926 if conf
.autoscrollstep
= 0
4927 then state
.autoscroll
<- Some
1
4928 else state
.autoscroll
<- Some conf
.autoscrollstep
4932 launchpath () (* XXX where do error messages go? *)
4935 setpresentationmode (not conf
.presentation
);
4936 showtext ' '
("presentation mode " ^
4937 if conf
.presentation
then "on" else "off");
4940 if List.mem
Wsi.Fullscreen state
.winstate
4941 then Wsi.reshape conf
.cwinw conf
.cwinh
4942 else Wsi.fullscreen
()
4945 search state
.searchpattern
false
4948 search state
.searchpattern
true
4951 begin match state
.layout with
4954 gotoghyll (getpagey
l.pageno)
4960 | @delete
| @kpdelete
-> (* delete *)
4964 showtext ' '
(describe_location ());
4967 begin match state
.layout with
4970 Wsi.reshape (l.pagew
+ vscrollw ()) l.pageh
;
4975 enterbookmarkmode
()
4983 | @e when Buffer.length state
.errmsgs
> 0 ->
4988 match state
.layout with
4993 (s, 0, Oanchor
(getanchor1
l)) :: state
.bookmarks
4996 enttext ("bookmark: ", E.s, None
, textentry, ondone, true)
5000 showtext ' '
"Quick bookmark added";
5003 begin match state
.layout with
5005 let rect = getpdimrect
l.pagedimno
in
5009 (truncate
(1.8 *. (rect.(1) -. rect.(0))),
5010 truncate
(1.2 *. (rect.(3) -. rect.(0))))
5012 (truncate
(rect.(1) -. rect.(0)),
5013 truncate
(rect.(3) -. rect.(0)))
5015 let w = truncate
((float w)*.conf
.zoom)
5016 and h = truncate
((float h)*.conf
.zoom) in
5019 state
.anchor <- getanchor
();
5020 Wsi.reshape (w + vscrollw ()) (h + conf
.interpagespace
)
5022 G.postRedisplay "z";
5027 | @x -> state
.roam
()
5030 reqlayout (conf
.angle
+
5031 (if key = @Gt
then 30 else -30)) conf
.fitmodel
5035 bound
(conf
.colorscale
+. (if key = 93 then 0.1 else -0.1)) 0.0 1.0
5037 G.postRedisplay "brightness";
5039 | @c when state
.mode = View
->
5044 let m = (wadjsb () + state
.winw
- state
.w) / 2 in
5046 gotoy_and_clear_text state
.y
5050 match state
.prevcolumns
with
5051 | None
-> (1, 0, 0), 1.0
5052 | Some
(columns
, z
) ->
5055 | Csplit
(c, _) -> -c, 0, 0
5056 | Cmulti
((c, a, b), _) -> c, a, b
5057 | Csingle
_ -> 1, 0, 0
5061 setcolumns View
c a b;
5064 | @down
| @up
when ctrl && Wsi.withshift mask
->
5065 let zoom, x = state
.prevzoom
in
5069 | @k
| @up
| @kpup
->
5070 begin match state
.autoscroll
with
5072 begin match state
.mode with
5073 | Birdseye beye
-> upbirdseye 1 beye
5078 then gotoy_and_clear_text (clamp ~
-(state
.winh
/2))
5080 if not
(Wsi.withshift mask
) && conf
.presentation
5082 else gotoghyll1 true (clamp (-conf
.scrollstep
))
5086 setautoscrollspeed n false
5089 | @j
| @down
| @kpdown
->
5090 begin match state
.autoscroll
with
5092 begin match state
.mode with
5093 | Birdseye beye
-> downbirdseye 1 beye
5098 then gotoy_and_clear_text (clamp (state
.winh
/2))
5100 if not
(Wsi.withshift mask
) && conf
.presentation
5102 else gotoghyll1 true (clamp (conf
.scrollstep
))
5106 setautoscrollspeed n true
5109 | @left | @right
| @kpleft
| @kpright
when not
(Wsi.withalt mask
) ->
5115 else conf
.hscrollstep
5117 let dx = if key = @left || key = @kpleft
then dx else -dx in
5118 state
.x <- panbound (state
.x + dx);
5119 gotoy_and_clear_text state
.y
5122 G.postRedisplay "left/right"
5125 | @prior
| @kpprior
->
5129 match state
.layout with
5131 | l :: _ -> state
.y - l.pagey
5133 clamp (pgscale (-state
.winh
))
5137 | @next | @kpnext
->
5141 match List.rev state
.layout with
5143 | l :: _ -> getpagey
l.pageno
5145 clamp (pgscale state
.winh
)
5149 | @g | @home
| @kphome
->
5152 | @G
| @jend
| @kpend
->
5154 gotoghyll (clamp state
.maxy)
5156 | @right
| @kpright
when Wsi.withalt mask
->
5157 gotoghyll (getnav 1)
5158 | @left | @kpleft
when Wsi.withalt mask
->
5159 gotoghyll (getnav ~
-1)
5164 | @v when conf
.debug
->
5167 match getopaque l.pageno with
5170 let x0, y0, x1, y1 = pagebbox
opaque in
5171 let rect = (float x0, float y0,
5174 float x0, float y1) in
5176 let color = (0.0, 0.0, 1.0 /. (l.pageno mod 3 |> float), 0.5) in
5177 state
.rects
<- (l.pageno, color, rect) :: state
.rects
;
5179 G.postRedisplay "v";
5182 let mode = state
.mode in
5183 let cmd = ref E.s in
5184 let onleave = function
5185 | Cancel
-> state
.mode <- mode
5188 match getopaque l.pageno with
5189 | Some
opaque -> pipesel opaque !cmd
5190 | None
-> ()) state
.layout;
5194 cbput state
.hists
.sel
s;
5198 "| ", !cmd, Some
(onhist state
.hists
.sel
), textentry, ondone, true
5200 G.postRedisplay "|";
5201 state
.mode <- Textentry
(te, onleave);
5204 vlog "huh? %s" (Wsi.keyname
key)
5207 let linknavkeyboard key mask
linknav =
5208 let getpage pageno =
5209 let rec loop = function
5211 | l :: _ when l.pageno = pageno -> Some
l
5212 | _ :: rest
-> loop rest
5213 in loop state
.layout
5215 let doexact (pageno, n) =
5216 match getopaque pageno, getpage pageno with
5217 | Some
opaque, Some
l ->
5218 if key = @enter || key = @kpenter
5220 let under = getlink
opaque n in
5221 G.postRedisplay "link gotounder";
5228 Some
(findlink
opaque LDfirst
), -1
5231 Some
(findlink
opaque LDlast
), 1
5234 Some
(findlink
opaque (LDleft
n)), -1
5237 Some
(findlink
opaque (LDright
n)), 1
5240 Some
(findlink
opaque (LDup
n)), -1
5243 Some
(findlink
opaque (LDdown
n)), 1
5248 begin match findpwl
l.pageno dir with
5252 state
.mode <- LinkNav
(Ltgendir
dir);
5253 let y, h = getpageyh
pageno in
5256 then y + h - state
.winh
5261 begin match getopaque pageno, getpage pageno with
5262 | Some
opaque, Some
_ ->
5264 let ld = if dir > 0 then LDfirst
else LDlast
in
5267 begin match link with
5269 showlinktype (getlink
opaque m);
5270 state
.mode <- LinkNav
(Ltexact
(pageno, m));
5271 G.postRedisplay "linknav jpage";
5272 | Lnotfound
-> notfound dir
5278 begin match opt with
5279 | Some Lnotfound
-> pwl l dir;
5280 | Some
(Lfound
m) ->
5284 let _, y0, _, y1 = getlinkrect
opaque m in
5286 then gotopage1 l.pageno y0
5288 let d = fstate
.fontsize
+ 1 in
5289 if y1 - l.pagey > l.pagevh - d
5290 then gotopage1 l.pageno (y1 - state
.winh
- hscrollh () + d)
5291 else G.postRedisplay "linknav";
5293 showlinktype (getlink
opaque m);
5294 state
.mode <- LinkNav
(Ltexact
(l.pageno, m));
5297 | None
-> viewkeyboard key mask
5299 | _ -> viewkeyboard key mask
5304 G.postRedisplay "leave linknav"
5308 | Ltgendir
_ | Ltnotready
_ -> viewkeyboard key mask
5309 | Ltexact exact
-> doexact exact
5312 let keyboard key mask
=
5313 if (key = @g && Wsi.withctrl mask
) && not
(istextentry state
.mode)
5314 then wcmd "interrupt"
5315 else state
.uioh <- state
.uioh#
key key mask
5318 let birdseyekeyboard key mask
5319 ((oconf
, leftx
, pageno, hooverpageno
, anchor) as beye
) =
5321 match conf
.columns
with
5323 | Cmulti
((c, _, _), _) -> c
5324 | Csplit
_ -> failwith
"bird's eye split mode"
5326 let pgh layout = List.fold_left
5327 (fun m l -> max
l.pageh
m) state
.winh
layout in
5329 | @l when Wsi.withctrl mask
->
5330 let y, h = getpageyh
pageno in
5331 let top = (state
.winh
- h) / 2 in
5332 gotoy (max
0 (y - top))
5333 | @enter | @kpenter
-> leavebirdseye beye
false
5334 | @escape
-> leavebirdseye beye
true
5335 | @up
-> upbirdseye incr beye
5336 | @down
-> downbirdseye incr beye
5337 | @left -> upbirdseye 1 beye
5338 | @right
-> downbirdseye 1 beye
5341 begin match state
.layout with
5345 state
.mode <- Birdseye
(
5346 oconf
, leftx
, l.pageno, hooverpageno
, anchor
5348 gotopage1 l.pageno 0;
5351 let layout = layout state
.x (state
.y-state
.winh
)
5353 (pgh state
.layout) in
5355 | [] -> gotoy (clamp (-state
.winh
))
5357 state
.mode <- Birdseye
(
5358 oconf
, leftx
, l.pageno, hooverpageno
, anchor
5360 gotopage1 l.pageno 0
5363 | [] -> gotoy (clamp (-state
.winh
))
5367 begin match List.rev state
.layout with
5369 let layout = layout state
.x
5370 (state
.y + (pgh state
.layout))
5371 state
.winw state
.winh
in
5372 begin match layout with
5374 let incr = l.pageh
- l.pagevh in
5379 oconf
, leftx
, state
.pagecount
- 1, hooverpageno
, anchor
5381 G.postRedisplay "birdseye pagedown";
5383 else gotoy (clamp (incr + conf
.interpagespace
*2));
5387 Birdseye
(oconf
, leftx
, l.pageno, hooverpageno
, anchor);
5388 gotopage1 l.pageno 0;
5391 | [] -> gotoy (clamp state
.winh
)
5395 state
.mode <- Birdseye
(oconf
, leftx
, 0, hooverpageno
, anchor);
5399 let pageno = state
.pagecount
- 1 in
5400 state
.mode <- Birdseye
(oconf
, leftx
, pageno, hooverpageno
, anchor);
5401 if not
(pagevisible state
.layout pageno)
5404 match List.rev state
.pdims
with
5406 | (_, _, h, _) :: _ -> h
5408 gotoy (max
0 (getpagey
pageno - (state
.winh
- h - conf
.interpagespace
)))
5409 else G.postRedisplay "birdseye end";
5411 | _ -> viewkeyboard key mask
5416 match state
.mode with
5417 | Textentry
_ -> scalecolor 0.4
5419 | View
-> scalecolor 1.0
5420 | Birdseye
(_, _, pageno, hooverpageno
, _) ->
5421 if l.pageno = hooverpageno
5424 if l.pageno = pageno
5426 let c = scalecolor 1.0 in
5428 GlDraw.line_width
3.0;
5429 let dispx = xadjsb () + l.pagedispx in
5431 (float (dispx-1)) (float (l.pagedispy-1))
5432 (float (dispx+l.pagevw+1))
5433 (float (l.pagedispy+l.pagevh+1))
5435 GlDraw.line_width
1.0;
5444 let postdrawpage l linkindexbase
=
5445 match getopaque l.pageno with
5447 if tileready l l.pagex
l.pagey
5449 let x = l.pagedispx - l.pagex
+ xadjsb ()
5450 and y = l.pagedispy - l.pagey in
5452 match conf
.columns
with
5453 | Csingle
_ | Cmulti
_ ->
5454 (if conf
.hlinks
then 1 else 0)
5456 && not
(isbirdseye state
.mode) then 2 else 0)
5460 match state
.mode with
5461 | Textentry
((_, s, _, _, _, _), _) when state
.glinks
-> s
5467 Hashtbl.find_all state
.prects
l.pageno |>
5468 List.iter
(fun vals
-> drawprect
opaque x y vals
);
5469 postprocess
opaque hlmask x y (linkindexbase
, s, conf
.hfsize
);
5474 let scrollindicator () =
5475 let sbw, ph
, sh = state
.uioh#
scrollph in
5476 let sbh, pw, sw = state
.uioh#scrollpw
in
5481 else ((state
.winw
- sbw), state
.winw
, 0)
5484 GlDraw.color (0.64, 0.64, 0.64);
5485 filledrect (float x0) 0. (float x1) (float state
.winh
);
5487 (float hx0
) (float (state
.winh
- sbh))
5488 (float (hx0
+ wadjsb () + state
.winw
)) (float state
.winh
)
5490 GlDraw.color (0.0, 0.0, 0.0);
5492 filledrect (float x0) ph
(float x1) (ph
+. sh);
5493 let pw = pw +. float hx0
in
5494 filledrect pw (float (state
.winh
- sbh)) (pw +. sw) (float state
.winh
);
5498 match state
.mstate
with
5499 | Mnone
| Mscrolly
| Mscrollx
| Mpan
_ | Mzoom
_ | Mzoomrect
_ ->
5502 | Msel
((x0, y0), (x1, y1)) ->
5503 let identify opaque l px py = Some
(opaque, l.pageno, px, py) in
5504 let o0,n0
,px0
,py0
= onppundermouse identify x0 y0 (~
< E.s, -1, 0, 0) in
5505 let _o1,n1
,px1
,py1
= onppundermouse identify x1 y1 (~
< E.s, -1, 0, 0) in
5506 if n0
!= -1 && n0
= n1
then seltext
o0 (px0
, py0
, px1
, py1
);
5509 let showrects = function [] -> () | rects
->
5511 GlDraw.color (0.0, 0.0, 1.0) ~
alpha:0.5;
5512 GlFunc.blend_func ~
src:`src_alpha ~dst
:`one_minus_src_alpha
;
5514 (fun (pageno, c, (x0, y0, x1, y1, x2
, y2
, x3
, y3
)) ->
5516 if l.pageno = pageno
5518 let dx = float (l.pagedispx - l.pagex
) in
5519 let dy = float (l.pagedispy - l.pagey) in
5520 let r, g, b, alpha = c in
5521 GlDraw.color (r, g, b) ~
alpha;
5522 filledrect2 (x0+.dx) (y0+.dy)
5534 begin match conf
.columns
, state
.layout with
5535 | Csingle
_, _ :: _ ->
5536 GlDraw.color (scalecolor2 conf
.bgcolor
);
5538 List.fold_left
(fun y l ->
5541 let x1 = l.pagedispx + xadjsb () in
5542 let y1 = (l.pagedispy + l.pagevh) in
5543 filledrect (float x0) (float y0) (float x1) (float y1);
5544 let x0 = x1 + l.pagevw in
5545 let x1 = state
.winw
in
5546 filledrect1 (float x0) (float y0) (float x1) (float y1);
5550 and x1 = state
.winw
in
5552 and y1 = l.pagedispy in
5553 filledrect1 (float x0) (float y0) (float x1) (float y1);
5555 l.pagedispy + l.pagevh) 0 state
.layout
5558 and x1 = state
.winw
in
5560 and y1 = state
.winh
in
5561 filledrect1 (float x0) (float y0) (float x1) (float y1)
5562 | (Cmulti
_ | Csplit
_), _ | Csingle
_, [] ->
5563 GlClear.color (scalecolor2 conf
.bgcolor
);
5564 GlClear.clear
[`
color];
5566 List.iter
drawpage state
.layout;
5568 match state
.mode with
5569 | LinkNav
(Ltexact
(pageno, linkno
)) ->
5570 begin match getopaque pageno with
5572 let dx = xadjsb () in
5573 let x0, y0, x1, y1 = getlinkrect
opaque linkno
in
5574 let x0 = x0 + dx and x1 = x1 + dx in
5575 let color = (0.0, 0.0, 0.5, 0.5) in
5582 | None
-> state
.rects
5584 | LinkNav
(Ltgendir
_) | LinkNav
(Ltnotready
_)
5587 | View
-> state
.rects
5590 let rec postloop linkindexbase
= function
5592 let linkindexbase = linkindexbase + postdrawpage l linkindexbase in
5593 postloop linkindexbase rest
5597 postloop 0 state
.layout;
5599 begin match state
.mstate
with
5600 | Mzoomrect
((x0, y0), (x1, y1)) ->
5602 GlDraw.color (0.3, 0.3, 0.3) ~
alpha:0.5;
5603 GlFunc.blend_func ~
src:`src_alpha ~dst
:`one_minus_src_alpha
;
5604 filledrect (float x0) (float y0) (float x1) (float y1);
5608 | Mscrolly
| Mscrollx
5617 let zoomrect x y x1 y1 =
5620 and y0 = min
y y1 in
5621 gotoy (state
.y + y0);
5622 state
.anchor <- getanchor
();
5623 let zoom = (float state
.w) /. float (x1 - x0) in
5626 let adjw = wadjsb () + state
.winw
in
5628 then (adjw - state
.w) / 2
5631 match conf
.fitmodel
with
5632 | FitWidth
| FitProportional
-> simple ()
5634 match conf
.columns
with
5636 onppundermouse (fun _ l _ _ -> Some
l.pagedispx) x0 y0 x0
5637 | Cmulti
_ | Csingle
_ -> simple ()
5639 state
.x <- (state
.x + margin) - x0;
5644 let annot inline
x y =
5645 match unproject x y with
5646 | Some
(opaque, n, ux
, uy
) ->
5648 addannot
opaque ux uy
text;
5649 wcmd "freepage %s" (~
> opaque);
5650 Hashtbl.remove state
.pagemap
(n, state
.gen
);
5656 let ondone s = add s in
5657 let mode = state
.mode in
5658 state
.mode <- Textentry
(
5659 ("annotation: ", E.s, None
, textentry, ondone, true),
5660 fun _ -> state
.mode <- mode);
5663 G.postRedisplay "annot"
5665 add @@ getusertext E.s
5670 let g opaque l px py =
5671 match rectofblock
opaque px py with
5673 let x0 = a.(0) -. 20. in
5674 let x1 = a.(1) +. 20. in
5675 let y0 = a.(2) -. 20. in
5676 let zoom = (float state
.w) /. (x1 -. x0) in
5677 let pagey = getpagey
l.pageno in
5678 gotoy_and_clear_text (pagey + truncate
y0);
5679 state
.anchor <- getanchor
();
5680 let margin = (state
.w - l.pagew
)/2 in
5681 state
.x <- -truncate
x0 - margin;
5686 match conf
.columns
with
5688 impmsg "block zooming does not work properly in split columns mode"
5689 | Cmulti
_ | Csingle
_ -> onppundermouse g x y ()
5693 let winw = wadjsb () + state
.winw - 1 in
5694 let s = float x /. float winw in
5695 let destx = truncate
(float (state
.w + winw) *. s) in
5696 state
.x <- winw - destx;
5697 gotoy_and_clear_text state
.y;
5698 state
.mstate
<- Mscrollx
;
5702 let s = float y /. float state
.winh
in
5703 let desty = truncate
(float (state
.maxy - state
.winh
) *. s) in
5704 gotoy_and_clear_text desty;
5705 state
.mstate
<- Mscrolly
;
5708 let viewmulticlick clicks
x y mask
=
5709 let g opaque l px py =
5717 if markunder
opaque px py mark
5721 match getopaque l.pageno with
5723 | Some
opaque -> pipesel opaque cmd
5725 state
.roam
<- (fun () -> dopipe conf
.paxcmd
);
5726 if not
(Wsi.withctrl mask
) then dopipe conf
.selcmd
;
5731 G.postRedisplay "viewmulticlick";
5732 onppundermouse g x y (fun () -> impmsg "nothing to select") ();
5736 match conf
.columns
with
5738 | Csingle
_ | Cmulti
_ -> conf
.angle
mod 360 = 0
5741 let viewmouse button down
x y mask
=
5743 | n when (n == 4 || n == 5) && not down
->
5744 if Wsi.withctrl mask
5746 match state
.mstate
with
5747 | Mzoom
(oldn
, i
) ->
5755 if conf
.zoom +. 0.01 > 0.1 then 0.1 else 0.01
5757 if conf
.zoom -. 0.1 < 0.1 then -0.01 else -0.1
5759 let zoom = conf
.zoom -. incr in
5761 state
.mstate
<- Mzoom
(n, 0);
5763 state
.mstate
<- Mzoom
(n, i
+1);
5765 else state
.mstate
<- Mzoom
(n, 0)
5769 | Mscrolly
| Mscrollx
5771 | Mnone
-> state
.mstate
<- Mzoom
(n, 0)
5774 match state
.autoscroll
with
5775 | Some step
-> setautoscrollspeed step
(n=4)
5777 if conf
.wheelbypage
|| conf
.presentation
5786 then -conf
.scrollstep
5787 else conf
.scrollstep
5789 let incr = incr * 2 in
5790 let y = clamp incr in
5791 gotoy_and_clear_text y
5794 | n when (n = 6 || n = 7) && not down
&& canpan () ->
5796 panbound (state
.x + (if n = 7 then -2 else 2) * conf
.hscrollstep
);
5797 gotoy_and_clear_text state
.y
5799 | 1 when Wsi.withshift mask
->
5800 state
.mstate
<- Mnone
;
5803 match unproject x y with
5805 | Some
(_, pageno, ux
, uy
) ->
5806 let cmd = Printf.sprintf
5808 conf
.stcmd state
.path pageno ux uy
5810 match spawn
cmd [] with
5811 | (exception exn
) ->
5812 impmsg "execution of synctex command(%S) failed: %S"
5813 conf
.stcmd
@@ exntos exn
5817 | 1 when Wsi.withctrl mask
->
5820 Wsi.setcursor
Wsi.CURSOR_FLEUR
;
5821 state
.mstate
<- Mpan
(x, y)
5824 state
.mstate
<- Mnone
5829 if Wsi.withshift mask
5831 annot conf
.annotinline
x y;
5832 G.postRedisplay "addannot"
5836 Wsi.setcursor
Wsi.CURSOR_CYCLE
;
5837 state
.mstate
<- Mzoomrect
(p, p)
5840 match state
.mstate
with
5841 | Mzoomrect
((x0, y0), _) ->
5842 if abs
(x-x0) > 10 && abs
(y - y0) > 10
5843 then zoomrect x0 y0 x y
5846 G.postRedisplay "kill accidental zoom rect";
5850 | Mscrolly
| Mscrollx
5856 | 1 when vscrollhit x ->
5859 let _, position, sh = state
.uioh#
scrollph in
5860 if y > truncate
position && y < truncate
(position +. sh)
5861 then state
.mstate
<- Mscrolly
5864 state
.mstate
<- Mnone
5866 | 1 when y > state
.winh
- hscrollh () ->
5869 let _, position, sw = state
.uioh#scrollpw
in
5870 if x > truncate
position && x < truncate
(position +. sw)
5871 then state
.mstate
<- Mscrollx
5874 state
.mstate
<- Mnone
5876 | 1 when state
.bzoom
-> if not down
then zoomblock x y
5879 let dest = if down
then getunder x y else Unone
in
5880 begin match dest with
5883 | Uremote
_ | Uremotedest
_
5884 | Uunexpected
_ | Ulaunch
_ | Unamed
_ ->
5887 | Unone
when down
->
5888 Wsi.setcursor
Wsi.CURSOR_FLEUR
;
5889 state
.mstate
<- Mpan
(x, y);
5891 | Uannotation
(opaque, slinkindex
) -> enterannotmode opaque slinkindex
5893 | Unone
| Utext
_ ->
5898 state
.mstate
<- Msel
((x, y), (x, y));
5899 G.postRedisplay "mouse select";
5903 match state
.mstate
with
5906 | Mzoom
_ | Mscrollx
| Mscrolly
->
5907 state
.mstate
<- Mnone
5909 | Mzoomrect
((x0, y0), _) ->
5913 Wsi.setcursor
Wsi.CURSOR_INHERIT
;
5914 state
.mstate
<- Mnone
5916 | Msel
((x0, y0), (x1, y1)) ->
5917 let rec loop = function
5921 let a0 = l.pagedispy in
5922 let a1 = a0 + l.pagevh in
5923 let b0 = l.pagedispx in
5924 let b1 = b0 + l.pagevw in
5925 ((y0 >= a0 && y0 <= a1) || (y1 >= a0 && y1 <= a1))
5926 && ((x0 >= b0 && x0 <= b1) || (x1 >= b0 && x1 <= b1))
5930 match getopaque l.pageno with
5933 match Unix.pipe
() with
5934 | (exception exn
) ->
5935 impmsg "cannot create sel pipe: %s" @@
5939 Ne.clo fd
(fun msg
->
5940 dolog
"%s close failed: %s" what msg
)
5943 try spawn
cmd [r, 0; w, -1]
5945 dolog
"cannot execute %S: %s"
5952 G.postRedisplay "copysel";
5954 else clo "Msel pipe/w" w;
5955 clo "Msel pipe/r" r;
5957 dosel conf
.selcmd
();
5958 state
.roam
<- dosel conf
.paxcmd
;
5970 let birdseyemouse button down
x y mask
5971 (conf
, leftx
, _, hooverpageno
, anchor) =
5974 let rec loop = function
5977 if y > l.pagedispy && y < l.pagedispy + l.pagevh
5978 && x > l.pagedispx && x < l.pagedispx + l.pagevw
5980 leavebirdseye (conf
, leftx
, l.pageno, hooverpageno
, anchor) false;
5986 | _ -> viewmouse button down
x y mask
5992 method key key mask
=
5993 begin match state
.mode with
5994 | Textentry
textentry -> textentrykeyboard key mask
textentry
5995 | Birdseye
birdseye -> birdseyekeyboard key mask
birdseye
5996 | View
-> viewkeyboard key mask
5997 | LinkNav
linknav -> linknavkeyboard key mask
linknav
6001 method button button bstate
x y mask
=
6002 begin match state
.mode with
6004 | View
-> viewmouse button bstate
x y mask
6005 | Birdseye beye
-> birdseyemouse button bstate
x y mask beye
6010 method multiclick clicks
x y mask
=
6011 begin match state
.mode with
6013 | View
-> viewmulticlick clicks
x y mask
6020 begin match state
.mode with
6022 | View
| Birdseye
_ | LinkNav
_ ->
6023 match state
.mstate
with
6024 | Mzoom
_ | Mnone
-> ()
6029 state
.mstate
<- Mpan
(x, y);
6031 then state
.x <- panbound (state
.x + dx);
6033 gotoy_and_clear_text y
6036 state
.mstate
<- Msel
(a, (x, y));
6037 G.postRedisplay "motion select";
6040 let y = min state
.winh
(max
0 y) in
6044 let x = min state
.winw (max
0 x) in
6047 | Mzoomrect
(p0
, _) ->
6048 state
.mstate
<- Mzoomrect
(p0
, (x, y));
6049 G.postRedisplay "motion zoomrect";
6053 method pmotion
x y =
6054 begin match state
.mode with
6055 | Birdseye
(conf
, leftx
, pageno, hooverpageno
, anchor) ->
6056 let rec loop = function
6058 if hooverpageno
!= -1
6060 state
.mode <- Birdseye
(conf
, leftx
, pageno, -1, anchor);
6061 G.postRedisplay "pmotion birdseye no hoover";
6064 if y > l.pagedispy && y < l.pagedispy + l.pagevh
6065 && x > l.pagedispx && x < l.pagedispx + l.pagevw
6067 state
.mode <- Birdseye
(conf
, leftx
, pageno, l.pageno, anchor);
6068 G.postRedisplay "pmotion birdseye hoover";
6078 match state
.mstate
with
6079 | Mpan
_ | Msel
_ | Mzoom
_ | Mscrolly
| Mscrollx
| Mzoomrect
_ -> ()
6087 let past, _, _ = !r in
6089 let delta = now -. past in
6092 else r := (now, x, y)
6096 method infochanged
_ = ()
6099 let maxy = state
.maxy - (if conf
.maxhfit
then state
.winh
else 0) in
6102 then 0.0, float state
.winh
6103 else scrollph state
.y maxy
6108 let winw = wadjsb () + state
.winw in
6109 let fwinw = float winw in
6111 let sw = fwinw /. float state
.w in
6112 let sw = fwinw *. sw in
6113 max
sw (float conf
.scrollh
)
6116 let maxx = state
.w + winw in
6117 let x = winw - state
.x in
6118 let percent = float x /. float maxx in
6119 (fwinw -. sw) *. percent
6121 hscrollh (), position, sw
6125 match state
.mode with
6126 | LinkNav
_ -> "links"
6127 | Textentry
_ -> "textentry"
6128 | Birdseye
_ -> "birdseye"
6131 findkeyhash conf
modename
6133 method eformsgs
= true
6134 method alwaysscrolly
= false
6137 let addrect pageno r g b a x0 y0 x1 y1 =
6138 Hashtbl.add state
.prects
pageno [|r; g; b; a; x0; y0; x1; y1|];
6142 let cl = splitatspace cmds
in
6144 try Scanf.sscanf
s fmt
f
6146 adderrfmt "remote exec"
6147 "error processing '%S': %s\n" cmds
@@ exntos exn
6149 let rectx s pageno (r, g, b, a) x0 y0 x1 y1 =
6150 vlog "%s page %d color (%f %f %f %f) x0,y0,x1,y1 = %f %f %f %f"
6151 s pageno r g b a x0 y0 x1 y1;
6155 let _,w1,h1
,_ = getpagedim
pageno in
6156 let sw = float w1 /. float w
6157 and sh = float h1
/. float h in
6161 and y1s
= y1 *. sh in
6162 let rect = (x0s,y0s
,x1s
,y0s
,x1s
,y1s
,x0s,y1s
) in
6163 let color = (r, g, b, a) in
6164 if conf
.verbose
then debugrect rect;
6165 state
.rects <- (pageno, color, rect) :: state
.rects;
6170 | "reload", "" -> reload ()
6172 scan args
"%u %f %f"
6174 let cmd, _ = state
.geomcmds
in
6176 then gotopagexy !wtmode pageno x y
6179 gotopagexy !wtmode pageno x y;
6182 state
.reprf
<- f state
.reprf
6184 | "goto1", args
-> scan args
"%u %f" gotopage
6187 (fun filename
pageno -> gotounder (Uremote
(filename
, pageno)))
6190 (fun filename
dest -> gotounder (Uremotedest
(filename
, dest)))
6192 scan args
"%u %u %f %f %f %f"
6193 (fun pageno c x0 y0 x1 y1 ->
6194 let color = (0.0, 0.0, 1.0 /. float c, 0.5) in
6195 rectx "rect" pageno color x0 y0 x1 y1;
6198 scan args
"%u %f %f %f %f %f %f %f %f"
6199 (fun pageno r g b alpha x0 y0 x1 y1 ->
6200 addrect pageno r g b alpha x0 y0 x1 y1;
6201 G.postRedisplay "prect"
6204 scan args
"%u %f %f"
6207 match getopaque pageno with
6208 | Some
opaque -> opaque
6211 pgoto optopaque pageno x y;
6212 let rec fixx = function
6215 if l.pageno = pageno
6217 state
.x <- state
.x - l.pagedispx;
6224 match conf
.columns
with
6225 | Csingle
_ | Csplit
_ -> 1
6226 | Cmulti
((n, _, _), _) -> n
6228 layout 0 state
.y (state
.winw * mult) state
.winh
6232 | "activatewin", "" -> Wsi.activatewin
()
6233 | "quit", "" -> raise Quit
6236 let l = Config.keys_of_string
keys in
6237 List.iter
(fun (k
, m) -> keyboard k
m) l
6239 adderrfmt "error processing keys" "`%S': %s\n" cmds
@@ exntos exn
6241 | "clearrects", "" ->
6242 Hashtbl.clear state
.prects
;
6243 G.postRedisplay "clearrects"
6245 adderrfmt "remote command"
6246 "error processing remote command: %S\n" cmds
;
6250 let scratch = Bytes.create
80 in
6251 let buf = Buffer.create
80 in
6253 match tempfailureretry
(Unix.read fd
scratch 0) 80 with
6254 | (exception Unix.Unix_error
(Unix.EAGAIN
, _, _)) -> None
6257 if Buffer.length
buf > 0
6259 let s = Buffer.contents
buf in
6267 match Bytes.index_from
scratch ppos '
\n'
with
6268 | pos -> if pos >= n then -1 else pos
6269 | (exception Not_found
) -> -1
6273 Buffer.add_subbytes
buf scratch ppos
(nlpos-ppos
);
6274 let s = Buffer.contents
buf in
6280 Buffer.add_subbytes
buf scratch ppos
(n-ppos
);
6286 let remoteopen path =
6287 try Some
(Unix.openfile
path [Unix.O_NONBLOCK
; Unix.O_RDONLY
] 0o0)
6289 adderrfmt "remoteopen" "error opening %S: %s" path @@ exntos exn
;
6294 let gcconfig = ref E.s in
6295 let trimcachepath = ref E.s in
6296 let rcmdpath = ref E.s in
6297 let pageno = ref None
in
6298 let rootwid = ref 0 in
6299 let openlast = ref false in
6300 let nofc = ref false in
6301 let doreap = ref false in
6302 selfexec := Sys.executable_name
;
6305 [("-p", Arg.String
(fun s -> state
.password <- s),
6306 "<password> Set password");
6310 Config.fontpath
:= s;
6311 selfexec := !selfexec ^
" -f " ^
Filename.quote
s;
6313 "<path> Set path to the user interface font");
6317 selfexec := !selfexec ^
" -c " ^
Filename.quote
s;
6318 Config.confpath
:= s),
6319 "<path> Set path to the configuration file");
6321 ("-last", Arg.Set
openlast, " Open last document");
6323 ("-page", Arg.Int
(fun pageno1
-> pageno := Some
(pageno1
-1)),
6324 "<page-number> Jump to page");
6326 ("-tcf", Arg.String
(fun s -> trimcachepath := s),
6327 "<path> Set path to the trim cache file");
6329 ("-dest", Arg.String
(fun s -> state
.nameddest
<- s),
6330 "<named-destination> Set named destination");
6332 ("-wtmode", Arg.Set
wtmode, " Operate in wt mode");
6333 ("-cxack", Arg.Set
cxack, " Cut corners");
6335 ("-remote", Arg.String
(fun s -> rcmdpath := s),
6336 "<path> Set path to the remote commands source");
6338 ("-origin", Arg.String
(fun s -> state
.origin
<- s),
6339 "<original-path> Set original path");
6341 ("-gc", Arg.Set_string
gcconfig,
6342 "<script-path> Collect garbage with the help of a script");
6344 ("-nofc", Arg.Set
nofc, " Do not use fontconfig");
6346 ("-v", Arg.Unit
(fun () ->
6348 "%s\nconfiguration path: %s\n"
6352 exit
0), " Print version and exit");
6354 ("-embed", Arg.Set_int
rootwid,
6355 "<window-id> Embed into window")
6358 (fun s -> state
.path <- s)
6359 ("Usage: " ^
Sys.argv
.(0) ^
" [options] some.pdf\nOptions:")
6362 then selfexec := !selfexec ^
" -wtmode";
6364 let histmode = emptystr state
.path && not
!openlast in
6366 if not
(Config.load !openlast)
6367 then dolog
"failed to load configuration";
6369 begin match !pageno with
6370 | Some
pageno -> state
.anchor <- (pageno, 0.0, 0.0)
6374 if nonemptystr
!gcconfig
6377 match Unix.socketpair
Unix.PF_UNIX
Unix.SOCK_STREAM
0 with
6378 | (exception exn
) -> error
"socketpair for gc failed: %s" @@ exntos exn
6381 match spawn
!gcconfig [(c, 0); (c, 1); (s, -1)] with
6382 | (exception exn
) -> error
"failed to execute gc script: %s" @@ exntos exn
6384 Ne.clo c @@ (fun s -> error
"failed to close gc fd %s" s);
6389 let wsfd, winw, winh
= Wsi.init
(object (self)
6390 val mutable m_clicks
= 0
6391 val mutable m_click_x
= 0
6392 val mutable m_click_y
= 0
6393 val mutable m_lastclicktime
= infinity
6395 method private cleanup =
6396 state
.roam
<- noroam
;
6397 Hashtbl.iter
(fun _ opaque -> clearmark
opaque) state
.pagemap
6398 method expose
= G.postRedisplay "expose"
6402 | Wsi.Unobscured
-> "unobscured"
6403 | Wsi.PartiallyObscured
-> "partiallyobscured"
6404 | Wsi.FullyObscured
-> "fullyobscured"
6406 vlog "visibility change %s" name
6407 method display = display ()
6408 method map mapped
= vlog "mapped %b" mapped
6409 method reshape w h =
6412 method mouse
b d x y m =
6413 if d && canselect ()
6415 (* http://blogs.msdn.com/b/oldnewthing/archive/2004/10/18/243925.aspx *)
6421 if abs
x - m_click_x
> 10
6422 || abs
y - m_click_y
> 10
6423 || abs_float
(t -. m_lastclicktime
) > 0.3
6425 m_clicks
<- m_clicks
+ 1;
6426 m_lastclicktime
<- t;
6430 G.postRedisplay "cleanup";
6431 state
.uioh <- state
.uioh#button
b d x y m;
6433 else state
.uioh <- state
.uioh#multiclick m_clicks
x y m
6438 m_lastclicktime
<- infinity
;
6439 state
.uioh <- state
.uioh#button
b d x y m
6443 state
.uioh <- state
.uioh#button
b d x y m
6446 state
.mpos
<- (x, y);
6447 state
.uioh <- state
.uioh#motion
x y
6448 method pmotion
x y =
6449 state
.mpos
<- (x, y);
6450 state
.uioh <- state
.uioh#pmotion
x y
6452 let mascm = m land (
6453 Wsi.altmask
+ Wsi.shiftmask
+ Wsi.ctrlmask
+ Wsi.metamask
6456 let x = state
.x and y = state
.y in
6458 if x != state
.x || y != state
.y then self#
cleanup
6460 match state
.keystate
with
6462 let km = k
, mascm in
6465 let modehash = state
.uioh#
modehash in
6466 try Hashtbl.find modehash km
6468 try Hashtbl.find (findkeyhash conf
"global") km
6469 with Not_found
-> KMinsrt
(k
, m)
6471 | KMinsrt
(k
, m) -> keyboard k
m
6472 | KMinsrl
l -> List.iter
(fun (k
, m) -> keyboard k
m) l
6473 | KMmulti
(l, r) -> state
.keystate
<- KSinto
(l, r)
6475 | KSinto
((k'
, m'
) :: [], insrt
) when k'
=k
&& m'
land mascm = m'
->
6476 List.iter
(fun (k
, m) -> keyboard k
m) insrt
;
6477 state
.keystate
<- KSnone
6478 | KSinto
((k'
, m'
) :: keys, insrt
) when k'
=k
&& m'
land mascm = m'
->
6479 state
.keystate
<- KSinto
(keys, insrt
)
6480 | KSinto
_ -> state
.keystate
<- KSnone
6483 state
.mpos
<- (x, y);
6484 state
.uioh <- state
.uioh#pmotion
x y
6485 method leave = state
.mpos
<- (-1, -1)
6486 method winstate wsl
= state
.winstate
<- wsl
6487 method quit
= raise Quit
6488 end) !rootwid conf
.cwinw conf
.cwinh platform
in
6490 setbgcol conf
.bgcolor
;
6494 List.exists
GlMisc.check_extension
6495 [ "GL_ARB_texture_rectangle"
6496 ; "GL_EXT_texture_recangle"
6497 ; "GL_NV_texture_rectangle" ]
6499 then (dolog
"OpenGL does not suppport rectangular textures"; exit
1);
6502 let r = GlMisc.get_string `renderer
in
6503 let p = "Mesa DRI Intel(" in
6504 let l = String.length
p in
6505 String.length
r > l && String.sub
r 0 l = p
6508 defconf
.sliceheight
<- 1024;
6509 defconf
.texcount
<- 32;
6510 defconf
.usepbo
<- true;
6514 match Unix.socketpair
Unix.PF_UNIX
Unix.SOCK_STREAM
0 with
6515 | (exception exn
) ->
6516 dolog
"socketpair failed: %s" @@ exntos exn
;
6524 setcheckers conf
.checkers
;
6526 opengl_has_pbo := GlMisc.check_extension
"GL_ARB_pixel_buffer_object";
6529 conf
.angle
, conf
.fitmodel
, (conf
.trimmargins
, conf
.trimfuzz
),
6530 conf
.texcount
, conf
.sliceheight
, conf
.mustoresize
, conf
.colorspace
,
6531 !Config.fontpath
, !trimcachepath,
6535 List.iter
GlArray.enable
[`texture_coord
; `vertex
];
6537 reshape ~firsttime
:true winw winh
;
6541 Wsi.settitle
"llpp (history)";
6545 state
.text <- "Opening " ^
(mbtoutf8 state
.path);
6546 opendoc state
.path state
.password;
6550 Wsi.setcursor
Wsi.CURSOR_INHERIT
;
6551 Sys.set_signal
Sys.sighup
(Sys.Signal_handle
(fun _ -> reload ()));
6554 match Unix.waitpid
[Unix.WNOHANG
] ~
-1 with
6555 | (exception (Unix.Unix_error
(Unix.ECHILD
, _, _))) -> ()
6556 | (exception exn
) -> dolog
"Unix.waitpid: %s" @@ exntos exn
6558 | _pid
, _status
-> reap ()
6560 Sys.set_signal
Sys.sigchld
(Sys.Signal_handle
(fun _ -> doreap := true));
6564 if nonemptystr
!rcmdpath
6565 then remoteopen !rcmdpath
6570 let rec loop deadline
=
6576 let r = [state
.ss; state
.wsfd] in
6580 | Some fd
-> fd
:: r
6584 state
.redisplay
<- false;
6591 if deadline
= infinity
6593 else max
0.0 (deadline
-. now)
6598 try Unix.select
r [] [] timeout
6599 with Unix.Unix_error
(Unix.EINTR
, _, _) -> [], [], []
6605 if state
.ghyll
== noghyll
6607 match state
.autoscroll
with
6608 | Some step
when step
!= 0 ->
6609 let y = state
.y + step
in
6610 let fy = if conf
.maxhfit
then state
.winh
else 0 in
6613 then state
.maxy - fy
6614 else if y >= state
.maxy - fy then 0 else y
6616 if state
.mode = View
6617 then gotoy_and_clear_text y
6621 else deadline
+. 0.01
6626 let rec checkfds = function
6628 | fd
:: rest
when fd
= state
.ss ->
6629 let cmd = rcmd state
.ss in
6633 | fd
:: rest
when fd
= state
.wsfd ->
6637 | fd
:: rest
when Some fd
= !optrfd ->
6638 begin match remote fd
with
6639 | None
-> optrfd := remoteopen !rcmdpath;
6640 | opt -> optrfd := opt
6645 dolog
"select returned unknown descriptor";
6651 if deadline
= infinity
6655 match state
.autoscroll
with
6656 | Some step
when step
!= 0 -> deadline1
6657 | _ -> if state
.ghyll
== noghyll
then infinity
else deadline1
6665 Config.save leavebirdseye;
6666 if hasunsavedchanges
()