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 key land 0xff00 = 0xff00
2004 else TEcont
(text ^ toutf8
key)
2007 let reqlayout angle fitmodel
=
2008 match state
.throttle
with
2010 if nogeomcmds state
.geomcmds
2011 then state
.anchor <- getanchor
();
2012 conf
.angle
<- angle
mod 360;
2015 match state
.mode
with
2016 | LinkNav
_ -> state
.mode
<- View
2021 conf
.fitmodel
<- fitmodel
;
2022 invalidate "reqlayout"
2024 wcmd "reqlayout %d %d %d"
2025 conf
.angle
(FMTE.to_int conf
.fitmodel
) (stateh state
.winh
)
2030 let settrim trimmargins trimfuzz
=
2031 if nogeomcmds state
.geomcmds
2032 then state
.anchor <- getanchor
();
2033 conf
.trimmargins
<- trimmargins
;
2034 conf
.trimfuzz
<- trimfuzz
;
2035 let x0, y0, x1, y1 = trimfuzz
in
2036 invalidate "settrim"
2038 wcmd "settrim %d %d %d %d %d" (btod conf
.trimmargins
) x0 y0 x1 y1);
2043 match state
.throttle
with
2045 let zoom = max
0.0001 zoom in
2046 if zoom <> conf
.zoom
2048 state
.prevzoom
<- (conf
.zoom, state
.x);
2050 reshape state
.winw state
.winh
;
2051 state
.text <- Printf.sprintf
"zoom is now %-5.2f" (zoom *. 100.0);
2054 | Some
(layout, y, started
) ->
2056 match conf
.maxwait
with
2060 let dt = now
() -. started
in
2068 let setcolumns mode columns coverA coverB
=
2069 state
.prevcolumns
<- Some
(conf
.columns
, conf
.zoom);
2073 then impmsg "split mode doesn't work in bird's eye"
2075 conf
.columns
<- Csplit
(-columns
, E.a);
2083 conf
.columns
<- Csingle
E.a;
2088 conf
.columns
<- Cmulti
((columns
, coverA
, coverB
), E.a);
2092 reshape state
.winw state
.winh
;
2095 let resetmstate () =
2096 state
.mstate
<- Mnone
;
2097 Wsi.setcursor
Wsi.CURSOR_INHERIT
;
2100 let enterbirdseye () =
2101 let zoom = float conf
.thumbw
/. float state
.winw
in
2102 let birdseyepageno =
2103 let cy = state
.winh
/ 2 in
2107 let rec fold best
= function
2110 let d = cy - (l.pagedispy + l.pagevh/2)
2111 and dbest
= cy - (best
.pagedispy + best
.pagevh/2) in
2112 if abs
d < abs dbest
2119 state
.mode
<- Birdseye
(
2120 { conf
with zoom = conf
.zoom }, state
.x, birdseyepageno, -1, getanchor
()
2124 conf
.presentation
<- false;
2125 conf
.interpagespace
<- 10;
2126 conf
.hlinks
<- false;
2127 conf
.fitmodel
<- FitPage
;
2129 conf
.maxwait
<- None
;
2131 match conf
.beyecolumns
with
2134 Cmulti
((c, 0, 0), E.a)
2135 | None
-> Csingle
E.a
2139 state
.text <- Printf.sprintf
"birds eye mode on (zoom %3.1f%%)"
2144 reshape state
.winw state
.winh
;
2147 let leavebirdseye (c, leftx
, pageno, _, anchor) goback
=
2149 conf
.zoom <- c.zoom;
2150 conf
.presentation
<- c.presentation
;
2151 conf
.interpagespace
<- c.interpagespace
;
2152 conf
.maxwait
<- c.maxwait
;
2153 conf
.hlinks
<- c.hlinks
;
2154 conf
.fitmodel
<- c.fitmodel
;
2155 conf
.beyecolumns
<- (
2156 match conf
.columns
with
2157 | Cmulti
((c, _, _), _) -> Some
c
2159 | Csplit
_ -> failwith
"leaving bird's eye split mode"
2162 match c.columns
with
2163 | Cmulti
(c, _) -> Cmulti
(c, E.a)
2164 | Csingle
_ -> Csingle
E.a
2165 | Csplit
(c, _) -> Csplit
(c, E.a)
2169 state
.text <- Printf.sprintf
"birds eye mode off (zoom %3.1f%%)"
2172 reshape state
.winw state
.winh
;
2173 state
.anchor <- if goback
then anchor else (pageno, 0.0, 1.0);
2177 let togglebirdseye () =
2178 match state
.mode
with
2179 | Birdseye vals
-> leavebirdseye vals
true
2180 | View
-> enterbirdseye ()
2185 let upbirdseye incr
(conf
, leftx
, pageno, hooverpageno
, anchor) =
2186 let pageno = max
0 (pageno - incr
) in
2187 let rec loop = function
2188 | [] -> gotopage1 pageno 0
2189 | l :: _ when l.pageno = pageno ->
2190 if l.pagedispy >= 0 && l.pagey = 0
2191 then G.postRedisplay "upbirdseye"
2192 else gotopage1 pageno 0
2193 | _ :: rest
-> loop rest
2197 state
.mode
<- Birdseye
(conf
, leftx
, pageno, hooverpageno
, anchor)
2200 let downbirdseye incr
(conf
, leftx
, pageno, hooverpageno
, anchor) =
2201 let pageno = min
(state
.pagecount
- 1) (pageno + incr
) in
2202 state
.mode
<- Birdseye
(conf
, leftx
, pageno, hooverpageno
, anchor);
2203 let rec loop = function
2205 let y, h = getpageyh
pageno in
2206 let dy = (y - state
.y) - (state
.winh
- h - conf
.interpagespace
) in
2208 | l :: _ when l.pageno = pageno ->
2209 if l.pagevh != l.pageh
2210 then gotoy (clamp (l.pageh
- l.pagevh + conf
.interpagespace
))
2211 else G.postRedisplay "downbirdseye"
2212 | _ :: rest
-> loop rest
2218 let optentry mode
_ key =
2219 let btos b = if b then "on" else "off" in
2220 if key >= 32 && key < 127
2222 let c = Char.chr
key in
2226 try conf
.scrollstep
<- int_of_string
s with exc
->
2227 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exc
2229 TEswitch
("scroll step: ", E.s, None
, intentry, ondone, true)
2234 conf
.autoscrollstep
<- boundastep state
.winh
(int_of_string
s);
2235 if state
.autoscroll
<> None
2236 then state
.autoscroll
<- Some conf
.autoscrollstep
2238 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exc
2240 TEswitch
("auto scroll step: ", E.s, None
, intentry, ondone, true)
2245 let n, a, b = multicolumns_of_string
s in
2246 setcolumns mode
n a b;
2248 state
.text <- Printf.sprintf
"bad columns `%s': %s" s @@ exntos exc
2250 TEswitch
("columns: ", E.s, None
, textentry, ondone, true)
2255 let zoom = float (int_of_string
s) /. 100.0 in
2258 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exc
2260 TEswitch
("zoom: ", E.s, None
, intentry, ondone, true)
2265 conf
.thumbw
<- bound
(int_of_string
s) 2 4096;
2267 Printf.sprintf
"thumbnail width is set to %d" conf
.thumbw
;
2268 begin match mode
with
2270 leavebirdseye beye
false;
2277 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exc
2279 TEswitch
("thumbnail width: ", E.s, None
, intentry, ondone, true)
2284 Some
(int_of_string
s)
2287 Printf.sprintf
"bad integer `%s': %s" s @@ exntos exc
;
2290 | Some angle
-> reqlayout angle conf
.fitmodel
2293 TEswitch
("rotation: ", E.s, None
, intentry, ondone, true)
2296 conf
.icase
<- not conf
.icase
;
2297 TEdone
("case insensitive search " ^
(btos conf
.icase
))
2300 conf
.preload <- not conf
.preload;
2302 TEdone
("preload " ^
(btos conf
.preload))
2305 conf
.verbose
<- not conf
.verbose
;
2306 TEdone
("verbose " ^
(btos conf
.verbose
))
2309 conf
.debug
<- not conf
.debug
;
2310 TEdone
("debug " ^
(btos conf
.debug
))
2313 conf
.maxhfit
<- not conf
.maxhfit
;
2314 state
.maxy
<- calcheight
();
2315 TEdone
("maxhfit " ^
(btos conf
.maxhfit
))
2318 conf
.crophack
<- not conf
.crophack
;
2319 TEdone
("crophack " ^
btos conf
.crophack
)
2323 match conf
.maxwait
with
2325 conf
.maxwait
<- Some infinity
;
2326 "always wait for page to complete"
2328 conf
.maxwait
<- None
;
2329 "show placeholder if page is not ready"
2334 conf
.underinfo
<- not conf
.underinfo
;
2335 TEdone
("underinfo " ^
btos conf
.underinfo
)
2338 conf
.savebmarks
<- not conf
.savebmarks
;
2339 TEdone
("persistent bookmarks " ^
btos conf
.savebmarks
)
2345 match state
.layout with
2350 conf
.interpagespace
<- int_of_string
s;
2351 docolumns conf
.columns
;
2352 state
.maxy
<- calcheight
();
2353 let y = getpagey
pageno in
2356 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exc
2358 TEswitch
("vertical margin: ", E.s, None
, intentry, ondone, true)
2362 match conf
.fitmodel
with
2363 | FitProportional
-> FitWidth
2364 | FitWidth
| FitPage
-> FitProportional
2366 reqlayout conf
.angle
fm;
2367 TEdone
("proportional display " ^
btos (fm == FitProportional
))
2370 settrim (not conf
.trimmargins
) conf
.trimfuzz
;
2371 TEdone
("trim margins " ^
btos conf
.trimmargins
)
2374 conf
.invert
<- not conf
.invert
;
2375 TEdone
("invert colors " ^
btos conf
.invert
)
2379 cbput state
.hists
.sel
s;
2382 TEswitch
("selection command: ", E.s, Some
(onhist state
.hists
.sel
),
2383 textentry, ondone, true)
2387 then conf
.pax
<- Some
(ref (0.0, 0, 0))
2388 else conf
.pax
<- None
;
2389 TEdone
("PAX " ^
btos (conf
.pax
!= None
))
2392 state
.text <- Printf.sprintf
"bad option %d `%c'" key c;
2398 class type lvsource
= object
2399 method getitemcount
: int
2400 method getitem
: int -> (string * int)
2401 method hasaction
: int -> bool
2409 method getactive
: int
2410 method getfirst
: int
2412 method getminfo
: (int * int) array
2415 class virtual lvsourcebase
= object
2416 val mutable m_active
= 0
2417 val mutable m_first
= 0
2418 val mutable m_pan
= 0
2419 method getactive
= m_active
2420 method getfirst
= m_first
2421 method getpan
= m_pan
2422 method getminfo
: (int * int) array
= E.a
2425 let textentrykeyboard
2426 key _mask
((c, text, opthist
, onkey
, ondone, cancelonempty
), onleave
) =
2429 if key >= 0xffb0 && key <= 0xffb9
2430 then key - 0xffb0 + 48 else key
2433 state
.mode
<- Textentry
(te
, onleave
);
2435 G.postRedisplay "textentrykeyboard enttext";
2437 let histaction cmd
=
2440 | Some
(action, _) ->
2441 state
.mode
<- Textentry
(
2442 (c, action cmd
, opthist
, onkey
, ondone, cancelonempty
), onleave
2444 G.postRedisplay "textentry histaction"
2448 if emptystr
text && cancelonempty
2451 G.postRedisplay "textentrykeyboard after cancel";
2454 let s = withoutlastutf8
text in
2455 enttext (c, s, opthist
, onkey
, ondone, cancelonempty
)
2457 | @enter
| @kpenter
->
2460 G.postRedisplay "textentrykeyboard after confirm"
2462 | @up
| @kpup
-> histaction HCprev
2463 | @down
| @kpdown
-> histaction HCnext
2464 | @home
| @kphome
-> histaction HCfirst
2465 | @jend
| @kpend
-> histaction HClast
2470 begin match opthist
with
2472 | Some
(_, onhistcancel
) -> onhistcancel
()
2476 G.postRedisplay "textentrykeyboard after cancel2"
2479 enttext (c, E.s, opthist
, onkey
, ondone, cancelonempty
)
2482 | @delete
| @kpdelete
-> ()
2485 && key land 0xff00 != 0xff00 (* keyboard *)
2486 && key land 0xfe00 != 0xfe00 (* xkb *)
2487 && key land 0xfd00 != 0xfd00 (* 3270 *)
2489 begin match onkey
text key with
2493 G.postRedisplay "textentrykeyboard after confirm2";
2496 enttext (c, text, opthist
, onkey
, ondone, cancelonempty
);
2500 G.postRedisplay "textentrykeyboard after cancel3"
2503 state
.mode
<- Textentry
(te
, onleave
);
2504 G.postRedisplay "textentrykeyboard switch";
2508 vlog "unhandled key %s" (Wsi.keyname
key)
2511 let firstof first active
=
2512 if first
> active
|| abs
(first
- active
) > fstate
.maxrows
- 1
2513 then max
0 (active
- (fstate
.maxrows
/2))
2517 let calcfirst first active
=
2520 let rows = active
- first
in
2521 if rows > fstate
.maxrows
then active
- fstate
.maxrows
else first
2525 let scrollph y maxy
=
2526 let sh = float (maxy
+ state
.winh
) /. float state
.winh
in
2527 let sh = float state
.winh
/. sh in
2528 let sh = max
sh (float conf
.scrollh
) in
2530 let percent = float y /. float maxy
in
2531 let position = (float state
.winh
-. sh) *. percent in
2534 if position +. sh > float state
.winh
2535 then float state
.winh
-. sh
2541 let adderrmsg src msg
=
2542 Buffer.add_string state
.errmsgs msg
;
2543 state
.newerrmsgs
<- true;
2547 let adderrfmt src fmt
=
2548 Format.ksprintf
(fun s -> adderrmsg src
s) fmt
;
2551 let coe s = (s :> uioh
);;
2553 class listview ~zebra ~helpmode ~
(source
:lvsource
) ~trusted ~modehash
=
2555 val m_pan
= source#getpan
2556 val m_first
= source#getfirst
2557 val m_active
= source#getactive
2559 val m_prev_uioh
= state
.uioh
2561 method private elemunder
y =
2565 let n = y / (fstate
.fontsize
+1) in
2566 if m_first
+ n < source#getitemcount
2568 if source#hasaction
(m_first
+ n)
2569 then Some
(m_first
+ n)
2576 GlFunc.blend_func ~src
:`src_alpha ~dst
:`one_minus_src_alpha
;
2577 GlDraw.color (0., 0., 0.) ~alpha
:0.85;
2578 filledrect 0. 0. (float state
.winw
) (float state
.winh
);
2579 GlDraw.color (1., 1., 1.);
2580 Gl.enable `texture_2d
;
2581 let fs = fstate
.fontsize
in
2583 let hw = (wadjsb () + xadjsb () + state
.winw
)/3 in
2584 let ww = fstate
.wwidth
in
2585 let tabw = 17.0*.ww in
2586 let itemcount = source#getitemcount
in
2587 let minfo = source#getminfo
in
2590 then float (xadjsb ()), float (state
.winw
- 1)
2591 else 0.0, float (state
.winw
- conf
.scrollbw
- 1)
2593 let xadj = xadjsb () in
2595 if (row - m_first
) > fstate
.maxrows
2598 if row >= 0 && row < itemcount
2600 let (s, level
) = source#getitem
row in
2601 let y = (row - m_first
) * nfs in
2603 (if conf
.leftscroll
then float xadj else 5.0)
2604 +. (float (level
+ m_pan
)) *. ww in
2607 (let c = if row land 1 = 0 then 1.0 else 0.92 in (c,c,c));
2611 Gl.disable `texture_2d
;
2612 let alpha = if source#hasaction
row then 0.9 else 0.3 in
2613 GlDraw.color (1., 1., 1.) ~
alpha;
2614 linerect (x0 +. 1.) (float (y + 1)) (x1) (float (y + fs + 3));
2615 Gl.enable `texture_2d
;
2618 if zebra
&& row land 1 = 1
2622 GlDraw.color (c,c,c);
2623 let drawtabularstring s =
2625 let x'
= truncate
(x0 +. x) in
2626 let pos = nindex
s '
\000'
in
2628 then drawstring1 fs x'
(y+nfs) s
2630 let s1 = String.sub
s 0 pos
2631 and s2
= String.sub
s (pos+1) (String.length
s - pos - 1) in
2636 let s'
= withoutlastutf8
s in
2637 let s = s' ^
"@Uellipsis" in
2638 let w = measurestr
fs s in
2639 if float x'
+. w +. ww < float (hw + x'
)
2644 if float x'
+. ww +. measurestr
fs s1 > float (hw + x'
)
2648 ignore
(drawstring1 fs x'
(y+nfs) s1);
2649 drawstring1 fs (hw + x'
) (y+nfs) s2
2653 let x = if helpmode
&& row > 0 then x +. ww else x in
2654 let tabpos = nindex
s '
\t'
in
2657 let len = String.length
s - tabpos - 1 in
2658 let s1 = String.sub
s 0 tabpos
2659 and s2
= String.sub
s (tabpos + 1) len in
2660 let nx = drawstr x s1 in
2662 let x = x +. (max
tabw sw) in
2665 let len = String.length
s - 2 in
2666 if len > 0 && s.[0] = '
\xc2'
&& s.[1] = '
\xb7'
2668 let s = String.sub
s 2 len in
2669 let x = if not helpmode
then x +. ww else x in
2670 GlDraw.color (1.2, 1.2, 1.2);
2671 let vinc = drawstring1 (fs+fs/4)
2672 (truncate
(x -. ww)) (y+nfs) s in
2673 GlDraw.color (1., 1., 1.);
2674 vinc +. (float fs *. 0.8)
2680 ignore
(drawtabularstring s);
2686 GlDraw.color (1.0, 1.0, 1.0) ~
alpha:0.5;
2687 let xadj = float (xadjsb () + 5) in
2689 if (row - m_first
) > fstate
.maxrows
2692 if row >= 0 && row < itemcount
2694 let (s, level
) = source#getitem
row in
2695 let pos0 = nindex
s '
\000'
in
2696 let y = (row - m_first
) * nfs in
2697 let x = float (level
+ m_pan
) *. ww in
2698 let (first
, last
) = minfo.(row) in
2700 if pos0 > 0 && first
> pos0
2701 then String.sub
s (pos0+1) (first
-pos0-1)
2702 else String.sub
s 0 first
2704 let suffix = String.sub
s first
(last
- first
) in
2705 let w1 = measurestr fstate
.fontsize
prefix in
2706 let w2 = measurestr fstate
.fontsize
suffix in
2707 let x = x +. if conf
.leftscroll
then xadj else 5.0 in
2708 let x = if pos0 > 0 && first
> pos0 then x +. float hw else x in
2710 and y0 = float (y+2) in
2712 and y1 = float (y+fs+3) in
2713 filledrect x0 y0 x1 y1;
2718 Gl.disable `texture_2d
;
2719 if Array.length
minfo > 0 then loop m_first
;
2722 method updownlevel incr
=
2723 let len = source#getitemcount
in
2725 if m_active
>= 0 && m_active
< len
2726 then snd
(source#getitem m_active
)
2730 if i
= len then i
-1 else if i
= -1 then 0 else
2731 let _, l = source#getitem i
in
2732 if l != curlevel then i
else flow (i
+incr
)
2734 let active = flow m_active
in
2735 let first = calcfirst m_first
active in
2736 G.postRedisplay "outline updownlevel";
2737 {< m_active
= active; m_first
= first >}
2739 method private key1
key mask
=
2740 let set1 active first qsearch
=
2741 coe {< m_active
= active; m_first
= first; m_qsearch
= qsearch
>}
2743 let search active pattern incr
=
2744 let active = if active = -1 then m_first
else active in
2747 if n >= 0 && n < source#getitemcount
2749 let s, _ = source#getitem
n in
2750 match Str.search_forward re
s 0 with
2751 | (exception Not_found
) -> loop (n + incr
)
2758 let qpat = Str.quote pattern
in
2759 match Str.regexp_case_fold
qpat with
2762 adderrfmt "listview key1" "regexp_case_fold for `%S' failed: %S\n"
2763 qpat @@ Printexc.to_string exn
;
2766 let itemcount = source#getitemcount
in
2767 let find start incr
=
2769 if i
= -1 || i
= itemcount
2772 if source#hasaction i
2774 else find (i
+ incr
)
2779 let set active first =
2780 let first = bound
first 0 (itemcount - fstate
.maxrows
) in
2782 coe {< m_active
= active; m_first
= first; m_qsearch
= E.s >}
2785 let isvisible first n = n >= first && n - first <= fstate
.maxrows
in
2787 let incr1 = if incr
> 0 then 1 else -1 in
2788 if isvisible m_first m_active
2791 let next = m_active
+ incr
in
2793 if next < 0 || next >= itemcount
2795 else find next incr1
2797 if abs
(m_active
- next) > fstate
.maxrows
2803 let first = m_first
+ incr
in
2804 let first = bound
first 0 (itemcount - fstate
.maxrows
) in
2806 let next = m_active
+ incr
in
2807 let next = bound
next 0 (itemcount - 1) in
2814 if isvisible first next
2821 let first = min
next m_first
in
2823 if abs
(next - first) > fstate
.maxrows
2829 let first = m_first
+ incr
in
2830 let first = bound
first 0 (itemcount - 1) in
2832 let next = m_active
+ incr
in
2833 let next = bound
next 0 (itemcount - 1) in
2834 let next = find next incr1 in
2836 if next = -1 || abs
(m_active
- first) > fstate
.maxrows
2838 let active = if m_active
= -1 then next else m_active
in
2843 if isvisible first active
2849 G.postRedisplay "listview navigate";
2853 | (@r
|@s) when Wsi.withctrl mask
->
2854 let incr = if key = @r
then -1 else 1 in
2856 match search (m_active
+ incr) m_qsearch
incr with
2858 state
.text <- m_qsearch ^
" [not found]";
2861 state
.text <- m_qsearch
;
2862 active, firstof m_first
active
2864 G.postRedisplay "listview ctrl-r/s";
2865 set1 active first m_qsearch
;
2867 | @insert
when Wsi.withctrl mask
->
2868 if m_active
>= 0 && m_active
< source#getitemcount
2870 let s, _ = source#getitem m_active
in
2876 if emptystr m_qsearch
2879 let qsearch = withoutlastutf8 m_qsearch
in
2883 G.postRedisplay "listview empty qsearch";
2884 set1 m_active m_first
E.s;
2888 match search m_active
qsearch ~
-1 with
2890 state
.text <- qsearch ^
" [not found]";
2893 state
.text <- qsearch;
2894 active, firstof m_first
active
2896 G.postRedisplay "listview backspace qsearch";
2897 set1 active first qsearch
2900 | key when (key != 0 && key land 0xff00 != 0xff00) ->
2901 let pattern = m_qsearch ^ toutf8
key in
2903 match search m_active
pattern 1 with
2905 state
.text <- pattern ^
" [not found]";
2908 state
.text <- pattern;
2909 active, firstof m_first
active
2911 G.postRedisplay "listview qsearch add";
2912 set1 active first pattern;
2916 if emptystr m_qsearch
2918 G.postRedisplay "list view escape";
2919 let mx, my
= state
.mpos
in
2923 source#exit ~uioh
:(coe self
)
2924 ~cancel
:true ~
active:m_active ~
first:m_first ~pan
:m_pan
2926 | None
-> m_prev_uioh
2931 G.postRedisplay "list view kill qsearch";
2932 coe {< m_qsearch
= E.s >}
2935 | @enter
| @kpenter
->
2937 let self = {< m_qsearch
= E.s >} in
2939 G.postRedisplay "listview enter";
2940 if m_active
>= 0 && m_active
< source#getitemcount
2942 source#exit ~uioh
:(coe self) ~cancel
:false
2943 ~
active:m_active ~
first:m_first ~pan
:m_pan
;
2946 source#exit ~uioh
:(coe self) ~cancel
:true
2947 ~
active:m_active ~
first:m_first ~pan
:m_pan
;
2950 begin match opt with
2951 | None
-> m_prev_uioh
2955 | @delete
| @kpdelete
->
2958 | @up
| @kpup
-> navigate ~
-1
2959 | @down
| @kpdown
-> navigate 1
2960 | @prior
| @kpprior
-> navigate ~
-(fstate
.maxrows
)
2961 | @next | @kpnext
-> navigate fstate
.maxrows
2963 | @right
| @kpright
->
2965 G.postRedisplay "listview right";
2966 coe {< m_pan
= m_pan
- 1 >}
2968 | @left | @kpleft
->
2970 G.postRedisplay "listview left";
2971 coe {< m_pan
= m_pan
+ 1 >}
2973 | @home
| @kphome
->
2974 let active = find 0 1 in
2975 G.postRedisplay "listview home";
2979 let first = max
0 (itemcount - fstate
.maxrows
) in
2980 let active = find (itemcount - 1) ~
-1 in
2981 G.postRedisplay "listview end";
2984 | key when (key = 0 || key land 0xff00 = 0xff00) ->
2988 dolog
"listview unknown key %#x" key; coe self
2990 method key key mask
=
2991 match state
.mode
with
2992 | Textentry te
-> textentrykeyboard key mask te
; coe self
2995 | LinkNav
_ -> self#key1
key mask
2997 method button button down
x y _ =
3000 | 1 when vscrollhit x ->
3001 G.postRedisplay "listview scroll";
3004 let _, position, sh = self#
scrollph in
3005 if y > truncate
position && y < truncate
(position +. sh)
3007 state
.mstate
<- Mscrolly
;
3011 let s = float (max
0 (y - conf
.scrollh
)) /. float state
.winh
in
3012 let first = truncate
(s *. float source#getitemcount
) in
3013 let first = min source#getitemcount
first in
3014 Some
(coe {< m_first
= first; m_active
= first >})
3016 state
.mstate
<- Mnone
;
3020 begin match self#elemunder
y with
3022 G.postRedisplay "listview click";
3023 source#exit ~uioh
:(coe {< m_active
= n >})
3024 ~cancel
:false ~
active:n ~
first:m_first ~pan
:m_pan
3028 | n when (n == 4 || n == 5) && not down
->
3029 let len = source#getitemcount
in
3031 if n = 5 && m_first
+ fstate
.maxrows
>= len
3035 let first = m_first
+ (if n == 4 then -1 else 1) in
3036 bound
first 0 (len - 1)
3038 G.postRedisplay "listview wheel";
3039 Some
(coe {< m_first
= first >})
3040 | n when (n = 6 || n = 7) && not down
->
3041 let inc = if n = 7 then -1 else 1 in
3042 G.postRedisplay "listview hwheel";
3043 Some
(coe {< m_pan
= m_pan
+ inc >})
3048 | None
-> m_prev_uioh
3051 method multiclick
_ x y = self#button
1 true x y
3054 match state
.mstate
with
3056 let s = float (max
0 (y - conf
.scrollh
)) /. float state
.winh
in
3057 let first = truncate
(s *. float source#getitemcount
) in
3058 let first = min source#getitemcount
first in
3059 G.postRedisplay "listview motion";
3060 coe {< m_first
= first; m_active
= first >}
3068 method pmotion
x y =
3069 if x < state
.winw
- conf
.scrollbw
3072 match self#elemunder
y with
3073 | None
-> Wsi.setcursor
Wsi.CURSOR_INHERIT
; m_active
3074 | Some
n -> Wsi.setcursor
Wsi.CURSOR_INFO
; n
3078 then (G.postRedisplay "listview pmotion"; {< m_active
= n >})
3083 Wsi.setcursor
Wsi.CURSOR_INHERIT
;
3087 method infochanged
_ = ()
3089 method scrollpw
= (0, 0.0, 0.0)
3091 let nfs = fstate
.fontsize
+ 1 in
3092 let y = m_first
* nfs in
3093 let itemcount = source#getitemcount
in
3094 let maxi = max
0 (itemcount - fstate
.maxrows
) in
3095 let maxy = maxi * nfs in
3096 let p, h = scrollph y maxy in
3099 method modehash
= modehash
3100 method eformsgs
= false
3101 method alwaysscrolly
= true
3104 class outlinelistview ~zebra ~source
=
3105 let settext autonarrow
s =
3108 let ss = source#statestr
in
3112 else "{" ^
ss ^
"} [" ^
s ^
"]"
3113 else state
.text <- s
3119 ~source
:(source
:> lvsource
)
3121 ~modehash
:(findkeyhash conf
"outline")
3124 val m_autonarrow
= false
3126 method! key key mask
=
3128 if emptystr state
.text
3130 else fstate
.maxrows - 2
3132 let calcfirst first active =
3135 let rows = active - first in
3136 if rows > maxrows then active - maxrows else first
3140 let active = m_active
+ incr in
3141 let active = bound
active 0 (source#getitemcount
- 1) in
3142 let first = calcfirst m_first
active in
3143 G.postRedisplay "outline navigate";
3144 coe {< m_active
= active; m_first
= first >}
3146 let navscroll first =
3148 let dist = m_active
- first in
3154 else first + maxrows
3157 G.postRedisplay "outline navscroll";
3158 coe {< m_first
= first; m_active
= active >}
3160 let ctrl = Wsi.withctrl mask
in
3165 then (source#denarrow
; E.s)
3167 let pattern = source#renarrow
in
3168 if nonemptystr m_qsearch
3169 then (source#narrow m_qsearch
; m_qsearch
)
3173 settext (not m_autonarrow
) text;
3174 G.postRedisplay "toggle auto narrowing";
3175 coe {< m_first
= 0; m_active
= 0; m_autonarrow
= not m_autonarrow
>}
3177 | @slash
when emptystr m_qsearch
&& not m_autonarrow
->
3179 G.postRedisplay "toggle auto narrowing";
3180 coe {< m_first
= 0; m_active
= 0; m_autonarrow
= true >}
3183 source#narrow m_qsearch
;
3185 then source#add_narrow_pattern m_qsearch
;
3186 G.postRedisplay "outline ctrl-n";
3187 coe {< m_first
= 0; m_active
= 0 >}
3190 let active = source#calcactive
(getanchor
()) in
3191 let first = firstof m_first
active in
3192 G.postRedisplay "outline ctrl-s";
3193 coe {< m_first
= first; m_active
= active >}
3196 G.postRedisplay "outline ctrl-u";
3197 if m_autonarrow
&& nonemptystr m_qsearch
3199 ignore
(source#renarrow
);
3200 settext m_autonarrow
E.s;
3201 coe {< m_first
= 0; m_active
= 0; m_qsearch
= E.s >}
3204 source#del_narrow_pattern
;
3205 let pattern = source#renarrow
in
3207 if emptystr
pattern then E.s else "Narrowed to " ^
pattern
3209 settext m_autonarrow
text;
3210 coe {< m_first
= 0; m_active
= 0; m_qsearch
= E.s >}
3214 let first = max
0 (m_active
- (fstate
.maxrows / 2)) in
3215 G.postRedisplay "outline ctrl-l";
3216 coe {< m_first
= first >}
3218 | @tab
when m_autonarrow
->
3219 if nonemptystr m_qsearch
3221 G.postRedisplay "outline list view tab";
3222 source#add_narrow_pattern m_qsearch
;
3224 coe {< m_qsearch
= E.s >}
3228 | @escape
when m_autonarrow
->
3229 if nonemptystr m_qsearch
3230 then source#add_narrow_pattern m_qsearch
;
3233 | @enter
| @kpenter
when m_autonarrow
->
3234 if nonemptystr m_qsearch
3235 then source#add_narrow_pattern m_qsearch
;
3238 | key when m_autonarrow
&& (key != 0 && key land 0xff00 != 0xff00) ->
3239 let pattern = m_qsearch ^ toutf8
key in
3240 G.postRedisplay "outlinelistview autonarrow add";
3241 source#narrow
pattern;
3242 settext true pattern;
3243 coe {< m_first
= 0; m_active
= 0; m_qsearch
= pattern >}
3245 | key when m_autonarrow
&& key = @backspace
->
3246 if emptystr m_qsearch
3249 let pattern = withoutlastutf8 m_qsearch
in
3250 G.postRedisplay "outlinelistview autonarrow backspace";
3251 ignore
(source#renarrow
);
3252 source#narrow
pattern;
3253 settext true pattern;
3254 coe {< m_first
= 0; m_active
= 0; m_qsearch
= pattern >}
3256 | @up
| @kpup
when ctrl ->
3257 navscroll (max
0 (m_first
- 1))
3259 | @down
| @kpdown
when ctrl ->
3260 navscroll (min
(source#getitemcount
- 1) (m_first
+ 1))
3262 | @up
| @kpup
-> navigate ~
-1
3263 | @down
| @kpdown
-> navigate 1
3264 | @prior
| @kpprior
-> navigate ~
-(fstate
.maxrows)
3265 | @next | @kpnext
-> navigate fstate
.maxrows
3267 | @right
| @kpright
->
3271 G.postRedisplay "outline ctrl right";
3272 {< m_pan
= m_pan
+ 1 >}
3274 else self#updownlevel
1
3278 | @left | @kpleft
->
3282 G.postRedisplay "outline ctrl left";
3283 {< m_pan
= m_pan
- 1 >}
3285 else self#updownlevel ~
-1
3289 | @home
| @kphome
->
3290 G.postRedisplay "outline home";
3291 coe {< m_first
= 0; m_active
= 0 >}
3294 let active = source#getitemcount
- 1 in
3295 let first = max
0 (active - fstate
.maxrows) in
3296 G.postRedisplay "outline end";
3297 coe {< m_active
= active; m_first
= first >}
3299 | _ -> super#
key key mask
3302 let genhistoutlines () =
3304 |> List.sort
(fun (_, c1
, _, _, _, _) (_, c2
, _, _, _, _) ->
3305 compare c2
.lastvisit c1
.lastvisit
)
3307 (fun ((path
, c, _, _, _, origin
) as hist
) ->
3308 let path = if nonemptystr origin
then origin
else path in
3309 let base = mbtoutf8
@@ Filename.basename
path in
3310 (base ^
"\000" ^
c.title
, 1, Ohistory hist
)
3315 let gotohist (path, c, bookmarks
, x, anchor, origin
) =
3316 Config.save
leavebirdseye;
3317 state
.anchor <- anchor;
3318 state
.bookmarks
<- bookmarks
;
3319 state
.origin
<- origin
;
3322 let x0, y0, x1, y1 = conf
.trimfuzz
in
3323 wcmd "trimset %d %d %d %d %d" (btod conf
.trimmargins
) x0 y0 x1 y1;
3324 reshape ~firsttime
:true state
.winw state
.winh
;
3325 opendoc path origin
;
3329 let makecheckers () =
3330 (* Based on lablGL-1.04/LablGlut/examples/lablGL/checker.ml which had
3332 converted by Issac Trotts. July 25, 2002 *)
3333 let image = GlPix.create `ubyte ~format
:`luminance ~width
:2 ~height
:2 in
3334 Raw.sets_string
(GlPix.to_raw
image) ~
pos:0 "\255\200\200\255";
3335 let id = GlTex.gen_texture
() in
3336 GlTex.bind_texture ~target
:`texture_2d
id;
3337 GlPix.store
(`unpack_alignment
1);
3338 GlTex.image2d
image;
3339 List.iter
(GlTex.parameter ~target
:`texture_2d
)
3340 [ `mag_filter `nearest
; `min_filter `nearest
];
3344 let setcheckers enabled
=
3345 match state
.checkerstexid
with
3347 if enabled
then state
.checkerstexid
<- Some
(makecheckers ())
3349 | Some checkerstexid
->
3352 GlTex.delete_texture checkerstexid
;
3353 state
.checkerstexid
<- None
;
3357 let describe_location () =
3358 let fn = page_of_y state
.y in
3359 let ln = page_of_y
(state
.y + state
.winh
- hscrollh () - 1) in
3360 let maxy = state
.maxy - (if conf
.maxhfit
then state
.winh
else 0) in
3364 else (100. *. (float state
.y /. float maxy))
3368 Printf.sprintf
"page %d of %d [%.2f%%]"
3369 (fn+1) state
.pagecount
percent
3372 "pages %d-%d of %d [%.2f%%]"
3373 (fn+1) (ln+1) state
.pagecount
percent
3376 let setpresentationmode v
=
3377 let n = page_of_y state
.y in
3378 state
.anchor <- (n, 0.0, 1.0);
3379 conf
.presentation
<- v
;
3380 if conf
.fitmodel
= FitPage
3381 then reqlayout conf
.angle conf
.fitmodel
;
3385 let setbgcol (r
, g, b) =
3387 let r = r *. 255.0 |> truncate
3388 and g = g *. 255.0 |> truncate
3389 and b = b *. 255.0 |> truncate
in
3390 r lsl 16 |> (lor) (g lsl 8) |> (lor) b
3392 Wsi.setwinbgcol
col;
3396 let btos b = if b then "@Uradical" else E.s in
3397 let showextended = ref false in
3398 let leave mode
_ = state
.mode
<- mode
in
3401 val mutable m_l
= []
3402 val mutable m_a
= E.a
3403 val mutable m_prev_uioh
= nouioh
3404 val mutable m_prev_mode
= View
3406 inherit lvsourcebase
3408 method reset prev_mode prev_uioh
=
3409 m_a
<- Array.of_list
(List.rev m_l
);
3411 m_prev_mode
<- prev_mode
;
3412 m_prev_uioh
<- prev_uioh
;
3414 method int name get
set =
3416 (name
, `
int get
, 1, Action
(
3419 try set (int_of_string
s)
3421 state
.text <- Printf.sprintf
"bad integer `%s': %s"
3425 let te = name ^
": ", E.s, None
, intentry, ondone, true in
3426 state
.mode
<- Textentry
(te, leave m_prev_mode
);
3430 method int_with_suffix name get
set =
3432 (name
, `intws get
, 1, Action
(
3435 try set (int_of_string_with_suffix
s)
3437 state
.text <- Printf.sprintf
"bad integer `%s': %s"
3442 name ^
": ", E.s, None
, intentry_with_suffix, ondone, true
3444 state
.mode
<- Textentry
(te, leave m_prev_mode
);
3448 method bool ?
(offset
=1) ?
(btos=btos) name get
set =
3450 (name
, `
bool (btos, get
), offset
, Action
(
3457 method color name get
set =
3459 (name
, `
color get
, 1, Action
(
3461 let invalid = (nan
, nan
, nan
) in
3464 try color_of_string
s
3466 state
.text <- Printf.sprintf
"bad color `%s': %s"
3473 let te = name ^
": ", E.s, None
, textentry, ondone, true in
3474 state
.text <- color_to_string
(get
());
3475 state
.mode
<- Textentry
(te, leave m_prev_mode
);
3479 method string name get
set =
3481 (name
, `
string get
, 1, Action
(
3483 let ondone s = set s in
3484 let te = name ^
": ", E.s, None
, textentry, ondone, true in
3485 state
.mode
<- Textentry
(te, leave m_prev_mode
);
3489 method colorspace name get
set =
3491 (name
, `
string get
, 1, Action
(
3495 inherit lvsourcebase
3498 m_active
<- CSTE.to_int conf
.colorspace
;
3501 method getitemcount
=
3502 Array.length
CSTE.names
3505 method exit ~uioh ~cancel ~
active ~
first ~pan
=
3506 ignore
(uioh
, first, pan
);
3507 if not cancel
then set active;
3509 method hasaction
_ = true
3513 let modehash = findkeyhash conf
"info" in
3514 coe (new listview ~zebra
:false ~helpmode
:false
3515 ~
source ~trusted
:true ~
modehash)
3518 method paxmark name get
set =
3520 (name
, `
string get
, 1, Action
(
3524 inherit lvsourcebase
3527 m_active
<- MTE.to_int conf
.paxmark
;
3530 method getitemcount
= Array.length
MTE.names
3531 method getitem
n = (MTE.names
.(n), 0)
3532 method exit ~uioh ~cancel ~
active ~
first ~pan
=
3533 ignore
(uioh
, first, pan
);
3534 if not cancel
then set active;
3536 method hasaction
_ = true
3540 let modehash = findkeyhash conf
"info" in
3541 coe (new listview ~zebra
:false ~helpmode
:false
3542 ~
source ~trusted
:true ~
modehash)
3545 method fitmodel name get
set =
3547 (name
, `
string get
, 1, Action
(
3551 inherit lvsourcebase
3554 m_active
<- FMTE.to_int conf
.fitmodel
;
3557 method getitemcount
= Array.length
FMTE.names
3558 method getitem
n = (FMTE.names
.(n), 0)
3559 method exit ~uioh ~cancel ~
active ~
first ~pan
=
3560 ignore
(uioh
, first, pan
);
3561 if not cancel
then set active;
3563 method hasaction
_ = true
3567 let modehash = findkeyhash conf
"info" in
3568 coe (new listview ~zebra
:false ~helpmode
:false
3569 ~
source ~trusted
:true ~
modehash)
3572 method caption
s offset
=
3573 m_l
<- (s, `empty
, offset
, Noaction
) :: m_l
3575 method caption2
s f offset
=
3576 m_l
<- (s, `
string f, offset
, Noaction
) :: m_l
3578 method getitemcount
= Array.length m_a
3581 let tostr = function
3582 | `
int f -> string_of_int
(f ())
3583 | `intws
f -> string_with_suffix_of_int
(f ())
3585 | `
color f -> color_to_string
(f ())
3586 | `
bool (btos, f) -> btos (f ())
3589 let name, t
, offset
, _ = m_a
.(n) in
3590 ((let s = tostr t
in
3592 then Printf.sprintf
"%s\t%s" name s
3596 method exit ~uioh ~cancel ~
active ~
first ~pan
=
3601 match m_a
.(active) with
3602 | _, _, _, Action
f -> f uioh
3603 | _, _, _, Noaction
-> uioh
3614 method hasaction
n =
3616 | _, _, _, Action
_ -> true
3617 | _, _, _, Noaction
-> false
3619 initializer m_active
<- 1
3622 let rec fillsrc prevmode prevuioh
=
3623 let sep () = src#caption
E.s 0 in
3624 let colorp name get
set =
3626 (fun () -> color_to_string
(get
()))
3629 let c = color_of_string
v in
3632 state
.text <- Printf.sprintf
"bad color `%s': %s" v @@ exntos exn
3635 let oldmode = state
.mode
in
3636 let birdseye = isbirdseye state
.mode
in
3638 src#caption
(if birdseye then "Setup (Bird's eye)" else "Setup") 0;
3640 src#
bool "presentation mode"
3641 (fun () -> conf
.presentation
)
3642 (fun v -> setpresentationmode v);
3644 src#
bool "ignore case in searches"
3645 (fun () -> conf
.icase
)
3646 (fun v -> conf
.icase
<- v);
3649 (fun () -> conf
.preload)
3650 (fun v -> conf
.preload <- v);
3652 src#
bool "highlight links"
3653 (fun () -> conf
.hlinks
)
3654 (fun v -> conf
.hlinks
<- v);
3656 src#
bool "under info"
3657 (fun () -> conf
.underinfo
)
3658 (fun v -> conf
.underinfo
<- v);
3660 src#
bool "persistent bookmarks"
3661 (fun () -> conf
.savebmarks
)
3662 (fun v -> conf
.savebmarks
<- v);
3664 src#fitmodel
"fit model"
3665 (fun () -> FMTE.to_string conf
.fitmodel
)
3666 (fun v -> reqlayout conf
.angle
(FMTE.of_int
v));
3668 src#
bool "trim margins"
3669 (fun () -> conf
.trimmargins
)
3670 (fun v -> settrim v conf
.trimfuzz
; fillsrc prevmode prevuioh
);
3672 src#
bool "persistent location"
3673 (fun () -> conf
.jumpback
)
3674 (fun v -> conf
.jumpback
<- v);
3677 src#
int "inter-page space"
3678 (fun () -> conf
.interpagespace
)
3680 conf
.interpagespace
<- n;
3681 docolumns conf
.columns
;
3683 match state
.layout with
3688 state
.maxy <- calcheight
();
3689 let y = getpagey
pageno in
3694 (fun () -> conf
.pagebias
)
3695 (fun v -> conf
.pagebias
<- v);
3697 src#
int "scroll step"
3698 (fun () -> conf
.scrollstep
)
3699 (fun n -> conf
.scrollstep
<- n);
3701 src#
int "horizontal scroll step"
3702 (fun () -> conf
.hscrollstep
)
3703 (fun v -> conf
.hscrollstep
<- v);
3705 src#
int "auto scroll step"
3707 match state
.autoscroll
with
3709 | _ -> conf
.autoscrollstep
)
3711 let n = boundastep state
.winh
n in
3712 if state
.autoscroll
<> None
3713 then state
.autoscroll
<- Some
n;
3714 conf
.autoscrollstep
<- n);
3717 (fun () -> truncate
(conf
.zoom *. 100.))
3718 (fun v -> setzoom ((float v) /. 100.));
3721 (fun () -> conf
.angle
)
3722 (fun v -> reqlayout v conf
.fitmodel
);
3724 src#
int "scroll bar width"
3725 (fun () -> conf
.scrollbw
)
3728 reshape state
.winw state
.winh
;
3731 src#
int "scroll handle height"
3732 (fun () -> conf
.scrollh
)
3733 (fun v -> conf
.scrollh
<- v;);
3735 src#
int "thumbnail width"
3736 (fun () -> conf
.thumbw
)
3738 conf
.thumbw
<- min
4096 v;
3741 leavebirdseye beye
false;
3748 let mode = state
.mode in
3749 src#
string "columns"
3751 match conf
.columns
with
3753 | Cmulti
(multi
, _) -> multicolumns_to_string multi
3754 | Csplit
(count
, _) -> "-" ^ string_of_int count
3757 let n, a, b = multicolumns_of_string
v in
3758 setcolumns mode n a b);
3761 src#caption
"Pixmap cache" 0;
3762 src#int_with_suffix
"size (advisory)"
3763 (fun () -> conf
.memlimit
)
3764 (fun v -> conf
.memlimit
<- v);
3767 (fun () -> Printf.sprintf
"%s bytes, %d tiles"
3768 (string_with_suffix_of_int state
.memused
)
3769 (Hashtbl.length state
.tilemap
)) 1;
3772 src#caption
"Layout" 0;
3773 src#caption2
"Dimension"
3775 Printf.sprintf
"%dx%d (virtual %dx%d)"
3776 state
.winw state
.winh
3781 src#caption2
"Position" (fun () ->
3782 Printf.sprintf
"%dx%d" state
.x state
.y
3785 src#caption2
"Position" (fun () -> describe_location ()) 1
3789 src#
bool ~offset
:0 ~
btos:(fun v -> if v then "(on)" else "(off)")
3790 "Save these parameters as global defaults at exit"
3791 (fun () -> conf
.bedefault
)
3792 (fun v -> conf
.bedefault
<- v)
3796 let btos b = if b then "@Ulguillemet" else "@Urguillemet" in
3797 src#
bool ~offset
:0 ~
btos "Extended parameters"
3798 (fun () -> !showextended)
3799 (fun v -> showextended := v; fillsrc prevmode prevuioh
);
3803 (fun () -> conf
.checkers
)
3804 (fun v -> conf
.checkers
<- v; setcheckers v);
3805 src#
bool "update cursor"
3806 (fun () -> conf
.updatecurs
)
3807 (fun v -> conf
.updatecurs
<- v);
3808 src#
bool "scroll-bar on the left"
3809 (fun () -> conf
.leftscroll
)
3810 (fun v -> conf
.leftscroll
<- v);
3812 (fun () -> conf
.verbose
)
3813 (fun v -> conf
.verbose
<- v);
3814 src#
bool "invert colors"
3815 (fun () -> conf
.invert
)
3816 (fun v -> conf
.invert
<- v);
3818 (fun () -> conf
.maxhfit
)
3819 (fun v -> conf
.maxhfit
<- v);
3821 (fun () -> conf
.pax
!= None
)
3824 then conf
.pax
<- Some
(ref (now
(), 0, 0))
3825 else conf
.pax
<- None
);
3826 src#
string "uri launcher"
3827 (fun () -> conf
.urilauncher
)
3828 (fun v -> conf
.urilauncher
<- v);
3829 src#
string "path launcher"
3830 (fun () -> conf
.pathlauncher
)
3831 (fun v -> conf
.pathlauncher
<- v);
3832 src#
string "tile size"
3833 (fun () -> Printf.sprintf
"%dx%d" conf
.tilew conf
.tileh
)
3836 let w, h = Scanf.sscanf
v "%dx%d" (fun w h -> w, h) in
3837 conf
.tilew
<- max
64 w;
3838 conf
.tileh
<- max
64 h;
3841 state
.text <- Printf.sprintf
"bad tile size `%s': %s"
3844 src#
int "texture count"
3845 (fun () -> conf
.texcount
)
3848 then conf
.texcount
<- v
3849 else impmsg "failed to set texture count please retry later"
3851 src#
int "slice height"
3852 (fun () -> conf
.sliceheight
)
3854 conf
.sliceheight
<- v;
3855 wcmd "sliceh %d" conf
.sliceheight
;
3857 src#
int "anti-aliasing level"
3858 (fun () -> conf
.aalevel
)
3860 conf
.aalevel
<- bound
v 0 8;
3861 state
.anchor <- getanchor
();
3862 opendoc state
.path state
.password;
3864 src#
string "page scroll scaling factor"
3865 (fun () -> string_of_float conf
.pgscale)
3868 let s = float_of_string
v in
3871 state
.text <- Printf.sprintf
3872 "bad page scroll scaling factor `%s': %s" v @@ exntos exn
3875 src#
int "ui font size"
3876 (fun () -> fstate
.fontsize
)
3877 (fun v -> setfontsize (bound
v 5 100));
3878 src#
int "hint font size"
3879 (fun () -> conf
.hfsize
)
3880 (fun v -> conf
.hfsize
<- bound
v 5 100);
3881 colorp "background color"
3882 (fun () -> conf
.bgcolor
)
3883 (fun v -> conf
.bgcolor
<- v; setbgcol v);
3884 src#
bool "crop hack"
3885 (fun () -> conf
.crophack
)
3886 (fun v -> conf
.crophack
<- v);
3887 src#
string "trim fuzz"
3888 (fun () -> irect_to_string conf
.trimfuzz
)
3891 conf
.trimfuzz
<- irect_of_string
v;
3893 then settrim true conf
.trimfuzz
;
3895 state
.text <- Printf.sprintf
"bad irect `%s': %s" v @@ exntos exn
3897 src#
string "throttle"
3899 match conf
.maxwait
with
3900 | None
-> "show place holder if page is not ready"
3903 then "wait for page to fully render"
3905 "wait " ^ string_of_float
time
3906 ^
" seconds before showing placeholder"
3910 let f = float_of_string
v in
3912 then conf
.maxwait
<- None
3913 else conf
.maxwait
<- Some
f
3915 state
.text <- Printf.sprintf
"bad time `%s': %s" v @@ exntos exn
3917 src#
string "ghyll scroll"
3919 match conf
.ghyllscroll
with
3921 | Some nab
-> ghyllscroll_to_string nab
3924 try conf
.ghyllscroll
<- ghyllscroll_of_string
v
3927 state
.text <- Printf.sprintf
"bad ghyll `%s': %s" v msg
3929 state
.text <- Printf.sprintf
"bad ghyll `%s': %s" v @@ exntos exn
3931 src#
string "selection command"
3932 (fun () -> conf
.selcmd
)
3933 (fun v -> conf
.selcmd
<- v);
3934 src#
string "synctex command"
3935 (fun () -> conf
.stcmd
)
3936 (fun v -> conf
.stcmd
<- v);
3937 src#
string "pax command"
3938 (fun () -> conf
.paxcmd
)
3939 (fun v -> conf
.paxcmd
<- v);
3940 src#
string "ask password command"
3941 (fun () -> conf
.passcmd)
3942 (fun v -> conf
.passcmd <- v);
3943 src#
string "save path command"
3944 (fun () -> conf
.savecmd
)
3945 (fun v -> conf
.savecmd
<- v);
3946 src#colorspace
"color space"
3947 (fun () -> CSTE.to_string conf
.colorspace
)
3949 conf
.colorspace
<- CSTE.of_int
v;
3953 src#paxmark
"pax mark method"
3954 (fun () -> MTE.to_string conf
.paxmark
)
3955 (fun v -> conf
.paxmark
<- MTE.of_int
v);
3956 if bousable
() && !opengl_has_pbo
3959 (fun () -> conf
.usepbo
)
3960 (fun v -> conf
.usepbo
<- v);
3961 src#
bool "mouse wheel scrolls pages"
3962 (fun () -> conf
.wheelbypage
)
3963 (fun v -> conf
.wheelbypage
<- v);
3964 src#
bool "open remote links in a new instance"
3965 (fun () -> conf
.riani
)
3966 (fun v -> conf
.riani
<- v);
3967 src#
bool "edit annotations inline"
3968 (fun () -> conf
.annotinline
)
3969 (fun v -> conf
.annotinline
<- v);
3970 src#
bool "coarse positioning in presentation mode"
3971 (fun () -> conf
.coarseprespos
)
3972 (fun v -> conf
.coarseprespos
<- v);
3976 src#caption
"Document" 0;
3977 List.iter
(fun (_, s) -> src#caption
s 1) state
.docinfo
;
3978 src#caption2
"Pages"
3979 (fun () -> string_of_int state
.pagecount
) 1;
3980 src#caption2
"Dimensions"
3981 (fun () -> string_of_int
(List.length state
.pdims
)) 1;
3985 src#caption
"Trimmed margins" 0;
3986 src#caption2
"Dimensions"
3987 (fun () -> string_of_int
(List.length state
.pdims
)) 1;
3991 src#caption
"OpenGL" 0;
3992 src#caption
(Printf.sprintf
"Vendor\t%s" (GlMisc.get_string `vendor
)) 1;
3993 src#caption
(Printf.sprintf
"Renderer\t%s" (GlMisc.get_string `renderer
)) 1;
3996 src#caption
"Location" 0;
3997 if nonemptystr state
.origin
3998 then src#caption
("Orign\t" ^ mbtoutf8 state
.origin
) 1;
3999 src#caption
("Path\t" ^ mbtoutf8 state
.path) 1;
4001 src#reset prevmode prevuioh
;
4006 let prevmode = state
.mode
4007 and prevuioh
= state
.uioh in
4008 fillsrc prevmode prevuioh
;
4009 let source = (src :> lvsource
) in
4010 let modehash = findkeyhash conf
"info" in
4011 state
.uioh <- coe (object (self)
4012 inherit listview ~zebra
:false ~helpmode
:false
4013 ~
source ~trusted
:true ~
modehash as super
4014 val mutable m_prevmemused
= 0
4015 method! infochanged
= function
4017 if m_prevmemused
!= state
.memused
4019 m_prevmemused
<- state
.memused
;
4020 G.postRedisplay "memusedchanged";
4022 | Pdim
-> G.postRedisplay "pdimchanged"
4023 | Docinfo
-> fillsrc prevmode prevuioh
4025 method! key key mask
=
4026 if not
(Wsi.withctrl mask
)
4029 | @left | @kpleft
-> coe (self#updownlevel ~
-1)
4030 | @right
| @kpright
-> coe (self#updownlevel
1)
4031 | _ -> super#
key key mask
4032 else super#
key key mask
4034 G.postRedisplay "info";
4040 inherit lvsourcebase
4041 method getitemcount
= Array.length state
.help
4043 let s, l, _ = state
.help
.(n) in
4046 method exit ~
uioh ~cancel ~
active ~
first ~pan
=
4050 match state
.help
.(active) with
4051 | _, _, Action
f -> Some
(f uioh)
4052 | _, _, Noaction
-> Some
uioh
4061 method hasaction
n =
4062 match state
.help
.(n) with
4063 | _, _, Action
_ -> true
4064 | _, _, Noaction
-> false
4070 let modehash = findkeyhash conf
"help" in
4072 state
.uioh <- coe (new listview
4073 ~zebra
:false ~helpmode
:true
4074 ~
source ~trusted
:true ~
modehash);
4075 G.postRedisplay "help";
4081 inherit lvsourcebase
4082 val mutable m_items
= E.a
4084 method getitemcount
= 1 + Array.length m_items
4089 else m_items
.(n-1), 0
4091 method exit ~
uioh ~cancel ~
active ~
first ~pan
=
4096 then Buffer.clear state
.errmsgs
;
4103 method hasaction
n =
4107 state
.newerrmsgs
<- false;
4108 let l = Str.split newlinere
(Buffer.contents state
.errmsgs
) in
4109 m_items
<- Array.of_list
l
4118 let source = (msgsource :> lvsource
) in
4119 let modehash = findkeyhash conf
"listview" in
4120 state
.uioh <- coe (object
4121 inherit listview ~zebra
:false ~helpmode
:false
4122 ~
source ~trusted
:false ~
modehash as super
4125 then msgsource#reset
;
4128 G.postRedisplay "msgs";
4132 let editor = getenvwithdef
"EDITOR" E.s in
4136 let tmppath = Filename.temp_file
"llpp" "note" in
4139 let oc = open_out
tmppath in
4143 let execstr = editor ^
" " ^
tmppath in
4145 match spawn
execstr [] with
4146 | (exception exn
) ->
4147 impmsg "spawn(%S) failed: %s" execstr @@ exntos exn
;
4150 match Unix.waitpid
[] pid with
4151 | (exception exn
) ->
4152 impmsg "waitpid(%d) failed: %s" pid @@ exntos exn
;
4156 | Unix.WEXITED
0 -> filecontents
tmppath
4158 impmsg "editor process(%s) exited abnormally: %d" execstr n;
4160 | Unix.WSIGNALED
n ->
4161 impmsg "editor process(%s) was killed by signal %d" execstr n;
4163 | Unix.WSTOPPED
n ->
4164 impmsg "editor(%s) process was stopped by signal %d" execstr n;
4167 match Unix.unlink
tmppath with
4168 | (exception exn
) ->
4169 impmsg "failed to ulink %S: %s" tmppath @@ exntos exn
;
4174 let enterannotmode opaque slinkindex
=
4177 inherit lvsourcebase
4178 val mutable m_text
= E.s
4179 val mutable m_items
= E.a
4181 method getitemcount
= Array.length m_items
4184 let label, _func
= m_items
.(n) in
4187 method exit ~
uioh ~cancel ~
active ~
first ~pan
=
4188 ignore
(uioh, first, pan
);
4191 let _label, func
= m_items
.(active) in
4196 method hasaction
n = nonemptystr
@@ fst m_items
.(n)
4199 let rec split accu b i
=
4201 if p = String.length
s
4202 then (String.sub
s b (p-b), unit) :: accu
4204 if (i
> 70 && s.[p] = ' '
) || s.[p] = '
\r'
|| s.[p] = '
\n'
4206 let ss = if i
= 0 then E.s else String.sub
s b i
in
4207 split ((ss, unit)::accu) (p+1) 0
4212 wcmd "freepage %s" (~
> opaque);
4214 Hashtbl.fold (fun key opaque'
accu ->
4215 if opaque'
= opaque'
4216 then key :: accu else accu) state
.pagemap
[]
4218 List.iter
(Hashtbl.remove state
.pagemap
) keys;
4223 delannot
opaque slinkindex
;
4226 let edit inline
() =
4231 modannot
opaque slinkindex
s;
4237 let mode = state
.mode in
4240 ("annotation: ", m_text
, None
, textentry, update, true),
4241 fun _ -> state
.mode <- mode);
4245 let s = getusertext m_text
in
4250 ( "[Copy]", fun () -> selstring m_text
)
4251 :: ("[Delete]", dele)
4252 :: ("[Edit]", edit conf
.annotinline
)
4254 :: split [] 0 0 |> List.rev
|> Array.of_list
4261 let s = getannotcontents
opaque slinkindex
in
4264 let source = (msgsource :> lvsource
) in
4265 let modehash = findkeyhash conf
"listview" in
4266 state
.uioh <- coe (object
4267 inherit listview ~zebra
:false ~helpmode
:false
4268 ~
source ~trusted
:false ~
modehash
4270 G.postRedisplay "enterannotmode";
4273 let gotounder under =
4274 let getpath filename
=
4276 if nonemptystr filename
4278 if Filename.is_relative filename
4280 let dir = Filename.dirname state
.path in
4282 if Filename.is_implicit
dir
4283 then Filename.concat
(Sys.getcwd
()) dir
4286 Filename.concat
dir filename
4290 if Sys.file_exists
path
4295 | Ulinkgoto
(pageno, top) ->
4300 if conf
.presentation
&& conf
.coarseprespos
4304 gotopage1 pageno top;
4307 | Ulinkuri
s -> gotouri
s
4309 | Uremote
(filename
, pageno) ->
4310 let path = getpath filename
in
4315 let command = Printf.sprintf
"%s -page %d %S" !selfexec pageno path in
4316 match spawn
command [] with
4318 | (exception exn
) ->
4319 dolog
"failed to execute `%s': %s" command @@ exntos exn
4321 let anchor = getanchor
() in
4322 let ranchor = state
.path, state
.password, anchor, state
.origin
in
4323 state
.origin
<- E.s;
4324 state
.anchor <- (pageno, 0.0, 0.0);
4325 state
.ranchors
<- ranchor :: state
.ranchors
;
4328 else impmsg "cannot find %s" filename
4330 | Uremotedest
(filename
, destname
) ->
4331 let path = getpath filename
in
4336 let command = !selfexec ^
" " ^
path ^
" -dest " ^ destname
in
4337 match spawn
command [] with
4338 | (exception exn
) ->
4339 dolog
"failed to execute `%s': %s" command @@ exntos exn
4342 let anchor = getanchor
() in
4343 let ranchor = state
.path, state
.password, anchor, state
.origin
in
4344 state
.origin
<- E.s;
4345 state
.nameddest
<- destname
;
4346 state
.ranchors
<- ranchor :: state
.ranchors
;
4349 else impmsg "cannot find %s" filename
4351 | Uunexpected
_ | Ulaunch
_ | Unamed
_ | Utext
_ | Unone
-> ()
4352 | Uannotation
(opaque, slinkindex
) -> enterannotmode opaque slinkindex
4355 let gotooutline (_, _, kind
) =
4359 let (pageno, y, _) = anchor in
4361 (if conf
.presentation
then (pageno, y, 1.0) else anchor)
4365 | Ouri
uri -> gotounder (Ulinkuri
uri)
4366 | Olaunch cmd
-> gotounder (Ulaunch cmd
)
4367 | Oremote remote
-> gotounder (Uremote remote
)
4368 | Ohistory hist
-> gotohist hist
4369 | Oremotedest remotedest
-> gotounder (Uremotedest remotedest
)
4372 class outlinesoucebase fetchoutlines
= object (self)
4373 inherit lvsourcebase
4374 val mutable m_items
= E.a
4375 val mutable m_minfo
= E.a
4376 val mutable m_orig_items
= E.a
4377 val mutable m_orig_minfo
= E.a
4378 val mutable m_narrow_patterns
= []
4379 val mutable m_gen
= -1
4381 method getitemcount
= Array.length m_items
4384 let s, n, _ = m_items
.(n) in
4387 method exit ~
(uioh:uioh) ~cancel ~
active ~
(first:int) ~pan
:
4389 ignore
(uioh, first);
4391 if m_narrow_patterns
= []
4392 then m_orig_items
, m_orig_minfo
4393 else m_items
, m_minfo
4400 gotooutline m_items
.(active);
4408 method hasaction
(_:int) = true
4411 if Array.length m_items
!= Array.length m_orig_items
4414 match m_narrow_patterns
with
4416 | many
-> String.concat
"@Uellipsis" (List.rev many
)
4418 "Narrowed to " ^
s ^
" (ctrl-u to restore)"
4422 match m_narrow_patterns
with
4425 | head
:: _ -> "@Uellipsis" ^ head
4427 method narrow
pattern =
4428 match Str.regexp_case_fold
pattern with
4429 | (exception _) -> ()
4431 let rec loop accu minfo n =
4434 m_items
<- Array.of_list
accu;
4435 m_minfo
<- Array.of_list
minfo;
4438 let (s, _, _) as o = m_items
.(n) in
4440 match Str.search_forward re
s 0 with
4441 | (exception Not_found
) -> accu, minfo
4442 | first -> o :: accu, (first, Str.match_end
()) :: minfo
4444 loop accu minfo (n-1)
4446 loop [] [] (Array.length m_items
- 1)
4448 method! getminfo
= m_minfo
4451 m_orig_items
<- fetchoutlines
();
4452 m_minfo
<- m_orig_minfo
;
4453 m_items
<- m_orig_items
4455 method add_narrow_pattern
pattern =
4456 m_narrow_patterns
<- pattern :: m_narrow_patterns
4458 method del_narrow_pattern
=
4459 match m_narrow_patterns
with
4460 | _ :: rest
-> m_narrow_patterns
<- rest
4465 match m_narrow_patterns
with
4466 | pattern :: [] -> self#narrow
pattern; pattern
4468 List.fold_left
(fun accu pattern ->
4469 self#narrow
pattern;
4470 pattern ^
"@Uellipsis" ^
accu) E.s list
4472 method calcactive
(_:anchor) = 0
4474 method reset
anchor items =
4475 if state
.gen
!= m_gen
4477 m_orig_items
<- items;
4479 m_narrow_patterns
<- [];
4481 m_orig_minfo
<- E.a;
4485 if items != m_orig_items
4487 m_orig_items
<- items;
4488 if m_narrow_patterns
== []
4489 then m_items
<- items;
4492 let active = self#calcactive
anchor in
4494 m_first
<- firstof m_first
active
4498 let outlinesource fetchoutlines
=
4500 inherit outlinesoucebase fetchoutlines
4501 method! calcactive
anchor =
4502 let rely = getanchory anchor in
4503 let rec loop n best bestd
=
4504 if n = Array.length m_items
4507 let _, _, kind
= m_items
.(n) in
4510 let orely = getanchory anchor in
4511 let d = abs
(orely - rely) in
4514 else loop (n+1) best bestd
4515 | Onone
| Oremote
_ | Olaunch
_
4516 | Oremotedest
_ | Ouri
_ | Ohistory
_ ->
4517 loop (n+1) best bestd
4523 let enteroutlinemode, enterbookmarkmode
, enterhistmode
=
4524 let mkselector sourcetype
=
4525 let fetchoutlines () =
4526 match sourcetype
with
4527 | `bookmarks
-> Array.of_list state
.bookmarks
4528 | `outlines
-> state
.outlines
4529 | `history
-> genhistoutlines ()
4532 if sourcetype
= `history
4533 then new outlinesoucebase
fetchoutlines
4534 else outlinesource fetchoutlines
4537 let outlines = fetchoutlines () in
4538 if Array.length
outlines = 0
4540 showtext ' ' errmsg
;
4544 Wsi.setcursor
Wsi.CURSOR_INHERIT
;
4545 let anchor = getanchor
() in
4546 source#reset
anchor outlines;
4547 state
.text <- source#greetmsg
;
4549 coe (new outlinelistview ~zebra
:(sourcetype
=`history
) ~
source);
4550 G.postRedisplay "enter selector";
4553 let mkenter sourcetype errmsg
=
4554 let enter = mkselector sourcetype
in
4555 fun () -> enter errmsg
4557 (**)mkenter `
outlines "document has no outline"
4558 , mkenter `bookmarks
"document has no bookmarks (yet)"
4559 , mkenter `history
"history is empty"
4562 let quickbookmark ?title
() =
4563 match state
.layout with
4569 let tm = Unix.localtime
(now
()) in
4571 "Quick (page %d) (bookmarked at %02d/%02d/%d %02d:%02d)"
4575 (tm.Unix.tm_year
+ 1900)
4578 | Some
title -> title
4580 state
.bookmarks
<- (title, 0, Oanchor
(getanchor1
l)) :: state
.bookmarks
4583 let setautoscrollspeed step goingdown
=
4584 let incr = max
1 ((abs step
) / 2) in
4585 let incr = if goingdown
then incr else -incr in
4586 let astep = boundastep state
.winh
(step
+ incr) in
4587 state
.autoscroll
<- Some
astep;
4591 match conf
.columns
with
4593 | Csingle
_ | Cmulti
_ -> state
.x != 0 || conf
.zoom > 1.0
4596 let panbound x = bound
x (-state
.w) (wadjsb () + state
.winw
);;
4598 let existsinrow pageno (columns
, coverA
, coverB
) p =
4599 let last = ((pageno - coverA
) mod columns
) + columns
in
4600 let rec any = function
4603 if l.pageno = coverA
- 1 || l.pageno = state
.pagecount
- coverB
4607 then (if l.pageno = last then false else any rest
)
4615 match state
.layout with
4617 let pageno = page_of_y state
.y in
4618 gotoghyll (getpagey
(pageno+1))
4620 match conf
.columns
with
4622 if conf
.presentation
&& rest
== [] && l.pageh
> l.pagey + l.pagevh
4624 let y = clamp (pgscale state
.winh
) in
4627 let pageno = min
(l.pageno+1) (state
.pagecount
-1) in
4628 gotoghyll (getpagey
pageno)
4629 | Cmulti
((c, _, _) as cl
, _) ->
4630 if conf
.presentation
4631 && (existsinrow l.pageno cl
4632 (fun l -> l.pageh
> l.pagey + l.pagevh))
4634 let y = clamp (pgscale state
.winh
) in
4637 let pageno = min
(l.pageno+c) (state
.pagecount
-1) in
4638 gotoghyll (getpagey
pageno)
4640 if l.pageno < state
.pagecount
- 1 || l.pagecol
< n - 1
4642 let pagey, pageh
= getpageyh
l.pageno in
4643 let pagey = pagey + pageh
* l.pagecol
in
4644 let ips = if l.pagecol
= 0 then 0 else conf
.interpagespace
in
4645 gotoghyll (pagey + pageh
+ ips)
4649 match state
.layout with
4651 let pageno = page_of_y state
.y in
4652 gotoghyll (getpagey
(pageno-1))
4654 match conf
.columns
with
4656 if conf
.presentation
&& l.pagey != 0
4658 gotoghyll (clamp (pgscale ~
-(state
.winh
)))
4660 let pageno = max
0 (l.pageno-1) in
4661 gotoghyll (getpagey
pageno)
4662 | Cmulti
((c, _, coverB
) as cl
, _) ->
4663 if conf
.presentation
&&
4664 (existsinrow l.pageno cl
(fun l -> l.pagey != 0))
4666 gotoghyll (clamp (pgscale ~
-(state
.winh
)))
4669 if l.pageno = state
.pagecount
- coverB
4673 let pageno = max
0 (l.pageno-decr) in
4674 gotoghyll (getpagey
pageno)
4682 let pageno = max
0 (l.pageno-1) in
4683 let pagey, pageh
= getpageyh
pageno in
4686 let pagey, pageh
= getpageyh
l.pageno in
4687 pagey + pageh
* (l.pagecol
-1) - conf
.interpagespace
4693 if emptystr conf
.savecmd
4694 then error
"don't know where to save modified document"
4696 let savecmd = Str.global_replace percentsre state
.path conf
.savecmd in
4699 (fun s -> error
"failed to obtain path to the saved copy: %s" s)
4704 let tmp = path ^
".tmp" in
4706 Unix.rename
tmp path;
4709 let viewkeyboard key mask
=
4711 let mode = state
.mode in
4712 state
.mode <- Textentry
(te, fun _ -> state
.mode <- mode);
4715 G.postRedisplay "view:enttext"
4717 let ctrl = Wsi.withctrl mask
in
4719 if key >= 0xffb0 && key < 0xffb9 then key - 0xffb0 + 48 else key
4725 if hasunsavedchanges
()
4729 if conf
.angle
mod 360 = 0 && not
(isbirdseye state
.mode)
4731 state
.mode <- LinkNav
(Ltgendir
0);
4734 else impmsg "keyboard link navigation does not work under rotation"
4737 begin match state
.mstate
with
4740 G.postRedisplay "kill rect";
4743 | Mscrolly
| Mscrollx
4746 begin match state
.mode with
4749 G.postRedisplay "esc leave linknav"
4753 match state
.ranchors
with
4755 | (path, password, anchor, origin
) :: rest
->
4756 state
.ranchors
<- rest
;
4757 state
.anchor <- anchor;
4758 state
.origin
<- origin
;
4759 state
.nameddest
<- E.s;
4760 opendoc path password
4765 gotoghyll (getnav ~
-1)
4776 Hashtbl.iter
(fun _ opaque ->
4778 Hashtbl.clear state
.prects
) state
.pagemap
;
4779 G.postRedisplay "dehighlight";
4781 | @slash
| @question
->
4782 let ondone isforw
s =
4783 cbput state
.hists
.pat
s;
4784 state
.searchpattern
<- s;
4787 let s = String.make
1 (Char.chr
key) in
4788 enttext (s, E.s, Some
(onhist state
.hists
.pat
),
4789 textentry, ondone (key = @slash
), true)
4791 | @plus
| @kpplus
| @equals
when ctrl ->
4792 let incr = if conf
.zoom +. 0.01 > 0.1 then 0.1 else 0.01 in
4793 setzoom (conf
.zoom +. incr)
4795 | @plus
| @kpplus
->
4798 try int_of_string
s with exc
->
4799 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exc
;
4805 state
.text <- "page bias is now " ^ string_of_int
n;
4808 enttext ("page bias: ", E.s, None
, intentry, ondone, true)
4810 | @minus
| @kpminus
when ctrl ->
4811 let decr = if conf
.zoom -. 0.1 < 0.1 then 0.01 else 0.1 in
4812 setzoom (max
0.01 (conf
.zoom -. decr))
4814 | @minus
| @kpminus
->
4815 let ondone msg
= state
.text <- msg
in
4817 "option [acfhilpstvxACFPRSZTISM]: ", E.s, None
,
4818 optentry state
.mode, ondone, true
4829 | (@1 | @2) when ctrl && conf
.fitmodel
!= FitPage
-> (* ctrl-1/2 *)
4831 match conf
.columns
with
4832 | Csingle
_ | Cmulti
_ -> 1
4833 | Csplit
(n, _) -> n
4835 let h = state
.winh
-
4836 conf
.interpagespace
lsl (if conf
.presentation
then 1 else 0)
4838 let zoom = zoomforh state
.winw
h (vscrollw ()) cols in
4839 if zoom > 0.0 && (key = @2 || zoom < 1.0)
4844 match conf
.fitmodel
with
4845 | FitWidth
-> FitProportional
4846 | FitProportional
-> FitPage
4847 | FitPage
-> FitWidth
4849 state
.text <- "fit model: " ^
FMTE.to_string
fm;
4850 reqlayout conf
.angle
fm
4852 | @4 when ctrl -> (* ctrl-4 *)
4853 let zoom = getmaxw
() /. float state
.winw
in
4854 if zoom > 0.0 then setzoom zoom
4862 | (48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57)
4863 when not
ctrl -> (* 0..9 *)
4866 try int_of_string
s with exc
->
4867 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exc
;
4873 cbput state
.hists
.pag
(string_of_int
n);
4874 gotopage1 (n + conf
.pagebias
- 1) 0;
4877 let pageentry text key =
4878 match Char.unsafe_chr
key with
4879 | '
g'
-> TEdone
text
4880 | _ -> intentry text key
4882 let text = String.make
1 (Char.chr
key) in
4883 enttext (":", text, Some
(onhist state
.hists
.pag
),
4884 pageentry, ondone, true)
4887 conf
.scrollb
<- if conf
.scrollb
= 0 then (scrollbvv
lor scrollbhv
) else 0;
4888 reshape state
.winw state
.winh
;
4891 state
.bzoom
<- not state
.bzoom
;
4893 showtext ' '
("block zoom " ^
if state
.bzoom
then "on" else "off")
4896 conf
.hlinks
<- not conf
.hlinks
;
4897 state
.text <- "highlightlinks " ^
if conf
.hlinks
then "on" else "off";
4898 G.postRedisplay "toggle highlightlinks";
4901 if conf
.angle
mod 360 = 0
4903 state
.glinks
<- true;
4904 let mode = state
.mode in
4907 (":", E.s, None
, linknentry, linknact gotounder, false),
4909 state
.glinks
<- false;
4913 G.postRedisplay "view:linkent(F)"
4915 else impmsg "hint mode does not work under rotation"
4918 state
.glinks
<- true;
4919 let mode = state
.mode in
4920 state
.mode <- Textentry
(
4922 ":", E.s, None
, linknentry, linknact (fun under ->
4923 selstring (undertext under);
4927 state
.glinks
<- false;
4931 G.postRedisplay "view:linkent"
4934 begin match state
.autoscroll
with
4936 conf
.autoscrollstep
<- step
;
4937 state
.autoscroll
<- None
4939 if conf
.autoscrollstep
= 0
4940 then state
.autoscroll
<- Some
1
4941 else state
.autoscroll
<- Some conf
.autoscrollstep
4945 launchpath () (* XXX where do error messages go? *)
4948 setpresentationmode (not conf
.presentation
);
4949 showtext ' '
("presentation mode " ^
4950 if conf
.presentation
then "on" else "off");
4953 if List.mem
Wsi.Fullscreen state
.winstate
4954 then Wsi.reshape conf
.cwinw conf
.cwinh
4955 else Wsi.fullscreen
()
4958 search state
.searchpattern
false
4961 search state
.searchpattern
true
4964 begin match state
.layout with
4967 gotoghyll (getpagey
l.pageno)
4973 | @delete
| @kpdelete
-> (* delete *)
4977 showtext ' '
(describe_location ());
4980 begin match state
.layout with
4983 Wsi.reshape (l.pagew
+ vscrollw ()) l.pageh
;
4988 enterbookmarkmode
()
4996 | @e when Buffer.length state
.errmsgs
> 0 ->
5001 match state
.layout with
5006 (s, 0, Oanchor
(getanchor1
l)) :: state
.bookmarks
5009 enttext ("bookmark: ", E.s, None
, textentry, ondone, true)
5013 showtext ' '
"Quick bookmark added";
5016 begin match state
.layout with
5018 let rect = getpdimrect
l.pagedimno
in
5022 (truncate
(1.8 *. (rect.(1) -. rect.(0))),
5023 truncate
(1.2 *. (rect.(3) -. rect.(0))))
5025 (truncate
(rect.(1) -. rect.(0)),
5026 truncate
(rect.(3) -. rect.(0)))
5028 let w = truncate
((float w)*.conf
.zoom)
5029 and h = truncate
((float h)*.conf
.zoom) in
5032 state
.anchor <- getanchor
();
5033 Wsi.reshape (w + vscrollw ()) (h + conf
.interpagespace
)
5035 G.postRedisplay "z";
5040 | @x -> state
.roam
()
5043 reqlayout (conf
.angle
+
5044 (if key = @Gt
then 30 else -30)) conf
.fitmodel
5048 bound
(conf
.colorscale
+. (if key = 93 then 0.1 else -0.1)) 0.0 1.0
5050 G.postRedisplay "brightness";
5052 | @c when state
.mode = View
->
5057 let m = (wadjsb () + state
.winw
- state
.w) / 2 in
5059 gotoy_and_clear_text state
.y
5063 match state
.prevcolumns
with
5064 | None
-> (1, 0, 0), 1.0
5065 | Some
(columns
, z
) ->
5068 | Csplit
(c, _) -> -c, 0, 0
5069 | Cmulti
((c, a, b), _) -> c, a, b
5070 | Csingle
_ -> 1, 0, 0
5074 setcolumns View
c a b;
5077 | @down
| @up
when ctrl && Wsi.withshift mask
->
5078 let zoom, x = state
.prevzoom
in
5082 | @k
| @up
| @kpup
->
5083 begin match state
.autoscroll
with
5085 begin match state
.mode with
5086 | Birdseye beye
-> upbirdseye 1 beye
5091 then gotoy_and_clear_text (clamp ~
-(state
.winh
/2))
5093 if not
(Wsi.withshift mask
) && conf
.presentation
5095 else gotoghyll1 true (clamp (-conf
.scrollstep
))
5099 setautoscrollspeed n false
5102 | @j
| @down
| @kpdown
->
5103 begin match state
.autoscroll
with
5105 begin match state
.mode with
5106 | Birdseye beye
-> downbirdseye 1 beye
5111 then gotoy_and_clear_text (clamp (state
.winh
/2))
5113 if not
(Wsi.withshift mask
) && conf
.presentation
5115 else gotoghyll1 true (clamp (conf
.scrollstep
))
5119 setautoscrollspeed n true
5122 | @left | @right
| @kpleft
| @kpright
when not
(Wsi.withalt mask
) ->
5128 else conf
.hscrollstep
5130 let dx = if key = @left || key = @kpleft
then dx else -dx in
5131 state
.x <- panbound (state
.x + dx);
5132 gotoy_and_clear_text state
.y
5135 G.postRedisplay "left/right"
5138 | @prior
| @kpprior
->
5142 match state
.layout with
5144 | l :: _ -> state
.y - l.pagey
5146 clamp (pgscale (-state
.winh
))
5150 | @next | @kpnext
->
5154 match List.rev state
.layout with
5156 | l :: _ -> getpagey
l.pageno
5158 clamp (pgscale state
.winh
)
5162 | @g | @home
| @kphome
->
5165 | @G
| @jend
| @kpend
->
5167 gotoghyll (clamp state
.maxy)
5169 | @right
| @kpright
when Wsi.withalt mask
->
5170 gotoghyll (getnav 1)
5171 | @left | @kpleft
when Wsi.withalt mask
->
5172 gotoghyll (getnav ~
-1)
5177 | @v when conf
.debug
->
5180 match getopaque l.pageno with
5183 let x0, y0, x1, y1 = pagebbox
opaque in
5184 let rect = (float x0, float y0,
5187 float x0, float y1) in
5189 let color = (0.0, 0.0, 1.0 /. (l.pageno mod 3 |> float), 0.5) in
5190 state
.rects
<- (l.pageno, color, rect) :: state
.rects
;
5192 G.postRedisplay "v";
5195 let mode = state
.mode in
5196 let cmd = ref E.s in
5197 let onleave = function
5198 | Cancel
-> state
.mode <- mode
5201 match getopaque l.pageno with
5202 | Some
opaque -> pipesel opaque !cmd
5203 | None
-> ()) state
.layout;
5207 cbput state
.hists
.sel
s;
5211 "| ", !cmd, Some
(onhist state
.hists
.sel
), textentry, ondone, true
5213 G.postRedisplay "|";
5214 state
.mode <- Textentry
(te, onleave);
5217 vlog "huh? %s" (Wsi.keyname
key)
5220 let linknavkeyboard key mask
linknav =
5221 let getpage pageno =
5222 let rec loop = function
5224 | l :: _ when l.pageno = pageno -> Some
l
5225 | _ :: rest
-> loop rest
5226 in loop state
.layout
5228 let doexact (pageno, n) =
5229 match getopaque pageno, getpage pageno with
5230 | Some
opaque, Some
l ->
5231 if key = @enter || key = @kpenter
5233 let under = getlink
opaque n in
5234 G.postRedisplay "link gotounder";
5241 Some
(findlink
opaque LDfirst
), -1
5244 Some
(findlink
opaque LDlast
), 1
5247 Some
(findlink
opaque (LDleft
n)), -1
5250 Some
(findlink
opaque (LDright
n)), 1
5253 Some
(findlink
opaque (LDup
n)), -1
5256 Some
(findlink
opaque (LDdown
n)), 1
5261 begin match findpwl
l.pageno dir with
5265 state
.mode <- LinkNav
(Ltgendir
dir);
5266 let y, h = getpageyh
pageno in
5269 then y + h - state
.winh
5274 begin match getopaque pageno, getpage pageno with
5275 | Some
opaque, Some
_ ->
5277 let ld = if dir > 0 then LDfirst
else LDlast
in
5280 begin match link with
5282 showlinktype (getlink
opaque m);
5283 state
.mode <- LinkNav
(Ltexact
(pageno, m));
5284 G.postRedisplay "linknav jpage";
5285 | Lnotfound
-> notfound dir
5291 begin match opt with
5292 | Some Lnotfound
-> pwl l dir;
5293 | Some
(Lfound
m) ->
5297 let _, y0, _, y1 = getlinkrect
opaque m in
5299 then gotopage1 l.pageno y0
5301 let d = fstate
.fontsize
+ 1 in
5302 if y1 - l.pagey > l.pagevh - d
5303 then gotopage1 l.pageno (y1 - state
.winh
- hscrollh () + d)
5304 else G.postRedisplay "linknav";
5306 showlinktype (getlink
opaque m);
5307 state
.mode <- LinkNav
(Ltexact
(l.pageno, m));
5310 | None
-> viewkeyboard key mask
5312 | _ -> viewkeyboard key mask
5317 G.postRedisplay "leave linknav"
5321 | Ltgendir
_ | Ltnotready
_ -> viewkeyboard key mask
5322 | Ltexact exact
-> doexact exact
5325 let keyboard key mask
=
5326 if (key = @g && Wsi.withctrl mask
) && not
(istextentry state
.mode)
5327 then wcmd "interrupt"
5328 else state
.uioh <- state
.uioh#
key key mask
5331 let birdseyekeyboard key mask
5332 ((oconf
, leftx
, pageno, hooverpageno
, anchor) as beye
) =
5334 match conf
.columns
with
5336 | Cmulti
((c, _, _), _) -> c
5337 | Csplit
_ -> failwith
"bird's eye split mode"
5339 let pgh layout = List.fold_left
5340 (fun m l -> max
l.pageh
m) state
.winh
layout in
5342 | @l when Wsi.withctrl mask
->
5343 let y, h = getpageyh
pageno in
5344 let top = (state
.winh
- h) / 2 in
5345 gotoy (max
0 (y - top))
5346 | @enter | @kpenter
-> leavebirdseye beye
false
5347 | @escape
-> leavebirdseye beye
true
5348 | @up
-> upbirdseye incr beye
5349 | @down
-> downbirdseye incr beye
5350 | @left -> upbirdseye 1 beye
5351 | @right
-> downbirdseye 1 beye
5354 begin match state
.layout with
5358 state
.mode <- Birdseye
(
5359 oconf
, leftx
, l.pageno, hooverpageno
, anchor
5361 gotopage1 l.pageno 0;
5364 let layout = layout state
.x (state
.y-state
.winh
)
5366 (pgh state
.layout) in
5368 | [] -> gotoy (clamp (-state
.winh
))
5370 state
.mode <- Birdseye
(
5371 oconf
, leftx
, l.pageno, hooverpageno
, anchor
5373 gotopage1 l.pageno 0
5376 | [] -> gotoy (clamp (-state
.winh
))
5380 begin match List.rev state
.layout with
5382 let layout = layout state
.x
5383 (state
.y + (pgh state
.layout))
5384 state
.winw state
.winh
in
5385 begin match layout with
5387 let incr = l.pageh
- l.pagevh in
5392 oconf
, leftx
, state
.pagecount
- 1, hooverpageno
, anchor
5394 G.postRedisplay "birdseye pagedown";
5396 else gotoy (clamp (incr + conf
.interpagespace
*2));
5400 Birdseye
(oconf
, leftx
, l.pageno, hooverpageno
, anchor);
5401 gotopage1 l.pageno 0;
5404 | [] -> gotoy (clamp state
.winh
)
5408 state
.mode <- Birdseye
(oconf
, leftx
, 0, hooverpageno
, anchor);
5412 let pageno = state
.pagecount
- 1 in
5413 state
.mode <- Birdseye
(oconf
, leftx
, pageno, hooverpageno
, anchor);
5414 if not
(pagevisible state
.layout pageno)
5417 match List.rev state
.pdims
with
5419 | (_, _, h, _) :: _ -> h
5421 gotoy (max
0 (getpagey
pageno - (state
.winh
- h - conf
.interpagespace
)))
5422 else G.postRedisplay "birdseye end";
5424 | _ -> viewkeyboard key mask
5429 match state
.mode with
5430 | Textentry
_ -> scalecolor 0.4
5432 | View
-> scalecolor 1.0
5433 | Birdseye
(_, _, pageno, hooverpageno
, _) ->
5434 if l.pageno = hooverpageno
5437 if l.pageno = pageno
5439 let c = scalecolor 1.0 in
5441 GlDraw.line_width
3.0;
5442 let dispx = xadjsb () + l.pagedispx in
5444 (float (dispx-1)) (float (l.pagedispy-1))
5445 (float (dispx+l.pagevw+1))
5446 (float (l.pagedispy+l.pagevh+1))
5448 GlDraw.line_width
1.0;
5457 let postdrawpage l linkindexbase
=
5458 match getopaque l.pageno with
5460 if tileready l l.pagex
l.pagey
5462 let x = l.pagedispx - l.pagex
+ xadjsb ()
5463 and y = l.pagedispy - l.pagey in
5465 match conf
.columns
with
5466 | Csingle
_ | Cmulti
_ ->
5467 (if conf
.hlinks
then 1 else 0)
5469 && not
(isbirdseye state
.mode) then 2 else 0)
5473 match state
.mode with
5474 | Textentry
((_, s, _, _, _, _), _) when state
.glinks
-> s
5480 Hashtbl.find_all state
.prects
l.pageno |>
5481 List.iter
(fun vals
-> drawprect
opaque x y vals
);
5482 postprocess
opaque hlmask x y (linkindexbase
, s, conf
.hfsize
);
5487 let scrollindicator () =
5488 let sbw, ph
, sh = state
.uioh#
scrollph in
5489 let sbh, pw, sw = state
.uioh#scrollpw
in
5494 else ((state
.winw
- sbw), state
.winw
, 0)
5497 GlDraw.color (0.64, 0.64, 0.64);
5498 filledrect (float x0) 0. (float x1) (float state
.winh
);
5500 (float hx0
) (float (state
.winh
- sbh))
5501 (float (hx0
+ wadjsb () + state
.winw
)) (float state
.winh
)
5503 GlDraw.color (0.0, 0.0, 0.0);
5505 filledrect (float x0) ph
(float x1) (ph
+. sh);
5506 let pw = pw +. float hx0
in
5507 filledrect pw (float (state
.winh
- sbh)) (pw +. sw) (float state
.winh
);
5511 match state
.mstate
with
5512 | Mnone
| Mscrolly
| Mscrollx
| Mpan
_ | Mzoom
_ | Mzoomrect
_ ->
5515 | Msel
((x0, y0), (x1, y1)) ->
5516 let identify opaque l px py = Some
(opaque, l.pageno, px, py) in
5517 let o0,n0
,px0
,py0
= onppundermouse identify x0 y0 (~
< E.s, -1, 0, 0) in
5518 let _o1,n1
,px1
,py1
= onppundermouse identify x1 y1 (~
< E.s, -1, 0, 0) in
5519 if n0
!= -1 && n0
= n1
then seltext
o0 (px0
, py0
, px1
, py1
);
5522 let showrects = function [] -> () | rects
->
5524 GlDraw.color (0.0, 0.0, 1.0) ~
alpha:0.5;
5525 GlFunc.blend_func ~
src:`src_alpha ~dst
:`one_minus_src_alpha
;
5527 (fun (pageno, c, (x0, y0, x1, y1, x2
, y2
, x3
, y3
)) ->
5529 if l.pageno = pageno
5531 let dx = float (l.pagedispx - l.pagex
) in
5532 let dy = float (l.pagedispy - l.pagey) in
5533 let r, g, b, alpha = c in
5534 GlDraw.color (r, g, b) ~
alpha;
5535 filledrect2 (x0+.dx) (y0+.dy)
5547 begin match conf
.columns
, state
.layout with
5548 | Csingle
_, _ :: _ ->
5549 GlDraw.color (scalecolor2 conf
.bgcolor
);
5551 List.fold_left
(fun y l ->
5554 let x1 = l.pagedispx + xadjsb () in
5555 let y1 = (l.pagedispy + l.pagevh) in
5556 filledrect (float x0) (float y0) (float x1) (float y1);
5557 let x0 = x1 + l.pagevw in
5558 let x1 = state
.winw
in
5559 filledrect1 (float x0) (float y0) (float x1) (float y1);
5563 and x1 = state
.winw
in
5565 and y1 = l.pagedispy in
5566 filledrect1 (float x0) (float y0) (float x1) (float y1);
5568 l.pagedispy + l.pagevh) 0 state
.layout
5571 and x1 = state
.winw
in
5573 and y1 = state
.winh
in
5574 filledrect1 (float x0) (float y0) (float x1) (float y1)
5575 | (Cmulti
_ | Csplit
_), _ | Csingle
_, [] ->
5576 GlClear.color (scalecolor2 conf
.bgcolor
);
5577 GlClear.clear
[`
color];
5579 List.iter
drawpage state
.layout;
5581 match state
.mode with
5582 | LinkNav
(Ltexact
(pageno, linkno
)) ->
5583 begin match getopaque pageno with
5585 let dx = xadjsb () in
5586 let x0, y0, x1, y1 = getlinkrect
opaque linkno
in
5587 let x0 = x0 + dx and x1 = x1 + dx in
5588 let color = (0.0, 0.0, 0.5, 0.5) in
5595 | None
-> state
.rects
5597 | LinkNav
(Ltgendir
_) | LinkNav
(Ltnotready
_)
5600 | View
-> state
.rects
5603 let rec postloop linkindexbase
= function
5605 let linkindexbase = linkindexbase + postdrawpage l linkindexbase in
5606 postloop linkindexbase rest
5610 postloop 0 state
.layout;
5612 begin match state
.mstate
with
5613 | Mzoomrect
((x0, y0), (x1, y1)) ->
5615 GlDraw.color (0.3, 0.3, 0.3) ~
alpha:0.5;
5616 GlFunc.blend_func ~
src:`src_alpha ~dst
:`one_minus_src_alpha
;
5617 filledrect (float x0) (float y0) (float x1) (float y1);
5621 | Mscrolly
| Mscrollx
5630 let zoomrect x y x1 y1 =
5633 and y0 = min
y y1 in
5634 gotoy (state
.y + y0);
5635 state
.anchor <- getanchor
();
5636 let zoom = (float state
.w) /. float (x1 - x0) in
5639 let adjw = wadjsb () + state
.winw
in
5641 then (adjw - state
.w) / 2
5644 match conf
.fitmodel
with
5645 | FitWidth
| FitProportional
-> simple ()
5647 match conf
.columns
with
5649 onppundermouse (fun _ l _ _ -> Some
l.pagedispx) x0 y0 x0
5650 | Cmulti
_ | Csingle
_ -> simple ()
5652 state
.x <- (state
.x + margin) - x0;
5657 let annot inline
x y =
5658 match unproject x y with
5659 | Some
(opaque, n, ux
, uy
) ->
5661 addannot
opaque ux uy
text;
5662 wcmd "freepage %s" (~
> opaque);
5663 Hashtbl.remove state
.pagemap
(n, state
.gen
);
5669 let ondone s = add s in
5670 let mode = state
.mode in
5671 state
.mode <- Textentry
(
5672 ("annotation: ", E.s, None
, textentry, ondone, true),
5673 fun _ -> state
.mode <- mode);
5676 G.postRedisplay "annot"
5678 add @@ getusertext E.s
5683 let g opaque l px py =
5684 match rectofblock
opaque px py with
5686 let x0 = a.(0) -. 20. in
5687 let x1 = a.(1) +. 20. in
5688 let y0 = a.(2) -. 20. in
5689 let zoom = (float state
.w) /. (x1 -. x0) in
5690 let pagey = getpagey
l.pageno in
5691 gotoy_and_clear_text (pagey + truncate
y0);
5692 state
.anchor <- getanchor
();
5693 let margin = (state
.w - l.pagew
)/2 in
5694 state
.x <- -truncate
x0 - margin;
5699 match conf
.columns
with
5701 impmsg "block zooming does not work properly in split columns mode"
5702 | Cmulti
_ | Csingle
_ -> onppundermouse g x y ()
5706 let winw = wadjsb () + state
.winw - 1 in
5707 let s = float x /. float winw in
5708 let destx = truncate
(float (state
.w + winw) *. s) in
5709 state
.x <- winw - destx;
5710 gotoy_and_clear_text state
.y;
5711 state
.mstate
<- Mscrollx
;
5715 let s = float y /. float state
.winh
in
5716 let desty = truncate
(float (state
.maxy - state
.winh
) *. s) in
5717 gotoy_and_clear_text desty;
5718 state
.mstate
<- Mscrolly
;
5721 let viewmulticlick clicks
x y mask
=
5722 let g opaque l px py =
5730 if markunder
opaque px py mark
5734 match getopaque l.pageno with
5736 | Some
opaque -> pipesel opaque cmd
5738 state
.roam
<- (fun () -> dopipe conf
.paxcmd
);
5739 if not
(Wsi.withctrl mask
) then dopipe conf
.selcmd
;
5744 G.postRedisplay "viewmulticlick";
5745 onppundermouse g x y (fun () -> impmsg "nothing to select") ();
5749 match conf
.columns
with
5751 | Csingle
_ | Cmulti
_ -> conf
.angle
mod 360 = 0
5754 let viewmouse button down
x y mask
=
5756 | n when (n == 4 || n == 5) && not down
->
5757 if Wsi.withctrl mask
5759 match state
.mstate
with
5760 | Mzoom
(oldn
, i
) ->
5768 if conf
.zoom +. 0.01 > 0.1 then 0.1 else 0.01
5770 if conf
.zoom -. 0.1 < 0.1 then -0.01 else -0.1
5772 let zoom = conf
.zoom -. incr in
5774 state
.mstate
<- Mzoom
(n, 0);
5776 state
.mstate
<- Mzoom
(n, i
+1);
5778 else state
.mstate
<- Mzoom
(n, 0)
5782 | Mscrolly
| Mscrollx
5784 | Mnone
-> state
.mstate
<- Mzoom
(n, 0)
5787 match state
.autoscroll
with
5788 | Some step
-> setautoscrollspeed step
(n=4)
5790 if conf
.wheelbypage
|| conf
.presentation
5799 then -conf
.scrollstep
5800 else conf
.scrollstep
5802 let incr = incr * 2 in
5803 let y = clamp incr in
5804 gotoy_and_clear_text y
5807 | n when (n = 6 || n = 7) && not down
&& canpan () ->
5809 panbound (state
.x + (if n = 7 then -2 else 2) * conf
.hscrollstep
);
5810 gotoy_and_clear_text state
.y
5812 | 1 when Wsi.withshift mask
->
5813 state
.mstate
<- Mnone
;
5816 match unproject x y with
5818 | Some
(_, pageno, ux
, uy
) ->
5819 let cmd = Printf.sprintf
5821 conf
.stcmd state
.path pageno ux uy
5823 match spawn
cmd [] with
5824 | (exception exn
) ->
5825 impmsg "execution of synctex command(%S) failed: %S"
5826 conf
.stcmd
@@ exntos exn
5830 | 1 when Wsi.withctrl mask
->
5833 Wsi.setcursor
Wsi.CURSOR_FLEUR
;
5834 state
.mstate
<- Mpan
(x, y)
5837 state
.mstate
<- Mnone
5842 if Wsi.withshift mask
5844 annot conf
.annotinline
x y;
5845 G.postRedisplay "addannot"
5849 Wsi.setcursor
Wsi.CURSOR_CYCLE
;
5850 state
.mstate
<- Mzoomrect
(p, p)
5853 match state
.mstate
with
5854 | Mzoomrect
((x0, y0), _) ->
5855 if abs
(x-x0) > 10 && abs
(y - y0) > 10
5856 then zoomrect x0 y0 x y
5859 G.postRedisplay "kill accidental zoom rect";
5863 | Mscrolly
| Mscrollx
5869 | 1 when vscrollhit x ->
5872 let _, position, sh = state
.uioh#
scrollph in
5873 if y > truncate
position && y < truncate
(position +. sh)
5874 then state
.mstate
<- Mscrolly
5877 state
.mstate
<- Mnone
5879 | 1 when y > state
.winh
- hscrollh () ->
5882 let _, position, sw = state
.uioh#scrollpw
in
5883 if x > truncate
position && x < truncate
(position +. sw)
5884 then state
.mstate
<- Mscrollx
5887 state
.mstate
<- Mnone
5889 | 1 when state
.bzoom
-> if not down
then zoomblock x y
5892 let dest = if down
then getunder x y else Unone
in
5893 begin match dest with
5896 | Uremote
_ | Uremotedest
_
5897 | Uunexpected
_ | Ulaunch
_ | Unamed
_ ->
5900 | Unone
when down
->
5901 Wsi.setcursor
Wsi.CURSOR_FLEUR
;
5902 state
.mstate
<- Mpan
(x, y);
5904 | Uannotation
(opaque, slinkindex
) -> enterannotmode opaque slinkindex
5906 | Unone
| Utext
_ ->
5911 state
.mstate
<- Msel
((x, y), (x, y));
5912 G.postRedisplay "mouse select";
5916 match state
.mstate
with
5919 | Mzoom
_ | Mscrollx
| Mscrolly
->
5920 state
.mstate
<- Mnone
5922 | Mzoomrect
((x0, y0), _) ->
5926 Wsi.setcursor
Wsi.CURSOR_INHERIT
;
5927 state
.mstate
<- Mnone
5929 | Msel
((x0, y0), (x1, y1)) ->
5930 let rec loop = function
5934 let a0 = l.pagedispy in
5935 let a1 = a0 + l.pagevh in
5936 let b0 = l.pagedispx in
5937 let b1 = b0 + l.pagevw in
5938 ((y0 >= a0 && y0 <= a1) || (y1 >= a0 && y1 <= a1))
5939 && ((x0 >= b0 && x0 <= b1) || (x1 >= b0 && x1 <= b1))
5943 match getopaque l.pageno with
5946 match Unix.pipe
() with
5947 | (exception exn
) ->
5948 impmsg "cannot create sel pipe: %s" @@
5952 Ne.clo fd
(fun msg
->
5953 dolog
"%s close failed: %s" what msg
)
5956 try spawn
cmd [r, 0; w, -1]
5958 dolog
"cannot execute %S: %s"
5965 G.postRedisplay "copysel";
5967 else clo "Msel pipe/w" w;
5968 clo "Msel pipe/r" r;
5970 dosel conf
.selcmd
();
5971 state
.roam
<- dosel conf
.paxcmd
;
5983 let birdseyemouse button down
x y mask
5984 (conf
, leftx
, _, hooverpageno
, anchor) =
5987 let rec loop = function
5990 if y > l.pagedispy && y < l.pagedispy + l.pagevh
5991 && x > l.pagedispx && x < l.pagedispx + l.pagevw
5993 leavebirdseye (conf
, leftx
, l.pageno, hooverpageno
, anchor) false;
5999 | _ -> viewmouse button down
x y mask
6005 method key key mask
=
6006 begin match state
.mode with
6007 | Textentry
textentry -> textentrykeyboard key mask
textentry
6008 | Birdseye
birdseye -> birdseyekeyboard key mask
birdseye
6009 | View
-> viewkeyboard key mask
6010 | LinkNav
linknav -> linknavkeyboard key mask
linknav
6014 method button button bstate
x y mask
=
6015 begin match state
.mode with
6017 | View
-> viewmouse button bstate
x y mask
6018 | Birdseye beye
-> birdseyemouse button bstate
x y mask beye
6023 method multiclick clicks
x y mask
=
6024 begin match state
.mode with
6026 | View
-> viewmulticlick clicks
x y mask
6033 begin match state
.mode with
6035 | View
| Birdseye
_ | LinkNav
_ ->
6036 match state
.mstate
with
6037 | Mzoom
_ | Mnone
-> ()
6042 state
.mstate
<- Mpan
(x, y);
6044 then state
.x <- panbound (state
.x + dx);
6046 gotoy_and_clear_text y
6049 state
.mstate
<- Msel
(a, (x, y));
6050 G.postRedisplay "motion select";
6053 let y = min state
.winh
(max
0 y) in
6057 let x = min state
.winw (max
0 x) in
6060 | Mzoomrect
(p0
, _) ->
6061 state
.mstate
<- Mzoomrect
(p0
, (x, y));
6062 G.postRedisplay "motion zoomrect";
6066 method pmotion
x y =
6067 begin match state
.mode with
6068 | Birdseye
(conf
, leftx
, pageno, hooverpageno
, anchor) ->
6069 let rec loop = function
6071 if hooverpageno
!= -1
6073 state
.mode <- Birdseye
(conf
, leftx
, pageno, -1, anchor);
6074 G.postRedisplay "pmotion birdseye no hoover";
6077 if y > l.pagedispy && y < l.pagedispy + l.pagevh
6078 && x > l.pagedispx && x < l.pagedispx + l.pagevw
6080 state
.mode <- Birdseye
(conf
, leftx
, pageno, l.pageno, anchor);
6081 G.postRedisplay "pmotion birdseye hoover";
6091 match state
.mstate
with
6092 | Mpan
_ | Msel
_ | Mzoom
_ | Mscrolly
| Mscrollx
| Mzoomrect
_ -> ()
6100 let past, _, _ = !r in
6102 let delta = now -. past in
6105 else r := (now, x, y)
6109 method infochanged
_ = ()
6112 let maxy = state
.maxy - (if conf
.maxhfit
then state
.winh
else 0) in
6115 then 0.0, float state
.winh
6116 else scrollph state
.y maxy
6121 let winw = wadjsb () + state
.winw in
6122 let fwinw = float winw in
6124 let sw = fwinw /. float state
.w in
6125 let sw = fwinw *. sw in
6126 max
sw (float conf
.scrollh
)
6129 let maxx = state
.w + winw in
6130 let x = winw - state
.x in
6131 let percent = float x /. float maxx in
6132 (fwinw -. sw) *. percent
6134 hscrollh (), position, sw
6138 match state
.mode with
6139 | LinkNav
_ -> "links"
6140 | Textentry
_ -> "textentry"
6141 | Birdseye
_ -> "birdseye"
6144 findkeyhash conf
modename
6146 method eformsgs
= true
6147 method alwaysscrolly
= false
6150 let addrect pageno r g b a x0 y0 x1 y1 =
6151 Hashtbl.add state
.prects
pageno [|r; g; b; a; x0; y0; x1; y1|];
6155 let cl = splitatspace cmds
in
6157 try Scanf.sscanf
s fmt
f
6159 adderrfmt "remote exec"
6160 "error processing '%S': %s\n" cmds
@@ exntos exn
6162 let rectx s pageno (r, g, b, a) x0 y0 x1 y1 =
6163 vlog "%s page %d color (%f %f %f %f) x0,y0,x1,y1 = %f %f %f %f"
6164 s pageno r g b a x0 y0 x1 y1;
6168 let _,w1,h1
,_ = getpagedim
pageno in
6169 let sw = float w1 /. float w
6170 and sh = float h1
/. float h in
6174 and y1s
= y1 *. sh in
6175 let rect = (x0s,y0s
,x1s
,y0s
,x1s
,y1s
,x0s,y1s
) in
6176 let color = (r, g, b, a) in
6177 if conf
.verbose
then debugrect rect;
6178 state
.rects <- (pageno, color, rect) :: state
.rects;
6183 | "reload", "" -> reload ()
6185 scan args
"%u %f %f"
6187 let cmd, _ = state
.geomcmds
in
6189 then gotopagexy !wtmode pageno x y
6192 gotopagexy !wtmode pageno x y;
6195 state
.reprf
<- f state
.reprf
6197 | "goto1", args
-> scan args
"%u %f" gotopage
6200 (fun filename
pageno -> gotounder (Uremote
(filename
, pageno)))
6203 (fun filename
dest -> gotounder (Uremotedest
(filename
, dest)))
6205 scan args
"%u %u %f %f %f %f"
6206 (fun pageno c x0 y0 x1 y1 ->
6207 let color = (0.0, 0.0, 1.0 /. float c, 0.5) in
6208 rectx "rect" pageno color x0 y0 x1 y1;
6211 scan args
"%u %f %f %f %f %f %f %f %f"
6212 (fun pageno r g b alpha x0 y0 x1 y1 ->
6213 addrect pageno r g b alpha x0 y0 x1 y1;
6214 G.postRedisplay "prect"
6217 scan args
"%u %f %f"
6220 match getopaque pageno with
6221 | Some
opaque -> opaque
6224 pgoto optopaque pageno x y;
6225 let rec fixx = function
6228 if l.pageno = pageno
6230 state
.x <- state
.x - l.pagedispx;
6237 match conf
.columns
with
6238 | Csingle
_ | Csplit
_ -> 1
6239 | Cmulti
((n, _, _), _) -> n
6241 layout 0 state
.y (state
.winw * mult) state
.winh
6245 | "activatewin", "" -> Wsi.activatewin
()
6246 | "quit", "" -> raise Quit
6249 let l = Config.keys_of_string
keys in
6250 List.iter
(fun (k
, m) -> keyboard k
m) l
6252 adderrfmt "error processing keys" "`%S': %s\n" cmds
@@ exntos exn
6254 | "clearrects", "" ->
6255 Hashtbl.clear state
.prects
;
6256 G.postRedisplay "clearrects"
6258 adderrfmt "remote command"
6259 "error processing remote command: %S\n" cmds
;
6263 let scratch = Bytes.create
80 in
6264 let buf = Buffer.create
80 in
6266 match tempfailureretry
(Unix.read fd
scratch 0) 80 with
6267 | (exception Unix.Unix_error
(Unix.EAGAIN
, _, _)) -> None
6270 if Buffer.length
buf > 0
6272 let s = Buffer.contents
buf in
6280 match Bytes.index_from
scratch ppos '
\n'
with
6281 | pos -> if pos >= n then -1 else pos
6282 | (exception Not_found
) -> -1
6286 Buffer.add_subbytes
buf scratch ppos
(nlpos-ppos
);
6287 let s = Buffer.contents
buf in
6293 Buffer.add_subbytes
buf scratch ppos
(n-ppos
);
6299 let remoteopen path =
6300 try Some
(Unix.openfile
path [Unix.O_NONBLOCK
; Unix.O_RDONLY
] 0o0)
6302 adderrfmt "remoteopen" "error opening %S: %s" path @@ exntos exn
;
6307 let gcconfig = ref E.s in
6308 let trimcachepath = ref E.s in
6309 let rcmdpath = ref E.s in
6310 let pageno = ref None
in
6311 let rootwid = ref 0 in
6312 let openlast = ref false in
6313 let nofc = ref false in
6314 let doreap = ref false in
6315 selfexec := Sys.executable_name
;
6318 [("-p", Arg.String
(fun s -> state
.password <- s),
6319 "<password> Set password");
6323 Config.fontpath
:= s;
6324 selfexec := !selfexec ^
" -f " ^
Filename.quote
s;
6326 "<path> Set path to the user interface font");
6330 selfexec := !selfexec ^
" -c " ^
Filename.quote
s;
6331 Config.confpath
:= s),
6332 "<path> Set path to the configuration file");
6334 ("-last", Arg.Set
openlast, " Open last document");
6336 ("-page", Arg.Int
(fun pageno1
-> pageno := Some
(pageno1
-1)),
6337 "<page-number> Jump to page");
6339 ("-tcf", Arg.String
(fun s -> trimcachepath := s),
6340 "<path> Set path to the trim cache file");
6342 ("-dest", Arg.String
(fun s -> state
.nameddest
<- s),
6343 "<named-destination> Set named destination");
6345 ("-wtmode", Arg.Set
wtmode, " Operate in wt mode");
6346 ("-cxack", Arg.Set
cxack, " Cut corners");
6348 ("-remote", Arg.String
(fun s -> rcmdpath := s),
6349 "<path> Set path to the remote commands source");
6351 ("-origin", Arg.String
(fun s -> state
.origin
<- s),
6352 "<original-path> Set original path");
6354 ("-gc", Arg.Set_string
gcconfig,
6355 "<script-path> Collect garbage with the help of a script");
6357 ("-nofc", Arg.Set
nofc, " Do not use fontconfig");
6359 ("-v", Arg.Unit
(fun () ->
6361 "%s\nconfiguration path: %s\n"
6365 exit
0), " Print version and exit");
6367 ("-embed", Arg.Set_int
rootwid,
6368 "<window-id> Embed into window")
6371 (fun s -> state
.path <- s)
6372 ("Usage: " ^
Sys.argv
.(0) ^
" [options] some.pdf\nOptions:")
6375 then selfexec := !selfexec ^
" -wtmode";
6377 let histmode = emptystr state
.path && not
!openlast in
6379 if not
(Config.load !openlast)
6380 then dolog
"failed to load configuration";
6382 begin match !pageno with
6383 | Some
pageno -> state
.anchor <- (pageno, 0.0, 0.0)
6387 if nonemptystr
!gcconfig
6390 match Unix.socketpair
Unix.PF_UNIX
Unix.SOCK_STREAM
0 with
6391 | (exception exn
) -> error
"socketpair for gc failed: %s" @@ exntos exn
6394 match spawn
!gcconfig [(c, 0); (c, 1); (s, -1)] with
6395 | (exception exn
) -> error
"failed to execute gc script: %s" @@ exntos exn
6397 Ne.clo c @@ (fun s -> error
"failed to close gc fd %s" s);
6402 let wsfd, winw, winh
= Wsi.init
(object (self)
6403 val mutable m_clicks
= 0
6404 val mutable m_click_x
= 0
6405 val mutable m_click_y
= 0
6406 val mutable m_lastclicktime
= infinity
6408 method private cleanup =
6409 state
.roam
<- noroam
;
6410 Hashtbl.iter
(fun _ opaque -> clearmark
opaque) state
.pagemap
6411 method expose
= G.postRedisplay "expose"
6415 | Wsi.Unobscured
-> "unobscured"
6416 | Wsi.PartiallyObscured
-> "partiallyobscured"
6417 | Wsi.FullyObscured
-> "fullyobscured"
6419 vlog "visibility change %s" name
6420 method display = display ()
6421 method map mapped
= vlog "mapped %b" mapped
6422 method reshape w h =
6425 method mouse
b d x y m =
6426 if d && canselect ()
6428 (* http://blogs.msdn.com/b/oldnewthing/archive/2004/10/18/243925.aspx *)
6434 if abs
x - m_click_x
> 10
6435 || abs
y - m_click_y
> 10
6436 || abs_float
(t -. m_lastclicktime
) > 0.3
6438 m_clicks
<- m_clicks
+ 1;
6439 m_lastclicktime
<- t;
6443 G.postRedisplay "cleanup";
6444 state
.uioh <- state
.uioh#button
b d x y m;
6446 else state
.uioh <- state
.uioh#multiclick m_clicks
x y m
6451 m_lastclicktime
<- infinity
;
6452 state
.uioh <- state
.uioh#button
b d x y m
6456 state
.uioh <- state
.uioh#button
b d x y m
6459 state
.mpos
<- (x, y);
6460 state
.uioh <- state
.uioh#motion
x y
6461 method pmotion
x y =
6462 state
.mpos
<- (x, y);
6463 state
.uioh <- state
.uioh#pmotion
x y
6465 let mascm = m land (
6466 Wsi.altmask
+ Wsi.shiftmask
+ Wsi.ctrlmask
+ Wsi.metamask
6469 let x = state
.x and y = state
.y in
6471 if x != state
.x || y != state
.y then self#
cleanup
6473 match state
.keystate
with
6475 let km = k
, mascm in
6478 let modehash = state
.uioh#
modehash in
6479 try Hashtbl.find modehash km
6481 try Hashtbl.find (findkeyhash conf
"global") km
6482 with Not_found
-> KMinsrt
(k
, m)
6484 | KMinsrt
(k
, m) -> keyboard k
m
6485 | KMinsrl
l -> List.iter
(fun (k
, m) -> keyboard k
m) l
6486 | KMmulti
(l, r) -> state
.keystate
<- KSinto
(l, r)
6488 | KSinto
((k'
, m'
) :: [], insrt
) when k'
=k
&& m'
land mascm = m'
->
6489 List.iter
(fun (k
, m) -> keyboard k
m) insrt
;
6490 state
.keystate
<- KSnone
6491 | KSinto
((k'
, m'
) :: keys, insrt
) when k'
=k
&& m'
land mascm = m'
->
6492 state
.keystate
<- KSinto
(keys, insrt
)
6493 | KSinto
_ -> state
.keystate
<- KSnone
6496 state
.mpos
<- (x, y);
6497 state
.uioh <- state
.uioh#pmotion
x y
6498 method leave = state
.mpos
<- (-1, -1)
6499 method winstate wsl
= state
.winstate
<- wsl
6500 method quit
= raise Quit
6501 end) !rootwid conf
.cwinw conf
.cwinh platform
in
6503 setbgcol conf
.bgcolor
;
6507 List.exists
GlMisc.check_extension
6508 [ "GL_ARB_texture_rectangle"
6509 ; "GL_EXT_texture_recangle"
6510 ; "GL_NV_texture_rectangle" ]
6512 then (dolog
"OpenGL does not suppport rectangular textures"; exit
1);
6515 let r = GlMisc.get_string `renderer
in
6516 let p = "Mesa DRI Intel(" in
6517 let l = String.length
p in
6518 String.length
r > l && String.sub
r 0 l = p
6521 defconf
.sliceheight
<- 1024;
6522 defconf
.texcount
<- 32;
6523 defconf
.usepbo
<- true;
6527 match Unix.socketpair
Unix.PF_UNIX
Unix.SOCK_STREAM
0 with
6528 | (exception exn
) ->
6529 dolog
"socketpair failed: %s" @@ exntos exn
;
6537 setcheckers conf
.checkers
;
6539 opengl_has_pbo := GlMisc.check_extension
"GL_ARB_pixel_buffer_object";
6542 conf
.angle
, conf
.fitmodel
, (conf
.trimmargins
, conf
.trimfuzz
),
6543 conf
.texcount
, conf
.sliceheight
, conf
.mustoresize
, conf
.colorspace
,
6544 !Config.fontpath
, !trimcachepath,
6548 List.iter
GlArray.enable
[`texture_coord
; `vertex
];
6550 reshape ~firsttime
:true winw winh
;
6554 Wsi.settitle
"llpp (history)";
6558 state
.text <- "Opening " ^
(mbtoutf8 state
.path);
6559 opendoc state
.path state
.password;
6563 Wsi.setcursor
Wsi.CURSOR_INHERIT
;
6564 Sys.set_signal
Sys.sighup
(Sys.Signal_handle
(fun _ -> reload ()));
6567 match Unix.waitpid
[Unix.WNOHANG
] ~
-1 with
6568 | (exception (Unix.Unix_error
(Unix.ECHILD
, _, _))) -> ()
6569 | (exception exn
) -> dolog
"Unix.waitpid: %s" @@ exntos exn
6571 | _pid
, _status
-> reap ()
6573 Sys.set_signal
Sys.sigchld
(Sys.Signal_handle
(fun _ -> doreap := true));
6577 if nonemptystr
!rcmdpath
6578 then remoteopen !rcmdpath
6583 let rec loop deadline
=
6589 let r = [state
.ss; state
.wsfd] in
6593 | Some fd
-> fd
:: r
6597 state
.redisplay
<- false;
6604 if deadline
= infinity
6606 else max
0.0 (deadline
-. now)
6611 try Unix.select
r [] [] timeout
6612 with Unix.Unix_error
(Unix.EINTR
, _, _) -> [], [], []
6618 if state
.ghyll
== noghyll
6620 match state
.autoscroll
with
6621 | Some step
when step
!= 0 ->
6622 let y = state
.y + step
in
6623 let fy = if conf
.maxhfit
then state
.winh
else 0 in
6626 then state
.maxy - fy
6627 else if y >= state
.maxy - fy then 0 else y
6629 if state
.mode = View
6630 then gotoy_and_clear_text y
6634 else deadline
+. 0.01
6639 let rec checkfds = function
6641 | fd
:: rest
when fd
= state
.ss ->
6642 let cmd = rcmd state
.ss in
6646 | fd
:: rest
when fd
= state
.wsfd ->
6650 | fd
:: rest
when Some fd
= !optrfd ->
6651 begin match remote fd
with
6652 | None
-> optrfd := remoteopen !rcmdpath;
6653 | opt -> optrfd := opt
6658 dolog
"select returned unknown descriptor";
6664 if deadline
= infinity
6668 match state
.autoscroll
with
6669 | Some step
when step
!= 0 -> deadline1
6670 | _ -> if state
.ghyll
== noghyll
then infinity
else deadline1
6678 Config.save leavebirdseye;
6679 if hasunsavedchanges
()