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 drawstr
: int -> int -> int -> string -> float = "ml_draw_string";;
16 external measurestr
: int -> string -> float = "ml_measure_string";;
17 external postprocess
:
18 opaque
-> int -> int -> int -> (int * string * int) -> int
20 external pagebbox
: opaque
-> (int * int * int * int) = "ml_getpagebox";;
21 external setaalevel
: int -> unit = "ml_setaalevel";;
22 external realloctexts
: int -> bool = "ml_realloctexts";;
23 external findlink
: opaque
-> linkdir
-> link
= "ml_findlink";;
24 external getlink
: opaque
-> int -> under
= "ml_getlink";;
25 external getlinkrect
: opaque
-> int -> irect
= "ml_getlinkrect";;
26 external getlinkcount
: opaque
-> int = "ml_getlinkcount";;
27 external findpwl
: int -> int -> pagewithlinks
= "ml_find_page_with_links";;
28 external getpbo
: width
-> height
-> colorspace
-> opaque
= "ml_getpbo";;
29 external freepbo
: opaque
-> unit = "ml_freepbo";;
30 external unmappbo
: opaque
-> unit = "ml_unmappbo";;
31 external pbousable
: unit -> bool = "ml_pbo_usable";;
32 external unproject
: opaque
-> int -> int -> (int * int) option
34 external project
: opaque
-> int -> int -> float -> float -> (float * float)
36 external drawtile
: tileparams
-> opaque
-> unit = "ml_drawtile";;
37 external rectofblock
: opaque
-> int -> int -> float array
option
39 external begintiles
: unit -> unit = "ml_begintiles";;
40 external endtiles
: unit -> unit = "ml_endtiles";;
41 external addannot
: opaque
-> int -> int -> string -> unit = "ml_addannot";;
42 external modannot
: opaque
-> slinkindex
-> string -> unit = "ml_modannot";;
43 external delannot
: opaque
-> slinkindex
-> unit = "ml_delannot";;
44 external hasunsavedchanges
: unit -> bool = "ml_hasunsavedchanges";;
45 external savedoc
: string -> unit = "ml_savedoc";;
46 external getannotcontents
: opaque
-> slinkindex
-> string
47 = "ml_getannotcontents";;
48 external drawprect
: opaque
-> int -> int -> float array
-> unit =
51 let selfexec = ref E.s
;;
53 let drawstring size x y s
=
55 Gl.enable `texture_2d
;
56 GlFunc.blend_func ~src
:`src_alpha ~dst
:`one_minus_src_alpha
;
57 ignore
(drawstr size x y s
);
59 Gl.disable `texture_2d
;
62 let drawstring1 size x y s
=
66 let drawstring2 size x y fmt
=
67 Printf.kprintf
(drawstring size
(x
+1) (y
+size
+1)) fmt
71 dolog
"l %d dim=%d {" l
.pageno l
.pagedimno
;
72 dolog
" WxH %dx%d" l
.pagew l
.pageh
;
73 dolog
" vWxH %dx%d" l
.pagevw l
.pagevh
;
74 dolog
" pagex,y %d,%d" l
.pagex l
.pagey
;
75 dolog
" dispx,y %d,%d" l
.pagedispx l
.pagedispy
;
76 dolog
" column %d" l
.pagecol
;
80 let debugrect (x0
, y0
, x1
, y1
, x2
, y2
, x3
, y3
) =
82 dolog
" x0,y0=(% f, % f)" x0 y0
;
83 dolog
" x1,y1=(% f, % f)" x1 y1
;
84 dolog
" x2,y2=(% f, % f)" x2 y2
;
85 dolog
" x3,y3=(% f, % f)" x3 y3
;
89 let isbirdseye = function
96 let istextentry = function
103 let wtmode = ref false;;
104 let cxack = ref false;;
106 let pgscale h
= truncate
(float h
*. conf
.pgscale);;
109 if not state
.uioh#alwaysscrolly
&& (conf
.scrollb
land scrollbhv
= 0)
110 || (state
.x
= 0 && state
.w
<= state
.winw
- conf
.scrollbw
)
116 if not state
.uioh#alwaysscrolly
&& (conf
.scrollb
land scrollbvv
= 0)
124 else x
> state
.winw
- vscrollw ()
127 let wadjsb () = -vscrollw ();;
128 let xadjsb () = if conf
.leftscroll
then vscrollw () else 0;;
131 fstate
.fontsize
<- n
;
132 fstate
.wwidth
<- measurestr fstate
.fontsize
"w";
133 fstate
.maxrows
<- (state
.winh
- fstate
.fontsize
- 1) / (fstate
.fontsize
+ 1);
139 else Printf.kprintf ignore fmt
143 if emptystr conf
.pathlauncher
144 then dolog
"%s" state
.path
146 let command = Str.global_replace percentsre state
.path conf
.pathlauncher
in
147 match spawn
command [] with
150 dolog
"failed to execute `%s': %s" command @@ exntos exn
156 let postRedisplay who
=
157 vlog "redisplay for [%S]" who
;
158 state
.redisplay
<- true;
162 let getopaque pageno
=
163 try Some
(Hashtbl.find state
.pagemap
(pageno
, state
.gen
))
164 with Not_found
-> None
167 let pagetranslatepoint l x y
=
168 let dy = y
- l
.pagedispy
in
169 let y = dy + l
.pagey
in
170 let dx = x
- l
.pagedispx
in
171 let x = dx + l
.pagex
in
175 let onppundermouse g
x y d
=
178 begin match getopaque l
.pageno
with
180 let x0 = l
.pagedispx
in
181 let x1 = x0 + l
.pagevw
in
182 let y0 = l
.pagedispy
in
183 let y1 = y0 + l
.pagevh
in
184 if y >= y0 && y <= y1 && x >= x0 && x <= x1
186 let px, py
= pagetranslatepoint l
x y in
187 match g opaque l
px py
with
200 let g opaque l
px py
=
203 match rectofblock opaque
px py
with
204 | Some
[|x0;x1;y0;y1|] ->
205 let ox = xadjsb () |> float in
206 let rect = (x0+.ox, y0, x1+.ox, y0, x1+.ox, y1, x0+.ox, y1) in
207 let color = (0.0, 0.0, 1.0 /. (l
.pageno
mod 3 |> float), 0.5) in
208 state
.rects
<- [l
.pageno
, color, rect];
209 G.postRedisplay "getunder";
212 let under = whatsunder opaque
px py
in
213 if under = Unone
then None
else Some
under
215 onppundermouse g x y Unone
220 match unproject opaque
x y with
221 | Some
(x, y) -> Some
(Some
(opaque
, l
.pageno
, x, y))
224 onppundermouse g x y None
;
228 state
.text
<- Printf.sprintf
"%c%s" c s
;
229 G.postRedisplay "showtext";
233 Format.ksprintf
(fun s
-> showtext '
!' s
) fmt
;
236 let pipesel opaque cmd
=
239 match Unix.pipe
() with
240 | (exception exn
) -> dolog
"pipesel cannot create pipe: %S" @@ exntos exn
;
242 let doclose what fd
=
243 Ne.clo fd
(fun msg
-> dolog
"%s close failed: %s" what msg
)
246 try spawn cmd
[r
, 0; w
, -1]
248 dolog
"cannot execute %S: %s" cmd
@@ exntos exn
;
254 G.postRedisplay "pipesel";
256 else doclose "pipesel pipe/w" w
;
257 doclose "pipesel pipe/r" r
;
261 let g opaque l
px py
=
262 if markunder opaque
px py conf
.paxmark
265 match getopaque l
.pageno
with
267 | Some opaque
-> pipesel opaque conf
.paxcmd
272 G.postRedisplay "paxunder";
273 if conf
.paxmark
= Mark_page
276 match getopaque l
.pageno
with
278 | Some opaque
-> clearmark opaque
) state
.layout
;
279 state
.roam
<- onppundermouse g x y (fun () -> impmsg "whoopsie daisy");
283 match Unix.pipe
() with
284 | (exception exn
) -> impmsg "pipe failed: %s" @@ exntos exn
287 Ne.clo fd
(fun msg
-> impmsg "failed to close %s: %s" cap msg
)
290 try spawn conf
.selcmd
[r
, 0; w
, -1]
292 impmsg "failed to execute %s: %s" conf
.selcmd
@@ exntos exn
;
298 let l = String.length s
in
299 let bytes = Bytes.unsafe_of_string s
in
300 let n = tempfailureretry
(Unix.write w
bytes 0) l in
302 then impmsg "failed to write %d characters to sel pipe, wrote %d"
305 impmsg "failed to write to sel pipe: %s" @@ exntos exn
308 clo "selstring pipe/r" r
;
309 clo "selstring pipe/w" w
;
312 let undertext ?
(nopath
=false) = function
315 | Ulinkgoto
(pageno
, _
) ->
317 then "page " ^ string_of_int
(pageno
+1)
318 else Printf.sprintf
"%s: page %d" state
.path
(pageno
+1)
319 | Utext s
-> "font: " ^ s
320 | Uunexpected s
-> "unexpected: " ^ s
321 | Ulaunch s
-> "launch: " ^ s
322 | Unamed s
-> "named: " ^ s
323 | Uremote
(filename
, pageno
) ->
324 Printf.sprintf
"%s: page %d" filename
(pageno
+1)
325 | Uremotedest
(filename
, destname
) ->
326 Printf.sprintf
"%s: destination %S" filename destname
327 | Uannotation
(opaque
, slinkindex
) ->
328 "annotation: " ^ getannotcontents opaque slinkindex
331 let updateunder x y =
332 match getunder x y with
333 | Unone
-> Wsi.setcursor
Wsi.CURSOR_INHERIT
335 if conf
.underinfo
then showtext 'u'
("ri: " ^ uri
);
336 Wsi.setcursor
Wsi.CURSOR_INFO
337 | Ulinkgoto
(pageno
, _
) ->
339 then showtext 'p'
("age: " ^ string_of_int
(pageno
+1));
340 Wsi.setcursor
Wsi.CURSOR_INFO
342 if conf
.underinfo
then showtext '
f'
("ont: " ^ s
);
343 Wsi.setcursor
Wsi.CURSOR_TEXT
345 if conf
.underinfo
then showtext 'u'
("nexpected: " ^ s
);
346 Wsi.setcursor
Wsi.CURSOR_INHERIT
348 if conf
.underinfo
then showtext '
l'
("aunch: " ^ s
);
349 Wsi.setcursor
Wsi.CURSOR_INHERIT
351 if conf
.underinfo
then showtext '
n'
("amed: " ^ s
);
352 Wsi.setcursor
Wsi.CURSOR_INHERIT
353 | Uremote
(filename
, pageno
) ->
354 if conf
.underinfo
then showtext 'r'
355 (Printf.sprintf
"emote: %s (%d)" filename
(pageno
+1));
356 Wsi.setcursor
Wsi.CURSOR_INFO
357 | Uremotedest
(filename
, destname
) ->
358 if conf
.underinfo
then showtext 'r'
359 (Printf.sprintf
"emote destination: %s (%S)" filename destname
);
360 Wsi.setcursor
Wsi.CURSOR_INFO
362 if conf
.underinfo
then showtext 'a'
"nnotation";
363 Wsi.setcursor
Wsi.CURSOR_INFO
366 let showlinktype under =
367 if conf
.underinfo
&& under != Unone
368 then showtext ' '
@@ undertext under
371 let intentry_with_suffix text key
=
373 if key
>= 32 && key
< 127
377 match Char.lowercase
c with
379 let text = addchar
text c in
383 let text = addchar
text c in
387 state
.text <- Printf.sprintf
"invalid char (%d, `%c')" key
c;
392 let s = Bytes.create
4 in
393 let n = tempfailureretry
(Unix.read fd
s 0) 4 in
394 if n != 4 then error
"incomplete read(len) = %d" n;
395 let len = (Char.code
(Bytes.get
s 0) lsl 24)
396 lor (Char.code
(Bytes.get
s 1) lsl 16)
397 lor (Char.code
(Bytes.get
s 2) lsl 8)
398 lor (Char.code
(Bytes.get
s 3))
400 let s = Bytes.create
len in
401 let n = tempfailureretry
(Unix.read fd
s 0) len in
402 if n != len then error
"incomplete read(data) %d vs %d" n len;
407 let b = Buffer.create
16 in
408 Buffer.add_string
b "llll";
411 let s = Buffer.to_bytes
b in
412 let n = Bytes.length
s in
414 (* dolog "wcmd %S" (String.sub s 4 len); *)
415 Bytes.set
s 0 (Char.chr
((len lsr 24) land 0xff));
416 Bytes.set
s 1 (Char.chr
((len lsr 16) land 0xff));
417 Bytes.set
s 2 (Char.chr
((len lsr 8) land 0xff));
418 Bytes.set
s 3 (Char.chr
(len land 0xff));
419 let n'
= tempfailureretry
(Unix.write state
.ss
s 0) n in
420 if n'
!= n then error
"write failed %d vs %d" n'
n;
424 let nogeomcmds cmds
=
426 | s, [] -> emptystr
s
430 let layoutN ((columns
, coverA
, coverB
), b) x y sw sh
=
431 let sh = sh - (hscrollh ()) in
432 let wadj = wadjsb () in
433 let rec fold accu
n =
434 if n = Array.length
b
437 let pdimno, dx, vy
, (_
, w
, h
, xoff
) = b.(n) in
440 || n = state
.pagecount
- coverB
441 || (n - coverA
) mod columns
= columns
- 1)
447 let pagey = max
0 (y - vy
) in
448 let pagedispy = if pagey > 0 then 0 else vy
- y in
449 let pagedispx, pagex
=
451 if n = coverA
- 1 || n = state
.pagecount
- coverB
452 then x + (wadj + sw
- w
) / 2
460 let vw = wadj + sw
- pagedispx in
461 let pw = w
- pagex
in
464 let pagevh = min
(h
- pagey) (sh - pagedispy) in
465 if pagevw > 0 && pagevh > 0
476 ; pagedispx = pagedispx
477 ; pagedispy = pagedispy
489 if Array.length
b = 0
491 else List.rev
(fold [] (page_of_y
y))
494 let layoutS (columns
, b) x y sw
sh =
495 let sh = sh - hscrollh () in
496 let wadj = wadjsb () in
497 let rec fold accu n =
498 if n = Array.length
b
501 let pdimno, px, vy
, (_
, pagew
, pageh
, xoff
) = b.(n) in
509 let pagey = max
0 (y - vy
) in
510 let pagedispy = if pagey > 0 then 0 else vy
- y in
511 let pagedispx, pagex
=
525 let pagecolw = pagew
/columns
in
528 then pagedispx + ((wadj + sw
- pagecolw) / 2)
532 let vw = wadj + sw
- pagedispx in
533 let pw = pagew
- pagex
in
536 let pagevw = min
pagevw pagecolw in
537 let pagevh = min
(pageh
- pagey) (sh - pagedispy) in
538 if pagevw > 0 && pagevh > 0
549 ; pagedispx = pagedispx
550 ; pagedispy = pagedispy
551 ; pagecol
= n mod columns
565 let layout x y sw
sh =
566 if nogeomcmds state
.geomcmds
568 match conf
.columns
with
569 | Csingle
b -> layoutN ((1, 0, 0), b) x y sw
sh
570 | Cmulti
c -> layoutN c x y sw
sh
571 | Csplit
s -> layoutS s x y sw
sh
576 let y = state
.y + incr
in
578 let y = min
y (state
.maxy
- (if conf
.maxhfit
then state
.winh
else 0)) in
583 let tilex = l.pagex
mod conf
.tilew
in
584 let tiley = l.pagey mod conf
.tileh
in
586 let col = l.pagex
/ conf
.tilew
in
587 let row = l.pagey / conf
.tileh
in
589 let xadj = xadjsb () in
590 let rec rowloop row y0 dispy h
=
594 let dh = conf
.tileh
- y0 in
596 let rec colloop col x0 dispx w
=
600 let dw = conf
.tilew
- x0 in
602 let dispx'
= xadj + dispx in
603 f col row dispx' dispy
x0 y0 dw dh;
604 colloop (col+1) 0 (dispx+dw) (w
-dw)
607 colloop col tilex l.pagedispx l.pagevw;
608 rowloop (row+1) 0 (dispy
+dh) (h
-dh)
611 if l.pagevw > 0 && l.pagevh > 0
612 then rowloop row tiley l.pagedispy l.pagevh;
615 let gettileopaque l col row =
617 l.pageno
, state
.gen
, conf
.colorspace
, conf
.angle
, l.pagew
, l.pageh
, col, row
619 try Some
(Hashtbl.find state
.tilemap
key)
620 with Not_found
-> None
623 let puttileopaque l col row gen colorspace angle opaque size elapsed
=
624 let key = l.pageno
, gen
, colorspace
, angle
, l.pagew
, l.pageh
, col, row in
625 Hashtbl.add state
.tilemap
key (opaque
, size
, elapsed
)
628 let filledrect x0 y0 x1 y1 =
629 GlArray.disable `texture_coord
;
630 Raw.sets_float state
.vraw ~pos
:0 [| x0; y0; x0; y1; x1; y0; x1; y1 |];
631 GlArray.vertex `two state
.vraw
;
632 GlArray.draw_arrays `triangle_strip ~first
:0 ~count
:4;
633 GlArray.enable `texture_coord
;
636 let linerect x0 y0 x1 y1 =
637 GlArray.disable `texture_coord
;
638 Raw.sets_float state
.vraw ~pos
:0 [| x0; y0; x0; y1; x1; y1; x1; y0 |];
639 GlArray.vertex `two state
.vraw
;
640 GlArray.draw_arrays `line_loop ~first
:0 ~count
:4;
641 GlArray.enable `texture_coord
;
644 let drawtiles l color =
646 let wadj = wadjsb () in
648 let f col row x y tilex tiley w h
=
649 match gettileopaque l col row with
650 | Some
(opaque
, _
, t
) ->
651 let params = x, y, w
, h
, tilex, tiley in
653 then GlTex.env
(`mode `blend
);
654 drawtile
params opaque
;
656 then GlTex.env
(`mode `modulate
);
660 let s = Printf.sprintf
664 let w = measurestr fstate
.fontsize
s in
665 GlDraw.color (0.0, 0.0, 0.0);
666 filledrect (float (x-2))
669 (float (y + fstate
.fontsize
+ 2));
670 GlDraw.color (1.0, 1.0, 1.0);
671 drawstring fstate
.fontsize
x (y + fstate
.fontsize
- 1) s;
681 let lw = wadj + state
.winw
- x in
684 let lh = state
.winh
- y in
688 then GlTex.env
(`mode `blend
);
689 begin match state
.checkerstexid
with
691 Gl.enable `texture_2d
;
692 GlTex.bind_texture ~target
:`texture_2d id
;
696 and y1 = float (y+h
) in
698 let tw = float w /. 16.0
699 and th
= float h
/. 16.0 in
700 let tx0 = float tilex /. 16.0
701 and ty0
= float tiley /. 16.0 in
703 and ty1
= ty0
+. th
in
704 Raw.sets_float state
.vraw ~pos
:0
705 [| x0; y0; x0; y1; x1; y0; x1; y1 |];
706 Raw.sets_float state
.traw ~pos
:0
707 [| tx0; ty0
; tx0; ty1
; tx1; ty0
; tx1; ty1
|];
708 GlArray.vertex `two state
.vraw
;
709 GlArray.tex_coord `two state
.traw
;
710 GlArray.draw_arrays `triangle_strip ~first
:0 ~count
:4;
711 Gl.disable `texture_2d
;
714 GlDraw.color (1.0, 1.0, 1.0);
715 filledrect (float x) (float y) (float (x+w)) (float (y+h
));
718 then GlTex.env
(`mode `modulate
);
719 if w > 128 && h
> fstate
.fontsize
+ 10
721 let c = if conf
.invert
then 1.0 else 0.0 in
722 GlDraw.color (c, c, c);
725 then (col*conf
.tilew
, row*conf
.tileh
)
728 drawstring2 fstate
.fontsize
x y "Loading %d [%d,%d]" l.pageno
c r
;
737 let pagevisible layout n = List.exists
(fun l -> l.pageno
= n) layout;;
739 let tilevisible1 l x y =
741 and ax1
= l.pagex
+ l.pagevw
743 and ay1
= l.pagey + l.pagevh in
747 let bx1 = min
(bx0 + conf
.tilew
) l.pagew
748 and by1
= min
(by0
+ conf
.tileh
) l.pageh
in
750 let rx0 = max
ax0 bx0
751 and ry0
= max ay0 by0
752 and rx1
= min ax1
bx1
753 and ry1
= min ay1 by1
in
755 let nonemptyintersection = rx1
> rx0 && ry1
> ry0
in
759 let tilevisible layout n x y =
760 let rec findpageinlayout m
= function
761 | l :: rest
when l.pageno
= n ->
762 tilevisible1 l x y || (
763 match conf
.columns
with
764 | Csplit
(c, _
) when c > m
-> findpageinlayout (m
+1) rest
769 | _
:: rest
-> findpageinlayout 0 rest
772 findpageinlayout 0 layout;
775 let tileready l x y =
776 tilevisible1 l x y &&
777 gettileopaque l (x/conf
.tilew
) (y/conf
.tileh
) != None
780 let tilepage n p
layout =
781 let rec loop = function
785 let f col row _ _ _ _ _ _
=
786 if state
.currently
= Idle
788 match gettileopaque l col row with
791 let x = col*conf
.tilew
792 and y = row*conf
.tileh
in
794 let w = l.pagew
- x in
798 let h = l.pageh
- y in
803 then getpbo
w h conf
.colorspace
806 wcmd "tile %s %d %d %d %d %s"
807 (~
> p
) x y w h (~
> pbo);
810 l, p
, conf
.colorspace
, conf
.angle
,
811 state
.gen
, col, row, conf
.tilew
, conf
.tileh
820 if nogeomcmds state
.geomcmds
824 let preloadlayout x y sw
sh =
825 let y = if y < sh then 0 else y - sh in
832 if state
.currently
!= Idle
837 begin match getopaque l.pageno
with
839 wcmd "page %d %d" l.pageno
l.pagedimno
;
840 state
.currently
<- Loading
(l, state
.gen
);
842 tilepage l.pageno opaque pages
;
847 if nogeomcmds state
.geomcmds
853 if conf
.preload && state
.currently
= Idle
854 then load (preloadlayout state
.x state
.y state
.winw state
.winh
);
857 let layoutready layout =
858 let rec fold all ls
=
861 let seen = ref false in
862 let allvisible = ref true in
863 let foo col row _ _ _ _ _ _
=
865 allvisible := !allvisible &&
866 begin match gettileopaque l col row with
872 fold (!seen && !allvisible) rest
875 let alltilesvisible = fold true layout in
880 let y = bound
y 0 state
.maxy
in
881 let y, layout, proceed
=
882 match conf
.maxwait
with
883 | Some time
when state
.ghyll
== noghyll
->
884 begin match state
.throttle
with
886 let layout = layout state
.x y state
.winw state
.winh
in
887 let ready = layoutready layout in
891 state
.throttle
<- Some
(layout, y, now
());
893 else G.postRedisplay "gotoy showall (None)";
895 | Some
(_
, _
, started
) ->
896 let dt = now
() -. started
in
899 state
.throttle
<- None
;
900 let layout = layout state
.x y state
.winw state
.winh
in
902 G.postRedisplay "maxwait";
909 let layout = layout state
.x y state
.winw state
.winh
in
910 if not
!wtmode || layoutready layout
911 then G.postRedisplay "gotoy ready";
917 state
.layout <- layout;
918 begin match state
.mode
with
921 | Ltexact
(pageno
, linkno
) ->
922 let rec loop = function
924 state
.mode
<- LinkNav
(Ltgendir
0)
925 | l :: _
when l.pageno
= pageno
->
926 begin match getopaque pageno
with
927 | None
-> state
.mode
<- LinkNav
(Ltnotready
(pageno
, 0))
929 let x0, y0, x1, y1 = getlinkrect opaque linkno
in
930 if not
(x0 >= l.pagex
&& x1 <= l.pagex
+ l.pagevw
931 && y0 >= l.pagey && y1 <= l.pagey + l.pagevh)
932 then state
.mode
<- LinkNav
(Ltgendir
0)
934 | _
:: rest
-> loop rest
937 | Ltnotready _
| Ltgendir _
-> ()
943 begin match state
.mode
with
944 | Birdseye
(conf
, leftx
, pageno
, hooverpageno
, anchor
) ->
945 if not
(pagevisible layout pageno
)
947 match state
.layout with
950 state
.mode
<- Birdseye
(
951 conf
, leftx
, l.pageno
, hooverpageno
, anchor
956 | Ltnotready
(_
, dir
)
959 let rec loop = function
962 match getopaque l.pageno
with
963 | None
-> Ltnotready
(l.pageno
, dir
)
968 then LDfirstvisible
(l.pagex
, l.pagey, dir
)
970 if dir
> 0 then LDfirst
else LDlast
976 | Lnotfound
-> loop rest
978 showlinktype (getlink opaque
n);
979 Ltexact
(l.pageno
, n)
983 state
.mode
<- LinkNav
linknav
991 state
.ghyll
<- noghyll
;
994 let mx, my
= state
.mpos
in
999 let conttiling pageno opaque
=
1000 tilepage pageno opaque
1002 then preloadlayout state
.x state
.y state
.winw state
.winh
1006 let gotoy_and_clear_text y =
1007 if not conf
.verbose
then state
.text <- E.s;
1011 let getanchory (n, top
, dtop
) =
1012 let y, h = getpageyh
n in
1013 if conf
.presentation
1015 let ips = calcips
h in
1016 y + truncate
(top
*.float h -. dtop
*.float ips) + ips;
1018 y + truncate
(top
*.float h -. dtop
*.float conf
.interpagespace
)
1021 let gotoanchor anchor
=
1022 gotoy (getanchory anchor
);
1026 cbput state
.hists
.nav
(getanchor
());
1030 let anchor = cbgetc state
.hists
.nav dir
in
1034 let gotoghyll1 single
y =
1035 let scroll f n a
b =
1036 (* http://devmaster.net/forums/topic/9796-ease-in-ease-out-algorithm/ *)
1038 let s x = 3.0*.x**2.0 -. 2.0*.x**3.0 in
1040 then s (float f /. float a
)
1043 then 1.0 -. s ((float (f-b) /. float (n-b)))
1049 let ins = float a
*. 0.5
1050 and outs
= float (n-b) *. 0.5 in
1052 ins +. outs
+. float ones
1054 let rec set nab
y sy
=
1055 let (_N
, _A
, _B
), y =
1058 let scl = if y > sy
then 2 else -2 in
1059 let _N, _
, _
= nab
in
1060 (_N,0,_N), y+conf
.scrollstep
*scl
1062 let sum = summa
_N _A _B
in
1063 let dy = float (y - sy
) in
1067 then state
.ghyll
<- noghyll
1070 let s = scroll n _N _A _B
in
1071 let y1 = y1 +. ((s *. dy) /. sum) in
1072 gotoy_and_clear_text (truncate
y1);
1073 state
.ghyll
<- gf (n+1) y1;
1077 | Some
y'
when single
-> set nab
y' state
.y
1078 | Some
y'
-> set (_N/2, 1, 1) y' state
.y
1080 gf 0 (float state
.y)
1083 match conf
.ghyllscroll
with
1084 | Some nab
when not conf
.presentation
->
1085 if state
.ghyll
== noghyll
1086 then set nab
y state
.y
1087 else state
.ghyll
(Some
y)
1089 gotoy_and_clear_text y
1092 let gotoghyll = gotoghyll1 false;;
1094 let gotopage n top
=
1095 let y, h = getpageyh
n in
1096 let y = y + (truncate
(top
*. float h)) in
1100 let gotopage1 n top
=
1101 let y = getpagey
n in
1106 let invalidate s f =
1111 match state
.geomcmds
with
1112 | ps
, [] when emptystr ps
->
1114 state
.geomcmds
<- s, [];
1117 state
.geomcmds
<- ps
, [s, f];
1119 | ps
, (s'
, _
) :: rest
when s'
= s ->
1120 state
.geomcmds
<- ps
, ((s, f) :: rest
);
1123 state
.geomcmds
<- ps
, ((s, f) :: cmds
);
1127 Hashtbl.iter
(fun _ opaque
->
1128 wcmd "freepage %s" (~
> opaque
);
1130 Hashtbl.clear state
.pagemap
;
1134 if not
(Queue.is_empty state
.tilelru
)
1136 Queue.iter
(fun (k
, p
, s) ->
1137 wcmd "freetile %s" (~
> p
);
1138 state
.memused
<- state
.memused
- s;
1139 Hashtbl.remove state
.tilemap k
;
1141 state
.uioh#infochanged Memused
;
1142 Queue.clear state
.tilelru
;
1148 let h = truncate
(float h*.conf
.zoom
) in
1149 let d = conf
.interpagespace
lsl (if conf
.presentation
then 1 else 0) in
1153 let opendoc path password
=
1155 state
.password
<- password
;
1156 state
.gen
<- state
.gen
+ 1;
1157 state
.docinfo
<- [];
1158 state
.outlines
<- [||];
1161 setaalevel conf
.aalevel
;
1163 if emptystr state
.origin
1167 Wsi.settitle
("llpp " ^
(mbtoutf8
(Filename.basename
titlepath)));
1168 wcmd "open %d %d %s\000%s\000" (btod
!wtmode) (btod
!cxack) path password
;
1169 invalidate "reqlayout"
1171 wcmd "reqlayout %d %d %d %s\000"
1172 conf
.angle
(FMTE.to_int conf
.fitmodel
)
1173 (stateh state
.winh
) state
.nameddest
1178 state
.anchor <- getanchor
();
1179 opendoc state
.path state
.password
;
1183 let c = c *. conf
.colorscale
in
1187 let scalecolor2 (r
, g, b) =
1188 (r
*. conf
.colorscale
, g *. conf
.colorscale
, b *. conf
.colorscale
);
1191 let docolumns columns
=
1192 let wadj = wadjsb () in
1195 let a = Array.make state
.pagecount
(-1, -1, -1, (-1, -1, -1, -1)) in
1196 let wadj = wadjsb () in
1197 let rec loop pageno
pdimno pdim
y ph pdims
=
1198 if pageno
= state
.pagecount
1201 let pdimno, ((_
, w, h, xoff
) as pdim
), pdims
=
1203 | ((pageno'
, _
, _
, _
) as pdim
) :: rest
when pageno'
= pageno
->
1204 pdimno+1, pdim
, rest
1208 let x = max
0 (((wadj + state
.winw
- w) / 2) - xoff
) in
1210 (if conf
.presentation
1211 then (if pageno
= 0 then calcips
h else calcips ph
+ calcips
h)
1212 else (if pageno
= 0 then 0 else conf
.interpagespace
)
1215 a.(pageno
) <- (pdimno, x, y, pdim
);
1216 loop (pageno
+1) pdimno pdim
(y + h) h pdims
1218 loop 0 ~
-1 (-1,-1,-1,-1) 0 0 state
.pdims
;
1219 conf
.columns
<- Csingle
a;
1221 | Cmulti
((columns
, coverA
, coverB
), _
) ->
1222 let a = Array.make state
.pagecount
(-1, -1, -1, (-1, -1, -1, -1)) in
1223 let rec loop pageno
pdimno pdim
x y rowh pdims
=
1224 let rec fixrow m
= if m
= pageno
then () else
1225 let (pdimno, x, y, ((_
, _
, h, _
) as pdim
)) = a.(m
) in
1228 let y = y + (rowh
- h) / 2 in
1229 a.(m
) <- (pdimno, x, y, pdim
);
1233 if pageno
= state
.pagecount
1234 then fixrow (((pageno
- 1) / columns
) * columns
)
1236 let pdimno, ((_
, w, h, xoff
) as pdim
), pdims
=
1238 | ((pageno'
, _
, _
, _
) as pdim
) :: rest
when pageno'
= pageno
->
1239 pdimno+1, pdim
, rest
1244 if pageno
= coverA
- 1 || pageno
= state
.pagecount
- coverB
1246 let x = (wadj + state
.winw
- w) / 2 in
1248 if conf
.presentation
then calcips
h else conf
.interpagespace
in
1249 x, y + ips + rowh
, h
1252 if (pageno
- coverA
) mod columns
= 0
1254 let x = max
0 (wadj + state
.winw
- state
.w) / 2 in
1256 if conf
.presentation
1258 let ips = calcips
h in
1259 y + (if pageno
= 0 then 0 else calcips rowh
+ ips)
1261 y + (if pageno
= 0 then 0 else conf
.interpagespace
)
1265 else x, y, max rowh
h
1269 if pageno
> 1 && (pageno
- coverA
) mod columns
= 0
1272 if pageno
= columns
&& conf
.presentation
1274 let ips = calcips rowh
in
1275 for i
= 0 to pred columns
1277 let (pdimno, x, y, pdim
) = a.(i
) in
1278 a.(i
) <- (pdimno, x, y+ips, pdim
)
1284 fixrow (pageno
- columns
);
1289 a.(pageno
) <- (pdimno, x, y, pdim
);
1290 let x = x + w + xoff
*2 + conf
.interpagespace
in
1291 loop (pageno
+1) pdimno pdim
x y rowh' pdims
1293 loop 0 ~
-1 (-1,-1,-1,-1) 0 0 0 state
.pdims
;
1294 conf
.columns
<- Cmulti
((columns
, coverA
, coverB
), a);
1297 let a = Array.make
(state
.pagecount
*c) (-1, -1, -1, (-1, -1, -1, -1)) in
1298 let rec loop pageno
pdimno pdim
y pdims
=
1299 if pageno
= state
.pagecount
1302 let pdimno, ((_
, w, h, _
) as pdim
), pdims
=
1304 | ((pageno'
, _
, _
, _
) as pdim
) :: rest
when pageno'
= pageno
->
1305 pdimno+1, pdim
, rest
1310 let rec loop1 n x y =
1311 if n = c then y else (
1312 a.(pageno
*c + n) <- (pdimno, x, y, pdim
);
1313 loop1 (n+1) (x+cw) (y + h + conf
.interpagespace
)
1316 let y = loop1 0 0 y in
1317 loop (pageno
+1) pdimno pdim
y pdims
1319 loop 0 ~
-1 (-1,-1,-1,-1) 0 state
.pdims
;
1320 conf
.columns
<- Csplit
(c, a);
1324 docolumns conf
.columns
;
1325 state
.maxy
<- calcheight
();
1326 if state
.reprf
== noreprf
1328 match state
.mode
with
1329 | Birdseye
(_
, _
, pageno
, _
, _
) ->
1330 let y, h = getpageyh pageno
in
1331 let top = (state
.winh
- h) / 2 in
1332 gotoy (max
0 (y - top))
1335 | LinkNav _
-> gotoanchor state
.anchor
1339 state
.reprf
<- noreprf
;
1343 let reshape ?
(firsttime
=false) w h =
1344 GlDraw.viewport ~
x:0 ~
y:0 ~
w:w ~
h:h;
1345 if not firsttime
&& nogeomcmds state
.geomcmds
1346 then state
.anchor <- getanchor
();
1349 let w = wadjsb () + (truncate
(float w *. conf
.zoom
)) in
1352 setfontsize fstate
.fontsize
;
1353 GlMat.mode `modelview
;
1354 GlMat.load_identity
();
1356 GlMat.mode `projection
;
1357 GlMat.load_identity
();
1358 GlMat.rotate ~
x:1.0 ~angle
:180.0 ();
1359 GlMat.translate ~
x:~
-.1.0 ~
y:~
-.1.0 ();
1360 GlMat.scale3
(2.0 /. float state
.winw
, 2.0 /. float state
.winh
, 1.0);
1365 else float state
.x /. float state
.w
1367 invalidate "geometry"
1371 then state
.x <- truncate
(relx *. float w);
1373 match conf
.columns
with
1375 | Cmulti
((c, _
, _
), _
) -> (w - (c-1)*conf
.interpagespace
) / c
1376 | Csplit
(c, _
) -> w * c
1378 wcmd "geometry %d %d %d"
1379 w (stateh h) (FMTE.to_int conf
.fitmodel
)
1384 let len = String.length state
.text in
1385 let x0 = xadjsb () in
1388 match state
.mode
with
1389 | Textentry _
| View
| LinkNav _
->
1390 let h, _
, _
= state
.uioh#scrollpw
in
1395 filledrect x (float (state
.winh
- (fstate
.fontsize
+ 4) - hscrollh))
1396 (x+.w) (float (state
.winh
- hscrollh))
1399 let w = float (wadjsb () + state
.winw
- 1) in
1400 if state
.progress
>= 0.0 && state
.progress
< 1.0
1402 GlDraw.color (0.3, 0.3, 0.3);
1403 let w1 = w *. state
.progress
in
1405 GlDraw.color (0.0, 0.0, 0.0);
1406 rect (float x0+.w1) (float x0+.w-.w1)
1409 GlDraw.color (0.0, 0.0, 0.0);
1413 GlDraw.color (1.0, 1.0, 1.0);
1414 drawstring fstate
.fontsize
1415 (if conf
.leftscroll
then x0 + 2 else x0 + if len > 0 then 8 else 2)
1416 (state
.winh
- hscrollh - 5) s;
1419 match state
.mode
with
1420 | Textentry
((prefix
, text, _
, _
, _
, _
), _
) ->
1424 Printf.sprintf
"%s%s_ [%s]" prefix
text state
.text
1426 Printf.sprintf
"%s%s_" prefix
text
1432 | LinkNav _
-> state
.text
1437 if not
(istextentry state
.mode
) && state
.uioh#eformsgs
1439 let s1 = "(press 'e' to review error messasges)" in
1440 if nonemptystr
s then s ^
" " ^
s1 else s1
1450 let len = Queue.length state
.tilelru
in
1452 match state
.throttle
with
1455 then preloadlayout state
.x state
.y state
.winw state
.winh
1457 | Some
(layout, _
, _
) ->
1461 if state
.memused
<= conf
.memlimit
1466 let (k
, p
, s) as lruitem
= Queue.pop state
.tilelru
in
1467 let n, gen
, colorspace
, angle
, pagew
, pageh
, col, row = k
in
1468 let (_
, pw, ph
, _
) = getpagedim
n in
1471 && colorspace
= conf
.colorspace
1472 && angle
= conf
.angle
1476 let x = col*conf
.tilew
1477 and y = row*conf
.tileh
in
1478 tilevisible (Lazy.force_val
layout) n x y
1480 then Queue.push lruitem state
.tilelru
1483 wcmd "freetile %s" (~
> p
);
1484 state
.memused
<- state
.memused
- s;
1485 state
.uioh#infochanged Memused
;
1486 Hashtbl.remove state
.tilemap k
;
1494 let onpagerect pageno
f =
1496 match conf
.columns
with
1497 | Cmulti
(_
, b) -> b
1499 | Csplit
(_
, b) -> b
1501 if pageno
>= 0 && pageno
< Array.length
b
1503 let (_
, _
, _
, (_
, w, h, _
)) = b.(pageno
) in
1507 let gotopagexy1 pageno
x y =
1508 let _,w1,h1
,leftx
= getpagedim pageno
in
1509 let top = y /. (float h1
) in
1510 let left = x /. (float w1) in
1511 let py, w, h = getpageywh pageno
in
1512 let wh = state
.winh
- hscrollh () in
1513 let x = left *. (float w) in
1514 let x = leftx
+ state
.x + truncate
x in
1515 let wadj = wadjsb () in
1517 if x < 0 || x >= wadj + state
.winw
1521 let pdy = truncate
(top *. float h) in
1522 let y'
= py + pdy in
1523 let dy = y'
- state
.y in
1525 if x != state
.x || not
(dy > 0 && dy < wh)
1527 if conf
.presentation
1529 if abs
(py - y'
) > wh
1536 if state
.x != sx || state
.y != sy
1541 let ww = wadj + state
.winw
in
1543 and qy
= pdy / wh in
1545 and y = py + qy
* wh in
1546 let x = if -x + ww > w1 then -(w1-ww) else x
1547 and y'
= if y + wh > state
.maxy
then state
.maxy
- wh else y in
1549 if conf
.presentation
1551 if abs
(py - y'
) > wh
1561 gotoy_and_clear_text y;
1563 else gotoy_and_clear_text state
.y;
1566 let gotopagexy pageno
x y =
1567 match state
.mode
with
1568 | Birdseye
_ -> gotopage pageno
0.0
1571 | LinkNav
_ -> gotopagexy1 pageno
x y
1574 let getpassword () =
1575 let passcmd = getenvwithdef
"LLPP_ASKPASS" conf
.passcmd in
1580 impmsg "error getting password: %s" s;
1581 dolog
"%s" s) passcmd;
1584 let pgoto opaque pageno
x y =
1585 let pdimno = getpdimno pageno
in
1586 let x, y = project opaque pageno
pdimno x y in
1587 gotopagexy pageno
x y;
1591 (* dolog "%S" cmds; *)
1592 let cl = splitatspace cmds
in
1594 try Scanf.sscanf
s fmt
f
1596 dolog
"error processing '%S': %s" cmds
@@ exntos exn
;
1599 let addoutline outline
=
1600 match state
.currently
with
1601 | Outlining outlines
->
1602 state
.currently
<- Outlining
(outline
:: outlines
)
1603 | Idle
-> state
.currently
<- Outlining
[outline
]
1606 dolog
"invalid outlining state";
1607 logcurrently state
.currently
1611 state
.uioh#infochanged Pdim
;
1614 | "clearrects" :: [] ->
1615 state
.rects
<- state
.rects1
;
1616 G.postRedisplay "clearrects";
1618 | "continue" :: args
:: [] ->
1619 let n = scan args
"%u" (fun n -> n) in
1620 state
.pagecount
<- n;
1621 begin match state
.currently
with
1623 state
.currently
<- Idle
;
1624 state
.outlines
<- Array.of_list
(List.rev
l)
1630 let cur, cmds
= state
.geomcmds
in
1632 then failwith
"umpossible";
1634 begin match List.rev cmds
with
1636 state
.geomcmds
<- E.s, [];
1637 state
.throttle
<- None
;
1641 state
.geomcmds
<- s, List.rev rest
;
1643 if conf
.maxwait
= None
&& not
!wtmode
1644 then G.postRedisplay "continue";
1646 | "msg" :: args
:: [] ->
1649 | "vmsg" :: args
:: [] ->
1651 then showtext ' ' args
1653 | "emsg" :: args
:: [] ->
1654 Buffer.add_string state
.errmsgs args
;
1655 state
.newerrmsgs
<- true;
1656 G.postRedisplay "error message"
1658 | "progress" :: args
:: [] ->
1659 let progress, text =
1662 f, String.sub args pos
(String.length args
- pos
))
1665 state
.progress <- progress;
1666 G.postRedisplay "progress"
1668 | "firstmatch" :: args
:: [] ->
1669 let pageno, c, x0, y0, x1, y1, x2
, y2
, x3
, y3
=
1670 scan args
"%u %d %f %f %f %f %f %f %f %f"
1671 (fun p
c x0 y0 x1 y1 x2 y2 x3 y3
->
1672 (p
, c, x0, y0, x1, y1, x2
, y2
, x3
, y3
))
1674 let xoff = float (xadjsb ()) in
1678 and x3
= x3
+. xoff in
1679 let y = (getpagey
pageno) + truncate
y0 in
1681 then state
.x <- truncate
(xoff -. x0) + state
.winw
/2;
1684 let color = (0.0, 0.0, 1.0 /. float c, 0.5) in
1685 state
.rects1
<- [pageno, color, (x0, y0, x1, y1, x2
, y2
, x3
, y3
)]
1687 | "match" :: args
:: [] ->
1688 let pageno, c, x0, y0, x1, y1, x2
, y2
, x3
, y3
=
1689 scan args
"%u %d %f %f %f %f %f %f %f %f"
1690 (fun p
c x0 y0 x1 y1 x2 y2 x3 y3
->
1691 (p
, c, x0, y0, x1, y1, x2
, y2
, x3
, y3
))
1693 let xoff = float (xadjsb ()) in
1697 and x3
= x3
+. xoff in
1698 let color = (0.0, 0.0, 1.0 /. float c, 0.5) in
1700 (pageno, color, (x0, y0, x1, y1, x2
, y2
, x3
, y3
)) :: state
.rects1
1702 | "page" :: args
:: [] ->
1703 let pageopaques, t
= scan args
"%s %f" (fun p t
-> p
, t
) in
1704 let pageopaque = ~
< pageopaques in
1705 begin match state
.currently
with
1706 | Loading
(l, gen
) ->
1707 vlog "page %d took %f sec" l.pageno t
;
1708 Hashtbl.replace state
.pagemap
(l.pageno, gen
) pageopaque;
1709 begin match state
.throttle
with
1711 let preloadedpages =
1713 then preloadlayout state
.x state
.y state
.winw state
.winh
1718 List.fold_left
(fun s l -> IntSet.add
l.pageno s)
1719 IntSet.empty
preloadedpages
1722 Hashtbl.fold (fun ((pageno, _) as key) opaque
accu ->
1723 if not
(IntSet.mem
pageno set)
1725 wcmd "freepage %s" (~
> opaque
);
1731 List.iter
(Hashtbl.remove state
.pagemap
) evictedpages;
1734 state
.currently
<- Idle
;
1737 tilepage l.pageno pageopaque state
.layout;
1739 load preloadedpages;
1740 let visible = pagevisible state
.layout l.pageno in
1743 match state
.mode
with
1744 | LinkNav
(Ltnotready
(pageno, dir
)) ->
1745 if pageno = l.pageno
1750 then LDfirstvisible
(l.pagex
, l.pagey, dir
)
1752 if dir
> 0 then LDfirst
else LDlast
1755 findlink
pageopaque ld
1760 showlinktype (getlink
pageopaque n);
1761 state
.mode
<- LinkNav
(Ltexact
(l.pageno, n))
1763 | LinkNav
(Ltgendir
_)
1764 | LinkNav
(Ltexact
_)
1770 if visible && layoutready state
.layout
1772 G.postRedisplay "page";
1776 | Some
(layout, _, _) ->
1777 state
.currently
<- Idle
;
1778 tilepage l.pageno pageopaque layout;
1785 dolog
"Inconsistent loading state";
1786 logcurrently state
.currently
;
1790 | "tile" :: args
:: [] ->
1791 let (x, y, opaques
, size
, t
) =
1792 scan args
"%u %u %s %u %f"
1793 (fun x y p size t
-> (x, y, p
, size
, t
))
1795 let opaque = ~
< opaques
in
1796 begin match state
.currently
with
1797 | Tiling
(l, pageopaque, cs
, angle
, gen
, col, row, tilew
, tileh
) ->
1798 vlog "tile %d [%d,%d] took %f sec" l.pageno col row t
;
1801 if tilew
!= conf
.tilew
|| tileh
!= conf
.tileh
1803 wcmd "freetile %s" (~
> opaque);
1804 state
.currently
<- Idle
;
1808 puttileopaque l col row gen cs angle
opaque size t
;
1809 state
.memused
<- state
.memused
+ size
;
1810 state
.uioh#infochanged Memused
;
1812 Queue.push
((l.pageno, gen
, cs
, angle
, l.pagew
, l.pageh
, col, row),
1813 opaque, size
) state
.tilelru
;
1816 match state
.throttle
with
1817 | None
-> state
.layout
1818 | Some
(layout, _, _) -> layout
1821 state
.currently
<- Idle
;
1823 && conf
.colorspace
= cs
1824 && conf
.angle
= angle
1825 && tilevisible layout l.pageno x y
1826 then conttiling l.pageno pageopaque;
1828 begin match state
.throttle
with
1830 preload state
.layout;
1832 && conf
.colorspace
= cs
1833 && conf
.angle
= angle
1834 && tilevisible state
.layout l.pageno x y
1835 && (not
!wtmode || layoutready state
.layout)
1836 then G.postRedisplay "tile nothrottle";
1838 | Some
(layout, y, _) ->
1839 let ready = layoutready layout in
1843 state
.layout <- layout;
1844 state
.throttle
<- None
;
1845 G.postRedisplay "throttle";
1854 dolog
"Inconsistent tiling state";
1855 logcurrently state
.currently
;
1859 | "pdim" :: args
:: [] ->
1860 let (n, w, h, _) as pdim
=
1861 scan args
"%u %u %u %u" (fun n w h x -> n, w, h, x)
1864 match conf
.fitmodel
with
1866 | FitPage
| FitProportional
->
1867 match conf
.columns
with
1868 | Csplit
_ -> (n, w, h, 0)
1869 | Csingle
_ | Cmulti
_ -> pdim
1871 state
.uioh#infochanged Pdim
;
1872 state
.pdims
<- pdim :: state
.pdims
1874 | "o" :: args
:: [] ->
1875 let (l, n, t
, h, pos
) =
1876 scan args
"%u %u %d %u %n"
1877 (fun l n t
h pos
-> l, n, t
, h, pos
)
1879 let s = String.sub args pos
(String.length args
- pos
) in
1880 addoutline (s, l, Oanchor
(n, float t
/. float h, 0.0))
1882 | "ou" :: args
:: [] ->
1883 let (l, len, pos
) = scan args
"%u %u %n" (fun l len pos
-> l, len, pos
) in
1884 let s = String.sub args pos
len in
1885 let pos2 = pos
+ len + 1 in
1886 let uri = String.sub args
pos2 (String.length args
- pos2) in
1887 addoutline (s, l, Ouri
uri)
1889 | "on" :: args
:: [] ->
1890 let (l, pos
) = scan args
"%u %n" (fun l pos
-> l, pos
) in
1891 let s = String.sub args pos
(String.length args
- pos
) in
1892 addoutline (s, l, Onone
)
1894 | "a" :: args
:: [] ->
1896 scan args
"%u %d %d" (fun n l t
-> n, l, t
)
1898 state
.reprf
<- (fun () -> gotopagexy n (float l) (float t
))
1900 | "info" :: args
:: [] ->
1901 let pos = nindex args '
\t'
in
1902 if pos >= 0 && String.sub args
0 pos = "Title"
1904 let s = String.sub args
(pos+1) @@ String.length args
- pos - 1 in
1908 state
.docinfo
<- (1, args
) :: state
.docinfo
1910 | "infoend" :: [] ->
1911 state
.uioh#infochanged Docinfo
;
1912 state
.docinfo
<- List.rev state
.docinfo
1916 then Wsi.settitle
"Wrong password";
1917 let password = getpassword () in
1918 if emptystr
password
1919 then error
"document is password protected"
1920 else opendoc state
.path
password
1922 error
"unknown cmd `%S'" cmds
1927 let action = function
1928 | HCprev
-> cbget cb ~
-1
1929 | HCnext
-> cbget cb
1
1930 | HCfirst
-> cbget cb ~
-(cb
.rc)
1931 | HClast
-> cbget cb
(cb
.len - 1 - cb
.rc)
1932 and cancel
() = cb
.rc <- rc
1936 let search pattern forward
=
1937 match conf
.columns
with
1938 | Csplit
_ -> impmsg "searching does not work properly in split columns mode"
1941 if nonemptystr pattern
1944 match state
.layout with
1947 l.pageno, (l.pagey + if forward
then 0 else 0*l.pagevh)
1949 wcmd "search %d %d %d %d,%s\000"
1950 (btod conf
.icase
) pn py (btod forward
) pattern
;
1953 let intentry text key =
1955 if key >= 32 && key < 127
1961 let text = addchar
text c in
1965 state
.text <- Printf.sprintf
"invalid char (%d, `%c')" key c;
1973 let l = String.length
s in
1974 let rec loop pos n = if pos = l then n else
1975 let m = Char.code
s.[pos] - (if pos = 0 && l > 1 then 96 else 97) in
1976 loop (pos+1) (n*26 + m)
1979 let rec loop n = function
1982 match getopaque l.pageno with
1983 | None
-> loop n rest
1985 let m = getlinkcount
opaque in
1988 let under = getlink
opaque n in
1991 else loop (n-m) rest
1993 loop n state
.layout;
1997 let linknentry text key =
1999 if key >= 32 && key < 127
2005 let text = addchar
text c in
2006 linknact (fun under -> state
.text <- undertext ~nopath
:true under) text;
2010 state
.text <- Printf.sprintf
"invalid char (%d, `%c')" key c;
2014 let textentry text key =
2015 if key land 0xff00 = 0xff00
2017 else TEcont
(text ^ toutf8
key)
2020 let reqlayout angle fitmodel
=
2021 match state
.throttle
with
2023 if nogeomcmds state
.geomcmds
2024 then state
.anchor <- getanchor
();
2025 conf
.angle
<- angle
mod 360;
2028 match state
.mode
with
2029 | LinkNav
_ -> state
.mode
<- View
2034 conf
.fitmodel
<- fitmodel
;
2035 invalidate "reqlayout"
2037 wcmd "reqlayout %d %d %d"
2038 conf
.angle
(FMTE.to_int conf
.fitmodel
) (stateh state
.winh
)
2043 let settrim trimmargins trimfuzz
=
2044 if nogeomcmds state
.geomcmds
2045 then state
.anchor <- getanchor
();
2046 conf
.trimmargins
<- trimmargins
;
2047 conf
.trimfuzz
<- trimfuzz
;
2048 let x0, y0, x1, y1 = trimfuzz
in
2049 invalidate "settrim"
2051 wcmd "settrim %d %d %d %d %d" (btod conf
.trimmargins
) x0 y0 x1 y1);
2056 match state
.throttle
with
2058 let zoom = max
0.0001 zoom in
2059 if zoom <> conf
.zoom
2061 state
.prevzoom
<- (conf
.zoom, state
.x);
2063 reshape state
.winw state
.winh
;
2064 state
.text <- Printf.sprintf
"zoom is now %-5.2f" (zoom *. 100.0);
2067 | Some
(layout, y, started
) ->
2069 match conf
.maxwait
with
2073 let dt = now
() -. started
in
2081 let setcolumns mode columns coverA coverB
=
2082 state
.prevcolumns
<- Some
(conf
.columns
, conf
.zoom);
2086 then impmsg "split mode doesn't work in bird's eye"
2088 conf
.columns
<- Csplit
(-columns
, E.a);
2096 conf
.columns
<- Csingle
E.a;
2101 conf
.columns
<- Cmulti
((columns
, coverA
, coverB
), E.a);
2105 reshape state
.winw state
.winh
;
2108 let resetmstate () =
2109 state
.mstate
<- Mnone
;
2110 Wsi.setcursor
Wsi.CURSOR_INHERIT
;
2113 let enterbirdseye () =
2114 let zoom = float conf
.thumbw
/. float state
.winw
in
2115 let birdseyepageno =
2116 let cy = state
.winh
/ 2 in
2120 let rec fold best
= function
2123 let d = cy - (l.pagedispy + l.pagevh/2)
2124 and dbest
= cy - (best
.pagedispy + best
.pagevh/2) in
2125 if abs
d < abs dbest
2132 state
.mode
<- Birdseye
(
2133 { conf
with zoom = conf
.zoom }, state
.x, birdseyepageno, -1, getanchor
()
2137 conf
.presentation
<- false;
2138 conf
.interpagespace
<- 10;
2139 conf
.hlinks
<- false;
2140 conf
.fitmodel
<- FitPage
;
2142 conf
.maxwait
<- None
;
2144 match conf
.beyecolumns
with
2147 Cmulti
((c, 0, 0), E.a)
2148 | None
-> Csingle
E.a
2152 state
.text <- Printf.sprintf
"birds eye mode on (zoom %3.1f%%)"
2157 reshape state
.winw state
.winh
;
2160 let leavebirdseye (c, leftx
, pageno, _, anchor) goback
=
2162 conf
.zoom <- c.zoom;
2163 conf
.presentation
<- c.presentation
;
2164 conf
.interpagespace
<- c.interpagespace
;
2165 conf
.maxwait
<- c.maxwait
;
2166 conf
.hlinks
<- c.hlinks
;
2167 conf
.fitmodel
<- c.fitmodel
;
2168 conf
.beyecolumns
<- (
2169 match conf
.columns
with
2170 | Cmulti
((c, _, _), _) -> Some
c
2172 | Csplit
_ -> failwith
"leaving bird's eye split mode"
2175 match c.columns
with
2176 | Cmulti
(c, _) -> Cmulti
(c, E.a)
2177 | Csingle
_ -> Csingle
E.a
2178 | Csplit
(c, _) -> Csplit
(c, E.a)
2182 state
.text <- Printf.sprintf
"birds eye mode off (zoom %3.1f%%)"
2185 reshape state
.winw state
.winh
;
2186 state
.anchor <- if goback
then anchor else (pageno, 0.0, 1.0);
2190 let togglebirdseye () =
2191 match state
.mode
with
2192 | Birdseye vals
-> leavebirdseye vals
true
2193 | View
-> enterbirdseye ()
2198 let upbirdseye incr
(conf
, leftx
, pageno, hooverpageno
, anchor) =
2199 let pageno = max
0 (pageno - incr
) in
2200 let rec loop = function
2201 | [] -> gotopage1 pageno 0
2202 | l :: _ when l.pageno = pageno ->
2203 if l.pagedispy >= 0 && l.pagey = 0
2204 then G.postRedisplay "upbirdseye"
2205 else gotopage1 pageno 0
2206 | _ :: rest
-> loop rest
2210 state
.mode
<- Birdseye
(conf
, leftx
, pageno, hooverpageno
, anchor)
2213 let downbirdseye incr
(conf
, leftx
, pageno, hooverpageno
, anchor) =
2214 let pageno = min
(state
.pagecount
- 1) (pageno + incr
) in
2215 state
.mode
<- Birdseye
(conf
, leftx
, pageno, hooverpageno
, anchor);
2216 let rec loop = function
2218 let y, h = getpageyh
pageno in
2219 let dy = (y - state
.y) - (state
.winh
- h - conf
.interpagespace
) in
2221 | l :: _ when l.pageno = pageno ->
2222 if l.pagevh != l.pageh
2223 then gotoy (clamp (l.pageh
- l.pagevh + conf
.interpagespace
))
2224 else G.postRedisplay "downbirdseye"
2225 | _ :: rest
-> loop rest
2231 let optentry mode
_ key =
2232 let btos b = if b then "on" else "off" in
2233 if key >= 32 && key < 127
2235 let c = Char.chr
key in
2239 try conf
.scrollstep
<- int_of_string
s with exc
->
2240 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exc
2242 TEswitch
("scroll step: ", E.s, None
, intentry, ondone, true)
2247 conf
.autoscrollstep
<- boundastep state
.winh
(int_of_string
s);
2248 if state
.autoscroll
<> None
2249 then state
.autoscroll
<- Some conf
.autoscrollstep
2251 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exc
2253 TEswitch
("auto scroll step: ", E.s, None
, intentry, ondone, true)
2258 let n, a, b = multicolumns_of_string
s in
2259 setcolumns mode
n a b;
2261 state
.text <- Printf.sprintf
"bad columns `%s': %s" s @@ exntos exc
2263 TEswitch
("columns: ", E.s, None
, textentry, ondone, true)
2268 let zoom = float (int_of_string
s) /. 100.0 in
2271 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exc
2273 TEswitch
("zoom: ", E.s, None
, intentry, ondone, true)
2278 conf
.thumbw
<- bound
(int_of_string
s) 2 4096;
2280 Printf.sprintf
"thumbnail width is set to %d" conf
.thumbw
;
2281 begin match mode
with
2283 leavebirdseye beye
false;
2290 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exc
2292 TEswitch
("thumbnail width: ", E.s, None
, intentry, ondone, true)
2297 Some
(int_of_string
s)
2300 Printf.sprintf
"bad integer `%s': %s" s @@ exntos exc
;
2303 | Some angle
-> reqlayout angle conf
.fitmodel
2306 TEswitch
("rotation: ", E.s, None
, intentry, ondone, true)
2309 conf
.icase
<- not conf
.icase
;
2310 TEdone
("case insensitive search " ^
(btos conf
.icase
))
2313 conf
.preload <- not conf
.preload;
2315 TEdone
("preload " ^
(btos conf
.preload))
2318 conf
.verbose
<- not conf
.verbose
;
2319 TEdone
("verbose " ^
(btos conf
.verbose
))
2322 conf
.debug
<- not conf
.debug
;
2323 TEdone
("debug " ^
(btos conf
.debug
))
2326 conf
.maxhfit
<- not conf
.maxhfit
;
2327 state
.maxy
<- calcheight
();
2328 TEdone
("maxhfit " ^
(btos conf
.maxhfit
))
2331 conf
.crophack
<- not conf
.crophack
;
2332 TEdone
("crophack " ^
btos conf
.crophack
)
2336 match conf
.maxwait
with
2338 conf
.maxwait
<- Some infinity
;
2339 "always wait for page to complete"
2341 conf
.maxwait
<- None
;
2342 "show placeholder if page is not ready"
2347 conf
.underinfo
<- not conf
.underinfo
;
2348 TEdone
("underinfo " ^
btos conf
.underinfo
)
2351 conf
.savebmarks
<- not conf
.savebmarks
;
2352 TEdone
("persistent bookmarks " ^
btos conf
.savebmarks
)
2358 match state
.layout with
2363 conf
.interpagespace
<- int_of_string
s;
2364 docolumns conf
.columns
;
2365 state
.maxy
<- calcheight
();
2366 let y = getpagey
pageno in
2369 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exc
2371 TEswitch
("vertical margin: ", E.s, None
, intentry, ondone, true)
2375 match conf
.fitmodel
with
2376 | FitProportional
-> FitWidth
2377 | FitWidth
| FitPage
-> FitProportional
2379 reqlayout conf
.angle
fm;
2380 TEdone
("proportional display " ^
btos (fm == FitProportional
))
2383 settrim (not conf
.trimmargins
) conf
.trimfuzz
;
2384 TEdone
("trim margins " ^
btos conf
.trimmargins
)
2387 conf
.invert
<- not conf
.invert
;
2388 TEdone
("invert colors " ^
btos conf
.invert
)
2392 cbput state
.hists
.sel
s;
2395 TEswitch
("selection command: ", E.s, Some
(onhist state
.hists
.sel
),
2396 textentry, ondone, true)
2400 then conf
.pax
<- Some
(ref (0.0, 0, 0))
2401 else conf
.pax
<- None
;
2402 TEdone
("PAX " ^
btos (conf
.pax
!= None
))
2405 state
.text <- Printf.sprintf
"bad option %d `%c'" key c;
2411 class type lvsource
= object
2412 method getitemcount
: int
2413 method getitem
: int -> (string * int)
2414 method hasaction
: int -> bool
2422 method getactive
: int
2423 method getfirst
: int
2425 method getminfo
: (int * int) array
2428 class virtual lvsourcebase
= object
2429 val mutable m_active
= 0
2430 val mutable m_first
= 0
2431 val mutable m_pan
= 0
2432 method getactive
= m_active
2433 method getfirst
= m_first
2434 method getpan
= m_pan
2435 method getminfo
: (int * int) array
= E.a
2438 let textentrykeyboard
2439 key _mask
((c, text, opthist
, onkey
, ondone, cancelonempty
), onleave
) =
2442 if key >= 0xffb0 && key <= 0xffb9
2443 then key - 0xffb0 + 48 else key
2446 state
.mode
<- Textentry
(te
, onleave
);
2448 G.postRedisplay "textentrykeyboard enttext";
2450 let histaction cmd
=
2453 | Some
(action, _) ->
2454 state
.mode
<- Textentry
(
2455 (c, action cmd
, opthist
, onkey
, ondone, cancelonempty
), onleave
2457 G.postRedisplay "textentry histaction"
2461 if emptystr
text && cancelonempty
2464 G.postRedisplay "textentrykeyboard after cancel";
2467 let s = withoutlastutf8
text in
2468 enttext (c, s, opthist
, onkey
, ondone, cancelonempty
)
2470 | @enter
| @kpenter
->
2473 G.postRedisplay "textentrykeyboard after confirm"
2475 | @up
| @kpup
-> histaction HCprev
2476 | @down
| @kpdown
-> histaction HCnext
2477 | @home
| @kphome
-> histaction HCfirst
2478 | @jend
| @kpend
-> histaction HClast
2483 begin match opthist
with
2485 | Some
(_, onhistcancel
) -> onhistcancel
()
2489 G.postRedisplay "textentrykeyboard after cancel2"
2492 enttext (c, E.s, opthist
, onkey
, ondone, cancelonempty
)
2495 | @delete
| @kpdelete
-> ()
2498 && key land 0xff00 != 0xff00 (* keyboard *)
2499 && key land 0xfe00 != 0xfe00 (* xkb *)
2500 && key land 0xfd00 != 0xfd00 (* 3270 *)
2502 begin match onkey
text key with
2506 G.postRedisplay "textentrykeyboard after confirm2";
2509 enttext (c, text, opthist
, onkey
, ondone, cancelonempty
);
2513 G.postRedisplay "textentrykeyboard after cancel3"
2516 state
.mode
<- Textentry
(te
, onleave
);
2517 G.postRedisplay "textentrykeyboard switch";
2521 vlog "unhandled key %s" (Wsi.keyname
key)
2524 let firstof first active
=
2525 if first
> active
|| abs
(first
- active
) > fstate
.maxrows
- 1
2526 then max
0 (active
- (fstate
.maxrows
/2))
2530 let calcfirst first active
=
2533 let rows = active
- first
in
2534 if rows > fstate
.maxrows
then active
- fstate
.maxrows
else first
2538 let scrollph y maxy
=
2539 let sh = float (maxy
+ state
.winh
) /. float state
.winh
in
2540 let sh = float state
.winh
/. sh in
2541 let sh = max
sh (float conf
.scrollh
) in
2543 let percent = float y /. float maxy
in
2544 let position = (float state
.winh
-. sh) *. percent in
2547 if position +. sh > float state
.winh
2548 then float state
.winh
-. sh
2554 let coe s = (s :> uioh
);;
2556 class listview ~zebra ~helpmode ~
(source
:lvsource
) ~trusted ~modehash
=
2558 val m_pan
= source#getpan
2559 val m_first
= source#getfirst
2560 val m_active
= source#getactive
2562 val m_prev_uioh
= state
.uioh
2564 method private elemunder
y =
2568 let n = y / (fstate
.fontsize
+1) in
2569 if m_first
+ n < source#getitemcount
2571 if source#hasaction
(m_first
+ n)
2572 then Some
(m_first
+ n)
2579 GlFunc.blend_func ~src
:`src_alpha ~dst
:`one_minus_src_alpha
;
2580 GlDraw.color (0., 0., 0.) ~alpha
:0.85;
2581 filledrect 0. 0. (float state
.winw
) (float state
.winh
);
2582 GlDraw.color (1., 1., 1.);
2583 Gl.enable `texture_2d
;
2584 let fs = fstate
.fontsize
in
2586 let hw = (wadjsb () + xadjsb () + state
.winw
)/3 in
2587 let ww = fstate
.wwidth
in
2588 let tabw = 17.0*.ww in
2589 let itemcount = source#getitemcount
in
2590 let minfo = source#getminfo
in
2593 then float (xadjsb ()), float (state
.winw
- 1)
2594 else 0.0, float (state
.winw
- conf
.scrollbw
- 1)
2596 let xadj = xadjsb () in
2598 if (row - m_first
) > fstate
.maxrows
2601 if row >= 0 && row < itemcount
2603 let (s, level
) = source#getitem
row in
2604 let y = (row - m_first
) * nfs in
2606 (if conf
.leftscroll
then float xadj else 5.0)
2607 +. (float (level
+ m_pan
)) *. ww in
2610 (let c = if row land 1 = 0 then 1.0 else 0.92 in (c,c,c));
2614 Gl.disable `texture_2d
;
2615 let alpha = if source#hasaction
row then 0.9 else 0.3 in
2616 GlDraw.color (1., 1., 1.) ~
alpha;
2617 linerect (x0 +. 1.) (float (y + 1)) (x1) (float (y + fs + 3));
2618 Gl.enable `texture_2d
;
2621 if zebra
&& row land 1 = 1
2625 GlDraw.color (c,c,c);
2626 let drawtabularstring s =
2628 let x'
= truncate
(x0 +. x) in
2629 let pos = nindex
s '
\000'
in
2631 then drawstring1 fs x'
(y+nfs) s
2633 let s1 = String.sub
s 0 pos
2634 and s2
= String.sub
s (pos+1) (String.length
s - pos - 1) in
2639 let s'
= withoutlastutf8
s in
2640 let s = s' ^
"@Uellipsis" in
2641 let w = measurestr
fs s in
2642 if float x'
+. w +. ww < float (hw + x'
)
2647 if float x'
+. ww +. measurestr
fs s1 > float (hw + x'
)
2651 ignore
(drawstring1 fs x'
(y+nfs) s1);
2652 drawstring1 fs (hw + x'
) (y+nfs) s2
2656 let x = if helpmode
&& row > 0 then x +. ww else x in
2657 let tabpos = nindex
s '
\t'
in
2660 let len = String.length
s - tabpos - 1 in
2661 let s1 = String.sub
s 0 tabpos
2662 and s2
= String.sub
s (tabpos + 1) len in
2663 let nx = drawstr x s1 in
2665 let x = x +. (max
tabw sw) in
2668 let len = String.length
s - 2 in
2669 if len > 0 && s.[0] = '
\xc2'
&& s.[1] = '
\xb7'
2671 let s = String.sub
s 2 len in
2672 let x = if not helpmode
then x +. ww else x in
2673 GlDraw.color (1.2, 1.2, 1.2);
2674 let vinc = drawstring1 (fs+fs/4)
2675 (truncate
(x -. ww)) (y+nfs) s in
2676 GlDraw.color (1., 1., 1.);
2677 vinc +. (float fs *. 0.8)
2683 ignore
(drawtabularstring s);
2689 GlDraw.color (1.0, 1.0, 1.0) ~
alpha:0.5;
2690 let xadj = float (xadjsb () + 5) in
2692 if (row - m_first
) > fstate
.maxrows
2695 if row >= 0 && row < itemcount
2697 let (s, level
) = source#getitem
row in
2698 let pos0 = nindex
s '
\000'
in
2699 let y = (row - m_first
) * nfs in
2700 let x = float (level
+ m_pan
) *. ww in
2701 let (first
, last
) = minfo.(row) in
2703 if pos0 > 0 && first
> pos0
2704 then String.sub
s (pos0+1) (first
-pos0-1)
2705 else String.sub
s 0 first
2707 let suffix = String.sub
s first
(last
- first
) in
2708 let w1 = measurestr fstate
.fontsize
prefix in
2709 let w2 = measurestr fstate
.fontsize
suffix in
2710 let x = x +. if conf
.leftscroll
then xadj else 5.0 in
2711 let x = if pos0 > 0 && first
> pos0 then x +. float hw else x in
2713 and y0 = float (y+2) in
2715 and y1 = float (y+fs+3) in
2716 filledrect x0 y0 x1 y1;
2721 Gl.disable `texture_2d
;
2722 if Array.length
minfo > 0 then loop m_first
;
2725 method updownlevel incr
=
2726 let len = source#getitemcount
in
2728 if m_active
>= 0 && m_active
< len
2729 then snd
(source#getitem m_active
)
2733 if i
= len then i
-1 else if i
= -1 then 0 else
2734 let _, l = source#getitem i
in
2735 if l != curlevel then i
else flow (i
+incr
)
2737 let active = flow m_active
in
2738 let first = calcfirst m_first
active in
2739 G.postRedisplay "outline updownlevel";
2740 {< m_active
= active; m_first
= first >}
2742 method private key1
key mask
=
2743 let set1 active first qsearch
=
2744 coe {< m_active
= active; m_first
= first; m_qsearch
= qsearch
>}
2746 let search active pattern incr
=
2747 let active = if active = -1 then m_first
else active in
2750 if n >= 0 && n < source#getitemcount
2752 let s, _ = source#getitem
n in
2753 match Str.search_forward re
s 0 with
2754 | (exception Not_found
) -> loop (n + incr
)
2761 Str.regexp_case_fold pattern
|> dosearch
2763 let itemcount = source#getitemcount
in
2764 let find start incr
=
2766 if i
= -1 || i
= itemcount
2769 if source#hasaction i
2771 else find (i
+ incr
)
2776 let set active first =
2777 let first = bound
first 0 (itemcount - fstate
.maxrows
) in
2779 coe {< m_active
= active; m_first
= first; m_qsearch
= E.s >}
2782 let isvisible first n = n >= first && n - first <= fstate
.maxrows
in
2784 let incr1 = if incr
> 0 then 1 else -1 in
2785 if isvisible m_first m_active
2788 let next = m_active
+ incr
in
2790 if next < 0 || next >= itemcount
2792 else find next incr1
2794 if abs
(m_active
- next) > fstate
.maxrows
2800 let first = m_first
+ incr
in
2801 let first = bound
first 0 (itemcount - fstate
.maxrows
) in
2803 let next = m_active
+ incr
in
2804 let next = bound
next 0 (itemcount - 1) in
2811 if isvisible first next
2818 let first = min
next m_first
in
2820 if abs
(next - first) > fstate
.maxrows
2826 let first = m_first
+ incr
in
2827 let first = bound
first 0 (itemcount - 1) in
2829 let next = m_active
+ incr
in
2830 let next = bound
next 0 (itemcount - 1) in
2831 let next = find next incr1 in
2833 if next = -1 || abs
(m_active
- first) > fstate
.maxrows
2835 let active = if m_active
= -1 then next else m_active
in
2840 if isvisible first active
2846 G.postRedisplay "listview navigate";
2850 | (@r
|@s) when Wsi.withctrl mask
->
2851 let incr = if key = @r
then -1 else 1 in
2853 match search (m_active
+ incr) m_qsearch
incr with
2855 state
.text <- m_qsearch ^
" [not found]";
2858 state
.text <- m_qsearch
;
2859 active, firstof m_first
active
2861 G.postRedisplay "listview ctrl-r/s";
2862 set1 active first m_qsearch
;
2864 | @insert
when Wsi.withctrl mask
->
2865 if m_active
>= 0 && m_active
< source#getitemcount
2867 let s, _ = source#getitem m_active
in
2873 if emptystr m_qsearch
2876 let qsearch = withoutlastutf8 m_qsearch
in
2880 G.postRedisplay "listview empty qsearch";
2881 set1 m_active m_first
E.s;
2885 match search m_active
qsearch ~
-1 with
2887 state
.text <- qsearch ^
" [not found]";
2890 state
.text <- qsearch;
2891 active, firstof m_first
active
2893 G.postRedisplay "listview backspace qsearch";
2894 set1 active first qsearch
2897 | key when (key != 0 && key land 0xff00 != 0xff00) ->
2898 let pattern = m_qsearch ^ toutf8
key in
2900 match search m_active
pattern 1 with
2902 state
.text <- pattern ^
" [not found]";
2905 state
.text <- pattern;
2906 active, firstof m_first
active
2908 G.postRedisplay "listview qsearch add";
2909 set1 active first pattern;
2913 if emptystr m_qsearch
2915 G.postRedisplay "list view escape";
2916 let mx, my
= state
.mpos
in
2920 source#exit ~uioh
:(coe self
)
2921 ~cancel
:true ~
active:m_active ~
first:m_first ~pan
:m_pan
2923 | None
-> m_prev_uioh
2928 G.postRedisplay "list view kill qsearch";
2929 coe {< m_qsearch
= E.s >}
2932 | @enter
| @kpenter
->
2934 let self = {< m_qsearch
= E.s >} in
2936 G.postRedisplay "listview enter";
2937 if m_active
>= 0 && m_active
< source#getitemcount
2939 source#exit ~uioh
:(coe self) ~cancel
:false
2940 ~
active:m_active ~
first:m_first ~pan
:m_pan
;
2943 source#exit ~uioh
:(coe self) ~cancel
:true
2944 ~
active:m_active ~
first:m_first ~pan
:m_pan
;
2947 begin match opt with
2948 | None
-> m_prev_uioh
2952 | @delete
| @kpdelete
->
2955 | @up
| @kpup
-> navigate ~
-1
2956 | @down
| @kpdown
-> navigate 1
2957 | @prior
| @kpprior
-> navigate ~
-(fstate
.maxrows
)
2958 | @next | @kpnext
-> navigate fstate
.maxrows
2960 | @right
| @kpright
->
2962 G.postRedisplay "listview right";
2963 coe {< m_pan
= m_pan
- 1 >}
2965 | @left | @kpleft
->
2967 G.postRedisplay "listview left";
2968 coe {< m_pan
= m_pan
+ 1 >}
2970 | @home
| @kphome
->
2971 let active = find 0 1 in
2972 G.postRedisplay "listview home";
2976 let first = max
0 (itemcount - fstate
.maxrows
) in
2977 let active = find (itemcount - 1) ~
-1 in
2978 G.postRedisplay "listview end";
2981 | key when (key = 0 || key land 0xff00 = 0xff00) ->
2985 dolog
"listview unknown key %#x" key; coe self
2987 method key key mask
=
2988 match state
.mode
with
2989 | Textentry te
-> textentrykeyboard key mask te
; coe self
2992 | LinkNav
_ -> self#key1
key mask
2994 method button button down
x y _ =
2997 | 1 when vscrollhit x ->
2998 G.postRedisplay "listview scroll";
3001 let _, position, sh = self#
scrollph in
3002 if y > truncate
position && y < truncate
(position +. sh)
3004 state
.mstate
<- Mscrolly
;
3008 let s = float (max
0 (y - conf
.scrollh
)) /. float state
.winh
in
3009 let first = truncate
(s *. float source#getitemcount
) in
3010 let first = min source#getitemcount
first in
3011 Some
(coe {< m_first
= first; m_active
= first >})
3013 state
.mstate
<- Mnone
;
3017 begin match self#elemunder
y with
3019 G.postRedisplay "listview click";
3020 source#exit ~uioh
:(coe {< m_active
= n >})
3021 ~cancel
:false ~
active:n ~
first:m_first ~pan
:m_pan
3025 | n when (n == 4 || n == 5) && not down
->
3026 let len = source#getitemcount
in
3028 if n = 5 && m_first
+ fstate
.maxrows
>= len
3032 let first = m_first
+ (if n == 4 then -1 else 1) in
3033 bound
first 0 (len - 1)
3035 G.postRedisplay "listview wheel";
3036 Some
(coe {< m_first
= first >})
3037 | n when (n = 6 || n = 7) && not down
->
3038 let inc = if n = 7 then -1 else 1 in
3039 G.postRedisplay "listview hwheel";
3040 Some
(coe {< m_pan
= m_pan
+ inc >})
3045 | None
-> m_prev_uioh
3048 method multiclick
_ x y = self#button
1 true x y
3051 match state
.mstate
with
3053 let s = float (max
0 (y - conf
.scrollh
)) /. float state
.winh
in
3054 let first = truncate
(s *. float source#getitemcount
) in
3055 let first = min source#getitemcount
first in
3056 G.postRedisplay "listview motion";
3057 coe {< m_first
= first; m_active
= first >}
3065 method pmotion
x y =
3066 if x < state
.winw
- conf
.scrollbw
3069 match self#elemunder
y with
3070 | None
-> Wsi.setcursor
Wsi.CURSOR_INHERIT
; m_active
3071 | Some
n -> Wsi.setcursor
Wsi.CURSOR_INFO
; n
3075 then (G.postRedisplay "listview pmotion"; {< m_active
= n >})
3080 Wsi.setcursor
Wsi.CURSOR_INHERIT
;
3084 method infochanged
_ = ()
3086 method scrollpw
= (0, 0.0, 0.0)
3088 let nfs = fstate
.fontsize
+ 1 in
3089 let y = m_first
* nfs in
3090 let itemcount = source#getitemcount
in
3091 let maxi = max
0 (itemcount - fstate
.maxrows
) in
3092 let maxy = maxi * nfs in
3093 let p, h = scrollph y maxy in
3096 method modehash
= modehash
3097 method eformsgs
= false
3098 method alwaysscrolly
= true
3101 class outlinelistview ~zebra ~source
=
3102 let settext autonarrow
s =
3105 let ss = source#statestr
in
3109 else "{" ^
ss ^
"} [" ^
s ^
"]"
3110 else state
.text <- s
3116 ~source
:(source
:> lvsource
)
3118 ~modehash
:(findkeyhash conf
"outline")
3121 val m_autonarrow
= false
3123 method! key key mask
=
3125 if emptystr state
.text
3127 else fstate
.maxrows - 2
3129 let calcfirst first active =
3132 let rows = active - first in
3133 if rows > maxrows then active - maxrows else first
3137 let active = m_active
+ incr in
3138 let active = bound
active 0 (source#getitemcount
- 1) in
3139 let first = calcfirst m_first
active in
3140 G.postRedisplay "outline navigate";
3141 coe {< m_active
= active; m_first
= first >}
3143 let navscroll first =
3145 let dist = m_active
- first in
3151 else first + maxrows
3154 G.postRedisplay "outline navscroll";
3155 coe {< m_first
= first; m_active
= active >}
3157 let ctrl = Wsi.withctrl mask
in
3162 then (source#denarrow
; E.s)
3164 let pattern = source#renarrow
in
3165 if nonemptystr m_qsearch
3166 then (source#narrow m_qsearch
; m_qsearch
)
3170 settext (not m_autonarrow
) text;
3171 G.postRedisplay "toggle auto narrowing";
3172 coe {< m_first
= 0; m_active
= 0; m_autonarrow
= not m_autonarrow
>}
3174 | @slash
when emptystr m_qsearch
&& not m_autonarrow
->
3176 G.postRedisplay "toggle auto narrowing";
3177 coe {< m_first
= 0; m_active
= 0; m_autonarrow
= true >}
3180 source#narrow m_qsearch
;
3182 then source#add_narrow_pattern m_qsearch
;
3183 G.postRedisplay "outline ctrl-n";
3184 coe {< m_first
= 0; m_active
= 0 >}
3187 let active = source#calcactive
(getanchor
()) in
3188 let first = firstof m_first
active in
3189 G.postRedisplay "outline ctrl-s";
3190 coe {< m_first
= first; m_active
= active >}
3193 G.postRedisplay "outline ctrl-u";
3194 if m_autonarrow
&& nonemptystr m_qsearch
3196 ignore
(source#renarrow
);
3197 settext m_autonarrow
E.s;
3198 coe {< m_first
= 0; m_active
= 0; m_qsearch
= E.s >}
3201 source#del_narrow_pattern
;
3202 let pattern = source#renarrow
in
3204 if emptystr
pattern then E.s else "Narrowed to " ^
pattern
3206 settext m_autonarrow
text;
3207 coe {< m_first
= 0; m_active
= 0; m_qsearch
= E.s >}
3211 let first = max
0 (m_active
- (fstate
.maxrows / 2)) in
3212 G.postRedisplay "outline ctrl-l";
3213 coe {< m_first
= first >}
3215 | @tab
when m_autonarrow
->
3216 if nonemptystr m_qsearch
3218 G.postRedisplay "outline list view tab";
3219 source#add_narrow_pattern m_qsearch
;
3221 coe {< m_qsearch
= E.s >}
3225 | @escape
when m_autonarrow
->
3226 if nonemptystr m_qsearch
3227 then source#add_narrow_pattern m_qsearch
;
3230 | @enter
| @kpenter
when m_autonarrow
->
3231 if nonemptystr m_qsearch
3232 then source#add_narrow_pattern m_qsearch
;
3235 | key when m_autonarrow
&& (key != 0 && key land 0xff00 != 0xff00) ->
3236 let pattern = m_qsearch ^ toutf8
key in
3237 G.postRedisplay "outlinelistview autonarrow add";
3238 source#narrow
pattern;
3239 settext true pattern;
3240 coe {< m_first
= 0; m_active
= 0; m_qsearch
= pattern >}
3242 | key when m_autonarrow
&& key = @backspace
->
3243 if emptystr m_qsearch
3246 let pattern = withoutlastutf8 m_qsearch
in
3247 G.postRedisplay "outlinelistview autonarrow backspace";
3248 ignore
(source#renarrow
);
3249 source#narrow
pattern;
3250 settext true pattern;
3251 coe {< m_first
= 0; m_active
= 0; m_qsearch
= pattern >}
3253 | @up
| @kpup
when ctrl ->
3254 navscroll (max
0 (m_first
- 1))
3256 | @down
| @kpdown
when ctrl ->
3257 navscroll (min
(source#getitemcount
- 1) (m_first
+ 1))
3259 | @up
| @kpup
-> navigate ~
-1
3260 | @down
| @kpdown
-> navigate 1
3261 | @prior
| @kpprior
-> navigate ~
-(fstate
.maxrows)
3262 | @next | @kpnext
-> navigate fstate
.maxrows
3264 | @right
| @kpright
->
3268 G.postRedisplay "outline ctrl right";
3269 {< m_pan
= m_pan
+ 1 >}
3271 else self#updownlevel
1
3275 | @left | @kpleft
->
3279 G.postRedisplay "outline ctrl left";
3280 {< m_pan
= m_pan
- 1 >}
3282 else self#updownlevel ~
-1
3286 | @home
| @kphome
->
3287 G.postRedisplay "outline home";
3288 coe {< m_first
= 0; m_active
= 0 >}
3291 let active = source#getitemcount
- 1 in
3292 let first = max
0 (active - fstate
.maxrows) in
3293 G.postRedisplay "outline end";
3294 coe {< m_active
= active; m_first
= first >}
3296 | _ -> super#
key key mask
3299 let genhistoutlines () =
3301 |> List.sort
(fun (_, c1
, _, _, _, _) (_, c2
, _, _, _, _) ->
3302 compare c2
.lastvisit c1
.lastvisit
)
3304 (fun ((path
, c, _, _, _, origin
) as hist
) ->
3305 let path = if nonemptystr origin
then origin
else path in
3306 let base = mbtoutf8
@@ Filename.basename
path in
3307 (base ^
"\000" ^
c.title
, 1, Ohistory hist
)
3312 let gotohist (path, c, bookmarks
, x, anchor, origin
) =
3313 Config.save
leavebirdseye;
3314 state
.anchor <- anchor;
3315 state
.bookmarks
<- bookmarks
;
3316 state
.origin
<- origin
;
3319 let x0, y0, x1, y1 = conf
.trimfuzz
in
3320 wcmd "trimset %d %d %d %d %d" (btod conf
.trimmargins
) x0 y0 x1 y1;
3321 reshape ~firsttime
:true state
.winw state
.winh
;
3322 opendoc path origin
;
3326 let makecheckers () =
3327 (* Based on lablGL-1.04/LablGlut/examples/lablGL/checker.ml which had
3329 converted by Issac Trotts. July 25, 2002 *)
3330 let image = GlPix.create `ubyte ~format
:`luminance ~width
:2 ~height
:2 in
3331 Raw.sets_string
(GlPix.to_raw
image) ~
pos:0 "\255\200\200\255";
3332 let id = GlTex.gen_texture
() in
3333 GlTex.bind_texture ~target
:`texture_2d
id;
3334 GlPix.store
(`unpack_alignment
1);
3335 GlTex.image2d
image;
3336 List.iter
(GlTex.parameter ~target
:`texture_2d
)
3337 [ `mag_filter `nearest
; `min_filter `nearest
];
3341 let setcheckers enabled
=
3342 match state
.checkerstexid
with
3344 if enabled
then state
.checkerstexid
<- Some
(makecheckers ())
3346 | Some checkerstexid
->
3349 GlTex.delete_texture checkerstexid
;
3350 state
.checkerstexid
<- None
;
3354 let describe_location () =
3355 let fn = page_of_y state
.y in
3356 let ln = page_of_y
(state
.y + state
.winh
- hscrollh () - 1) in
3357 let maxy = state
.maxy - (if conf
.maxhfit
then state
.winh
else 0) in
3361 else (100. *. (float state
.y /. float maxy))
3365 Printf.sprintf
"page %d of %d [%.2f%%]"
3366 (fn+1) state
.pagecount
percent
3369 "pages %d-%d of %d [%.2f%%]"
3370 (fn+1) (ln+1) state
.pagecount
percent
3373 let setpresentationmode v
=
3374 let n = page_of_y state
.y in
3375 state
.anchor <- (n, 0.0, 1.0);
3376 conf
.presentation
<- v
;
3377 if conf
.fitmodel
= FitPage
3378 then reqlayout conf
.angle conf
.fitmodel
;
3383 let btos b = if b then "@Uradical" else E.s in
3384 let showextended = ref false in
3385 let leave mode
_ = state
.mode
<- mode
in
3388 val mutable m_l
= []
3389 val mutable m_a
= E.a
3390 val mutable m_prev_uioh
= nouioh
3391 val mutable m_prev_mode
= View
3393 inherit lvsourcebase
3395 method reset prev_mode prev_uioh
=
3396 m_a
<- Array.of_list
(List.rev m_l
);
3398 m_prev_mode
<- prev_mode
;
3399 m_prev_uioh
<- prev_uioh
;
3401 method int name get
set =
3403 (name
, `
int get
, 1, Action
(
3406 try set (int_of_string
s)
3408 state
.text <- Printf.sprintf
"bad integer `%s': %s"
3412 let te = name ^
": ", E.s, None
, intentry, ondone, true in
3413 state
.mode
<- Textentry
(te, leave m_prev_mode
);
3417 method int_with_suffix name get
set =
3419 (name
, `intws get
, 1, Action
(
3422 try set (int_of_string_with_suffix
s)
3424 state
.text <- Printf.sprintf
"bad integer `%s': %s"
3429 name ^
": ", E.s, None
, intentry_with_suffix, ondone, true
3431 state
.mode
<- Textentry
(te, leave m_prev_mode
);
3435 method bool ?
(offset
=1) ?
(btos=btos) name get
set =
3437 (name
, `
bool (btos, get
), offset
, Action
(
3444 method color name get
set =
3446 (name
, `
color get
, 1, Action
(
3448 let invalid = (nan
, nan
, nan
) in
3451 try color_of_string
s
3453 state
.text <- Printf.sprintf
"bad color `%s': %s"
3460 let te = name ^
": ", E.s, None
, textentry, ondone, true in
3461 state
.text <- color_to_string
(get
());
3462 state
.mode
<- Textentry
(te, leave m_prev_mode
);
3466 method string name get
set =
3468 (name
, `
string get
, 1, Action
(
3470 let ondone s = set s in
3471 let te = name ^
": ", E.s, None
, textentry, ondone, true in
3472 state
.mode
<- Textentry
(te, leave m_prev_mode
);
3476 method colorspace name get
set =
3478 (name
, `
string get
, 1, Action
(
3482 inherit lvsourcebase
3485 m_active
<- CSTE.to_int conf
.colorspace
;
3488 method getitemcount
=
3489 Array.length
CSTE.names
3492 method exit ~uioh ~cancel ~
active ~
first ~pan
=
3493 ignore
(uioh
, first, pan
);
3494 if not cancel
then set active;
3496 method hasaction
_ = true
3500 let modehash = findkeyhash conf
"info" in
3501 coe (new listview ~zebra
:false ~helpmode
:false
3502 ~
source ~trusted
:true ~
modehash)
3505 method paxmark name get
set =
3507 (name
, `
string get
, 1, Action
(
3511 inherit lvsourcebase
3514 m_active
<- MTE.to_int conf
.paxmark
;
3517 method getitemcount
= Array.length
MTE.names
3518 method getitem
n = (MTE.names
.(n), 0)
3519 method exit ~uioh ~cancel ~
active ~
first ~pan
=
3520 ignore
(uioh
, first, pan
);
3521 if not cancel
then set active;
3523 method hasaction
_ = true
3527 let modehash = findkeyhash conf
"info" in
3528 coe (new listview ~zebra
:false ~helpmode
:false
3529 ~
source ~trusted
:true ~
modehash)
3532 method fitmodel name get
set =
3534 (name
, `
string get
, 1, Action
(
3538 inherit lvsourcebase
3541 m_active
<- FMTE.to_int conf
.fitmodel
;
3544 method getitemcount
= Array.length
FMTE.names
3545 method getitem
n = (FMTE.names
.(n), 0)
3546 method exit ~uioh ~cancel ~
active ~
first ~pan
=
3547 ignore
(uioh
, first, pan
);
3548 if not cancel
then set active;
3550 method hasaction
_ = true
3554 let modehash = findkeyhash conf
"info" in
3555 coe (new listview ~zebra
:false ~helpmode
:false
3556 ~
source ~trusted
:true ~
modehash)
3559 method caption
s offset
=
3560 m_l
<- (s, `empty
, offset
, Noaction
) :: m_l
3562 method caption2
s f offset
=
3563 m_l
<- (s, `
string f, offset
, Noaction
) :: m_l
3565 method getitemcount
= Array.length m_a
3568 let tostr = function
3569 | `
int f -> string_of_int
(f ())
3570 | `intws
f -> string_with_suffix_of_int
(f ())
3572 | `
color f -> color_to_string
(f ())
3573 | `
bool (btos, f) -> btos (f ())
3576 let name, t
, offset
, _ = m_a
.(n) in
3577 ((let s = tostr t
in
3579 then Printf.sprintf
"%s\t%s" name s
3583 method exit ~uioh ~cancel ~
active ~
first ~pan
=
3588 match m_a
.(active) with
3589 | _, _, _, Action
f -> f uioh
3590 | _, _, _, Noaction
-> uioh
3601 method hasaction
n =
3603 | _, _, _, Action
_ -> true
3604 | _, _, _, Noaction
-> false
3606 initializer m_active
<- 1
3609 let rec fillsrc prevmode prevuioh
=
3610 let sep () = src#caption
E.s 0 in
3611 let colorp name get
set =
3613 (fun () -> color_to_string
(get
()))
3616 let c = color_of_string
v in
3619 state
.text <- Printf.sprintf
"bad color `%s': %s" v @@ exntos exn
3622 let oldmode = state
.mode
in
3623 let birdseye = isbirdseye state
.mode
in
3625 src#caption
(if birdseye then "Setup (Bird's eye)" else "Setup") 0;
3627 src#
bool "presentation mode"
3628 (fun () -> conf
.presentation
)
3629 (fun v -> setpresentationmode v);
3631 src#
bool "ignore case in searches"
3632 (fun () -> conf
.icase
)
3633 (fun v -> conf
.icase
<- v);
3636 (fun () -> conf
.preload)
3637 (fun v -> conf
.preload <- v);
3639 src#
bool "highlight links"
3640 (fun () -> conf
.hlinks
)
3641 (fun v -> conf
.hlinks
<- v);
3643 src#
bool "under info"
3644 (fun () -> conf
.underinfo
)
3645 (fun v -> conf
.underinfo
<- v);
3647 src#
bool "persistent bookmarks"
3648 (fun () -> conf
.savebmarks
)
3649 (fun v -> conf
.savebmarks
<- v);
3651 src#fitmodel
"fit model"
3652 (fun () -> FMTE.to_string conf
.fitmodel
)
3653 (fun v -> reqlayout conf
.angle
(FMTE.of_int
v));
3655 src#
bool "trim margins"
3656 (fun () -> conf
.trimmargins
)
3657 (fun v -> settrim v conf
.trimfuzz
; fillsrc prevmode prevuioh
);
3659 src#
bool "persistent location"
3660 (fun () -> conf
.jumpback
)
3661 (fun v -> conf
.jumpback
<- v);
3664 src#
int "inter-page space"
3665 (fun () -> conf
.interpagespace
)
3667 conf
.interpagespace
<- n;
3668 docolumns conf
.columns
;
3670 match state
.layout with
3675 state
.maxy <- calcheight
();
3676 let y = getpagey
pageno in
3681 (fun () -> conf
.pagebias
)
3682 (fun v -> conf
.pagebias
<- v);
3684 src#
int "scroll step"
3685 (fun () -> conf
.scrollstep
)
3686 (fun n -> conf
.scrollstep
<- n);
3688 src#
int "horizontal scroll step"
3689 (fun () -> conf
.hscrollstep
)
3690 (fun v -> conf
.hscrollstep
<- v);
3692 src#
int "auto scroll step"
3694 match state
.autoscroll
with
3696 | _ -> conf
.autoscrollstep
)
3698 let n = boundastep state
.winh
n in
3699 if state
.autoscroll
<> None
3700 then state
.autoscroll
<- Some
n;
3701 conf
.autoscrollstep
<- n);
3704 (fun () -> truncate
(conf
.zoom *. 100.))
3705 (fun v -> setzoom ((float v) /. 100.));
3708 (fun () -> conf
.angle
)
3709 (fun v -> reqlayout v conf
.fitmodel
);
3711 src#
int "scroll bar width"
3712 (fun () -> conf
.scrollbw
)
3715 reshape state
.winw state
.winh
;
3718 src#
int "scroll handle height"
3719 (fun () -> conf
.scrollh
)
3720 (fun v -> conf
.scrollh
<- v;);
3722 src#
int "thumbnail width"
3723 (fun () -> conf
.thumbw
)
3725 conf
.thumbw
<- min
4096 v;
3728 leavebirdseye beye
false;
3735 let mode = state
.mode in
3736 src#
string "columns"
3738 match conf
.columns
with
3740 | Cmulti
(multi
, _) -> multicolumns_to_string multi
3741 | Csplit
(count
, _) -> "-" ^ string_of_int count
3744 let n, a, b = multicolumns_of_string
v in
3745 setcolumns mode n a b);
3748 src#caption
"Pixmap cache" 0;
3749 src#int_with_suffix
"size (advisory)"
3750 (fun () -> conf
.memlimit
)
3751 (fun v -> conf
.memlimit
<- v);
3754 (fun () -> Printf.sprintf
"%s bytes, %d tiles"
3755 (string_with_suffix_of_int state
.memused
)
3756 (Hashtbl.length state
.tilemap
)) 1;
3759 src#caption
"Layout" 0;
3760 src#caption2
"Dimension"
3762 Printf.sprintf
"%dx%d (virtual %dx%d)"
3763 state
.winw state
.winh
3768 src#caption2
"Position" (fun () ->
3769 Printf.sprintf
"%dx%d" state
.x state
.y
3772 src#caption2
"Position" (fun () -> describe_location ()) 1
3776 src#
bool ~offset
:0 ~
btos:(fun v -> if v then "(on)" else "(off)")
3777 "Save these parameters as global defaults at exit"
3778 (fun () -> conf
.bedefault
)
3779 (fun v -> conf
.bedefault
<- v)
3783 let btos b = if b then "@Ulguillemet" else "@Urguillemet" in
3784 src#
bool ~offset
:0 ~
btos "Extended parameters"
3785 (fun () -> !showextended)
3786 (fun v -> showextended := v; fillsrc prevmode prevuioh
);
3790 (fun () -> conf
.checkers
)
3791 (fun v -> conf
.checkers
<- v; setcheckers v);
3792 src#
bool "update cursor"
3793 (fun () -> conf
.updatecurs
)
3794 (fun v -> conf
.updatecurs
<- v);
3795 src#
bool "scroll-bar on the left"
3796 (fun () -> conf
.leftscroll
)
3797 (fun v -> conf
.leftscroll
<- v);
3799 (fun () -> conf
.verbose
)
3800 (fun v -> conf
.verbose
<- v);
3801 src#
bool "invert colors"
3802 (fun () -> conf
.invert
)
3803 (fun v -> conf
.invert
<- v);
3805 (fun () -> conf
.maxhfit
)
3806 (fun v -> conf
.maxhfit
<- v);
3808 (fun () -> conf
.pax
!= None
)
3811 then conf
.pax
<- Some
(ref (now
(), 0, 0))
3812 else conf
.pax
<- None
);
3813 src#
string "uri launcher"
3814 (fun () -> conf
.urilauncher
)
3815 (fun v -> conf
.urilauncher
<- v);
3816 src#
string "path launcher"
3817 (fun () -> conf
.pathlauncher
)
3818 (fun v -> conf
.pathlauncher
<- v);
3819 src#
string "tile size"
3820 (fun () -> Printf.sprintf
"%dx%d" conf
.tilew conf
.tileh
)
3823 let w, h = Scanf.sscanf
v "%dx%d" (fun w h -> w, h) in
3824 conf
.tilew
<- max
64 w;
3825 conf
.tileh
<- max
64 h;
3828 state
.text <- Printf.sprintf
"bad tile size `%s': %s"
3831 src#
int "texture count"
3832 (fun () -> conf
.texcount
)
3835 then conf
.texcount
<- v
3836 else impmsg "failed to set texture count please retry later"
3838 src#
int "slice height"
3839 (fun () -> conf
.sliceheight
)
3841 conf
.sliceheight
<- v;
3842 wcmd "sliceh %d" conf
.sliceheight
;
3844 src#
int "anti-aliasing level"
3845 (fun () -> conf
.aalevel
)
3847 conf
.aalevel
<- bound
v 0 8;
3848 state
.anchor <- getanchor
();
3849 opendoc state
.path state
.password;
3851 src#
string "page scroll scaling factor"
3852 (fun () -> string_of_float conf
.pgscale)
3855 let s = float_of_string
v in
3858 state
.text <- Printf.sprintf
3859 "bad page scroll scaling factor `%s': %s" v @@ exntos exn
3862 src#
int "ui font size"
3863 (fun () -> fstate
.fontsize
)
3864 (fun v -> setfontsize (bound
v 5 100));
3865 src#
int "hint font size"
3866 (fun () -> conf
.hfsize
)
3867 (fun v -> conf
.hfsize
<- bound
v 5 100);
3868 colorp "background color"
3869 (fun () -> conf
.bgcolor
)
3870 (fun v -> conf
.bgcolor
<- v);
3871 src#
bool "crop hack"
3872 (fun () -> conf
.crophack
)
3873 (fun v -> conf
.crophack
<- v);
3874 src#
string "trim fuzz"
3875 (fun () -> irect_to_string conf
.trimfuzz
)
3878 conf
.trimfuzz
<- irect_of_string
v;
3880 then settrim true conf
.trimfuzz
;
3882 state
.text <- Printf.sprintf
"bad irect `%s': %s" v @@ exntos exn
3884 src#
string "throttle"
3886 match conf
.maxwait
with
3887 | None
-> "show place holder if page is not ready"
3890 then "wait for page to fully render"
3892 "wait " ^ string_of_float
time
3893 ^
" seconds before showing placeholder"
3897 let f = float_of_string
v in
3899 then conf
.maxwait
<- None
3900 else conf
.maxwait
<- Some
f
3902 state
.text <- Printf.sprintf
"bad time `%s': %s" v @@ exntos exn
3904 src#
string "ghyll scroll"
3906 match conf
.ghyllscroll
with
3908 | Some nab
-> ghyllscroll_to_string nab
3911 try conf
.ghyllscroll
<- ghyllscroll_of_string
v
3914 state
.text <- Printf.sprintf
"bad ghyll `%s': %s" v msg
3916 state
.text <- Printf.sprintf
"bad ghyll `%s': %s" v @@ exntos exn
3918 src#
string "selection command"
3919 (fun () -> conf
.selcmd
)
3920 (fun v -> conf
.selcmd
<- v);
3921 src#
string "synctex command"
3922 (fun () -> conf
.stcmd
)
3923 (fun v -> conf
.stcmd
<- v);
3924 src#
string "pax command"
3925 (fun () -> conf
.paxcmd
)
3926 (fun v -> conf
.paxcmd
<- v);
3927 src#
string "ask password command"
3928 (fun () -> conf
.passcmd)
3929 (fun v -> conf
.passcmd <- v);
3930 src#
string "save path command"
3931 (fun () -> conf
.savecmd
)
3932 (fun v -> conf
.savecmd
<- v);
3933 src#colorspace
"color space"
3934 (fun () -> CSTE.to_string conf
.colorspace
)
3936 conf
.colorspace
<- CSTE.of_int
v;
3940 src#paxmark
"pax mark method"
3941 (fun () -> MTE.to_string conf
.paxmark
)
3942 (fun v -> conf
.paxmark
<- MTE.of_int
v);
3946 (fun () -> conf
.usepbo
)
3947 (fun v -> conf
.usepbo
<- v);
3948 src#
bool "mouse wheel scrolls pages"
3949 (fun () -> conf
.wheelbypage
)
3950 (fun v -> conf
.wheelbypage
<- v);
3951 src#
bool "open remote links in a new instance"
3952 (fun () -> conf
.riani
)
3953 (fun v -> conf
.riani
<- v);
3954 src#
bool "edit annotations inline"
3955 (fun () -> conf
.annotinline
)
3956 (fun v -> conf
.annotinline
<- v);
3960 src#caption
"Document" 0;
3961 List.iter
(fun (_, s) -> src#caption
s 1) state
.docinfo
;
3962 src#caption2
"Pages"
3963 (fun () -> string_of_int state
.pagecount
) 1;
3964 src#caption2
"Dimensions"
3965 (fun () -> string_of_int
(List.length state
.pdims
)) 1;
3969 src#caption
"Trimmed margins" 0;
3970 src#caption2
"Dimensions"
3971 (fun () -> string_of_int
(List.length state
.pdims
)) 1;
3975 src#caption
"OpenGL" 0;
3976 src#caption
(Printf.sprintf
"Vendor\t%s" (GlMisc.get_string `vendor
)) 1;
3977 src#caption
(Printf.sprintf
"Renderer\t%s" (GlMisc.get_string `renderer
)) 1;
3980 src#caption
"Location" 0;
3981 if nonemptystr state
.origin
3982 then src#caption
("Orign\t" ^ mbtoutf8 state
.origin
) 1;
3983 src#caption
("Path\t" ^ mbtoutf8 state
.path) 1;
3985 src#reset prevmode prevuioh
;
3990 let prevmode = state
.mode
3991 and prevuioh
= state
.uioh in
3992 fillsrc prevmode prevuioh
;
3993 let source = (src :> lvsource
) in
3994 let modehash = findkeyhash conf
"info" in
3995 state
.uioh <- coe (object (self)
3996 inherit listview ~zebra
:false ~helpmode
:false
3997 ~
source ~trusted
:true ~
modehash as super
3998 val mutable m_prevmemused
= 0
3999 method! infochanged
= function
4001 if m_prevmemused
!= state
.memused
4003 m_prevmemused
<- state
.memused
;
4004 G.postRedisplay "memusedchanged";
4006 | Pdim
-> G.postRedisplay "pdimchanged"
4007 | Docinfo
-> fillsrc prevmode prevuioh
4009 method! key key mask
=
4010 if not
(Wsi.withctrl mask
)
4013 | @left | @kpleft
-> coe (self#updownlevel ~
-1)
4014 | @right
| @kpright
-> coe (self#updownlevel
1)
4015 | _ -> super#
key key mask
4016 else super#
key key mask
4018 G.postRedisplay "info";
4024 inherit lvsourcebase
4025 method getitemcount
= Array.length state
.help
4027 let s, l, _ = state
.help
.(n) in
4030 method exit ~
uioh ~cancel ~
active ~
first ~pan
=
4034 match state
.help
.(active) with
4035 | _, _, Action
f -> Some
(f uioh)
4036 | _, _, Noaction
-> Some
uioh
4045 method hasaction
n =
4046 match state
.help
.(n) with
4047 | _, _, Action
_ -> true
4048 | _, _, Noaction
-> false
4054 let modehash = findkeyhash conf
"help" in
4056 state
.uioh <- coe (new listview
4057 ~zebra
:false ~helpmode
:true
4058 ~
source ~trusted
:true ~
modehash);
4059 G.postRedisplay "help";
4065 inherit lvsourcebase
4066 val mutable m_items
= E.a
4068 method getitemcount
= 1 + Array.length m_items
4073 else m_items
.(n-1), 0
4075 method exit ~
uioh ~cancel ~
active ~
first ~pan
=
4080 then Buffer.clear state
.errmsgs
;
4087 method hasaction
n =
4091 state
.newerrmsgs
<- false;
4092 let l = Str.split newlinere
(Buffer.contents state
.errmsgs
) in
4093 m_items
<- Array.of_list
l
4102 let source = (msgsource :> lvsource
) in
4103 let modehash = findkeyhash conf
"listview" in
4104 state
.uioh <- coe (object
4105 inherit listview ~zebra
:false ~helpmode
:false
4106 ~
source ~trusted
:false ~
modehash as super
4109 then msgsource#reset
;
4112 G.postRedisplay "msgs";
4116 let editor = getenvwithdef
"EDITOR" E.s in
4120 let tmppath = Filename.temp_file
"llpp" "note" in
4123 let oc = open_out
tmppath in
4127 let execstr = editor ^
" " ^
tmppath in
4129 match spawn
execstr [] with
4130 | (exception exn
) ->
4131 impmsg "spawn(%S) failed: %s" execstr @@ exntos exn
;
4134 match Unix.waitpid
[] pid with
4135 | (exception exn
) ->
4136 impmsg "waitpid(%d) failed: %s" pid @@ exntos exn
;
4140 | Unix.WEXITED
0 -> filecontents
tmppath
4142 impmsg "editor process(%s) exited abnormally: %d" execstr n;
4144 | Unix.WSIGNALED
n ->
4145 impmsg "editor process(%s) was killed by signal %d" execstr n;
4147 | Unix.WSTOPPED
n ->
4148 impmsg "editor(%s) process was stopped by signal %d" execstr n;
4151 match Unix.unlink
tmppath with
4152 | (exception exn
) ->
4153 impmsg "failed to ulink %S: %s" tmppath @@ exntos exn
;
4158 let enterannotmode opaque slinkindex
=
4161 inherit lvsourcebase
4162 val mutable m_text
= E.s
4163 val mutable m_items
= E.a
4165 method getitemcount
= Array.length m_items
4168 let label, _func
= m_items
.(n) in
4171 method exit ~
uioh ~cancel ~
active ~
first ~pan
=
4172 ignore
(uioh, first, pan
);
4175 let _label, func
= m_items
.(active) in
4180 method hasaction
n = nonemptystr
@@ fst m_items
.(n)
4183 let rec split accu b i
=
4185 if p = String.length
s
4186 then (String.sub
s b (p-b), unit) :: accu
4188 if (i
> 70 && s.[p] = ' '
) || s.[p] = '
\r'
|| s.[p] = '
\n'
4190 let ss = if i
= 0 then E.s else String.sub
s b i
in
4191 split ((ss, unit)::accu) (p+1) 0
4196 wcmd "freepage %s" (~
> opaque);
4198 Hashtbl.fold (fun key opaque'
accu ->
4199 if opaque'
= opaque'
4200 then key :: accu else accu) state
.pagemap
[]
4202 List.iter
(Hashtbl.remove state
.pagemap
) keys;
4207 delannot
opaque slinkindex
;
4210 let edit inline
() =
4215 modannot
opaque slinkindex
s;
4221 let mode = state
.mode in
4224 ("annotation: ", m_text
, None
, textentry, update, true),
4225 fun _ -> state
.mode <- mode);
4229 let s = getusertext m_text
in
4234 ( "[Copy]", fun () -> selstring m_text
)
4235 :: ("[Delete]", dele)
4236 :: ("[Edit]", edit conf
.annotinline
)
4238 :: split [] 0 0 |> List.rev
|> Array.of_list
4245 let s = getannotcontents
opaque slinkindex
in
4248 let source = (msgsource :> lvsource
) in
4249 let modehash = findkeyhash conf
"listview" in
4250 state
.uioh <- coe (object
4251 inherit listview ~zebra
:false ~helpmode
:false
4252 ~
source ~trusted
:false ~
modehash
4254 G.postRedisplay "enterannotmode";
4257 let gotounder under =
4258 let getpath filename
=
4260 if nonemptystr filename
4262 if Filename.is_relative filename
4264 let dir = Filename.dirname state
.path in
4266 if Filename.is_implicit
dir
4267 then Filename.concat
(Sys.getcwd
()) dir
4270 Filename.concat
dir filename
4274 if Sys.file_exists
path
4279 | Ulinkgoto
(pageno, top) ->
4283 gotopage1 pageno top;
4286 | Ulinkuri
s -> gotouri
s
4288 | Uremote
(filename
, pageno) ->
4289 let path = getpath filename
in
4294 let command = Printf.sprintf
"%s -page %d %S" !selfexec pageno path in
4295 match spawn
command [] with
4297 | (exception exn
) ->
4298 dolog
"failed to execute `%s': %s" command @@ exntos exn
4300 let anchor = getanchor
() in
4301 let ranchor = state
.path, state
.password, anchor, state
.origin
in
4302 state
.origin
<- E.s;
4303 state
.anchor <- (pageno, 0.0, 0.0);
4304 state
.ranchors
<- ranchor :: state
.ranchors
;
4307 else impmsg "cannot find %s" filename
4309 | Uremotedest
(filename
, destname
) ->
4310 let path = getpath filename
in
4315 let command = !selfexec ^
" " ^
path ^
" -dest " ^ destname
in
4316 match spawn
command [] with
4317 | (exception exn
) ->
4318 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
.nameddest
<- destname
;
4325 state
.ranchors
<- ranchor :: state
.ranchors
;
4328 else impmsg "cannot find %s" filename
4330 | Uunexpected
_ | Ulaunch
_ | Unamed
_ | Utext
_ | Unone
-> ()
4331 | Uannotation
(opaque, slinkindex
) -> enterannotmode opaque slinkindex
4334 let gotooutline (_, _, kind
) =
4338 let (pageno, y, _) = anchor in
4340 (if conf
.presentation
then (pageno, y, 1.0) else anchor)
4344 | Ouri
uri -> gotounder (Ulinkuri
uri)
4345 | Olaunch cmd
-> gotounder (Ulaunch cmd
)
4346 | Oremote remote
-> gotounder (Uremote remote
)
4347 | Ohistory hist
-> gotohist hist
4348 | Oremotedest remotedest
-> gotounder (Uremotedest remotedest
)
4351 let outlinesource fetchoutlines
=
4353 inherit lvsourcebase
4354 val mutable m_items
= E.a
4355 val mutable m_minfo
= E.a
4356 val mutable m_orig_items
= E.a
4357 val mutable m_orig_minfo
= E.a
4358 val mutable m_narrow_patterns
= []
4359 val mutable m_gen
= -1
4361 method getitemcount
= Array.length m_items
4364 let s, n, _ = m_items
.(n) in
4367 method exit ~
uioh ~cancel ~
active ~
first ~pan
=
4368 ignore
(uioh, first);
4370 if m_narrow_patterns
= []
4371 then m_orig_items
, m_orig_minfo
4372 else m_items
, m_minfo
4379 gotooutline m_items
.(active);
4387 method hasaction
_ = true
4390 if Array.length m_items
!= Array.length m_orig_items
4393 match m_narrow_patterns
with
4395 | many
-> String.concat
"@Uellipsis" (List.rev many
)
4397 "Narrowed to " ^
s ^
" (ctrl-u to restore)"
4401 match m_narrow_patterns
with
4404 | head
:: _ -> "@Uellipsis" ^ head
4406 method narrow
pattern =
4407 match Str.regexp_case_fold
pattern with
4408 | (exception _) -> ()
4410 let rec loop accu minfo n =
4413 m_items
<- Array.of_list
accu;
4414 m_minfo
<- Array.of_list
minfo;
4417 let (s, _, _) as o = m_items
.(n) in
4419 match Str.search_forward re
s 0 with
4420 | (exception Not_found
) -> accu, minfo
4421 | first -> o :: accu, (first, Str.match_end
()) :: minfo
4423 loop accu minfo (n-1)
4425 loop [] [] (Array.length m_items
- 1)
4427 method! getminfo
= m_minfo
4430 m_orig_items
<- fetchoutlines
();
4431 m_minfo
<- m_orig_minfo
;
4432 m_items
<- m_orig_items
4434 method add_narrow_pattern
pattern =
4435 m_narrow_patterns
<- pattern :: m_narrow_patterns
4437 method del_narrow_pattern
=
4438 match m_narrow_patterns
with
4439 | _ :: rest
-> m_narrow_patterns
<- rest
4444 match m_narrow_patterns
with
4445 | pattern :: [] -> self#narrow
pattern; pattern
4447 List.fold_left
(fun accu pattern ->
4448 self#narrow
pattern;
4449 pattern ^
"@Uellipsis" ^
accu) E.s list
4451 method calcactive
anchor =
4452 let rely = getanchory anchor in
4453 let rec loop n best bestd
=
4454 if n = Array.length m_items
4457 let _, _, kind
= m_items
.(n) in
4460 let orely = getanchory anchor in
4461 let d = abs
(orely - rely) in
4464 else loop (n+1) best bestd
4465 | Onone
| Oremote
_ | Olaunch
_
4466 | Oremotedest
_ | Ouri
_ | Ohistory
_ ->
4467 loop (n+1) best bestd
4471 method reset
anchor items =
4472 if state
.gen
!= m_gen
4474 m_orig_items
<- items;
4476 m_narrow_patterns
<- [];
4478 m_orig_minfo
<- E.a;
4482 if items != m_orig_items
4484 m_orig_items
<- items;
4485 if m_narrow_patterns
== []
4486 then m_items
<- items;
4489 let active = self#calcactive
anchor in
4491 m_first
<- firstof m_first
active
4495 let enteroutlinemode, enterbookmarkmode
, enterhistmode
=
4496 let mkselector sourcetype
=
4497 let fetchoutlines () =
4498 match sourcetype
with
4499 | `bookmarks
-> Array.of_list state
.bookmarks
4500 | `outlines
-> state
.outlines
4501 | `history
-> genhistoutlines ()
4503 let source = outlinesource fetchoutlines in
4505 let outlines = fetchoutlines () in
4506 if Array.length
outlines = 0
4508 showtext ' ' errmsg
;
4512 Wsi.setcursor
Wsi.CURSOR_INHERIT
;
4513 let anchor = getanchor
() in
4514 source#reset
anchor outlines;
4515 state
.text <- source#greetmsg
;
4517 coe (new outlinelistview ~zebra
:(sourcetype
=`history
) ~
source);
4518 G.postRedisplay "enter selector";
4521 let mkenter sourcetype errmsg
=
4522 let enter = mkselector sourcetype
in
4523 fun () -> enter errmsg
4525 (**)mkenter `
outlines "document has no outline"
4526 , mkenter `bookmarks
"document has no bookmarks (yet)"
4527 , mkenter `history
"history is empty"
4530 let quickbookmark ?title
() =
4531 match state
.layout with
4537 let tm = Unix.localtime
(now
()) in
4539 "Quick (page %d) (bookmarked at %02d/%02d/%d %02d:%02d)"
4543 (tm.Unix.tm_year
+ 1900)
4546 | Some
title -> title
4548 state
.bookmarks
<- (title, 0, Oanchor
(getanchor1
l)) :: state
.bookmarks
4551 let setautoscrollspeed step goingdown
=
4552 let incr = max
1 ((abs step
) / 2) in
4553 let incr = if goingdown
then incr else -incr in
4554 let astep = boundastep state
.winh
(step
+ incr) in
4555 state
.autoscroll
<- Some
astep;
4559 match conf
.columns
with
4561 | Csingle
_ | Cmulti
_ -> state
.x != 0 || conf
.zoom > 1.0
4564 let panbound x = bound
x (-state
.w) (wadjsb () + state
.winw
);;
4566 let existsinrow pageno (columns
, coverA
, coverB
) p =
4567 let last = ((pageno - coverA
) mod columns
) + columns
in
4568 let rec any = function
4571 if l.pageno = coverA
- 1 || l.pageno = state
.pagecount
- coverB
4575 then (if l.pageno = last then false else any rest
)
4583 match state
.layout with
4585 let pageno = page_of_y state
.y in
4586 gotoghyll (getpagey
(pageno+1))
4588 match conf
.columns
with
4590 if conf
.presentation
&& rest
== [] && l.pageh
> l.pagey + l.pagevh
4592 let y = clamp (pgscale state
.winh
) in
4595 let pageno = min
(l.pageno+1) (state
.pagecount
-1) in
4596 gotoghyll (getpagey
pageno)
4597 | Cmulti
((c, _, _) as cl, _) ->
4598 if conf
.presentation
4599 && (existsinrow l.pageno cl
4600 (fun l -> l.pageh
> l.pagey + l.pagevh))
4602 let y = clamp (pgscale state
.winh
) in
4605 let pageno = min
(l.pageno+c) (state
.pagecount
-1) in
4606 gotoghyll (getpagey
pageno)
4608 if l.pageno < state
.pagecount
- 1 || l.pagecol
< n - 1
4610 let pagey, pageh
= getpageyh
l.pageno in
4611 let pagey = pagey + pageh
* l.pagecol
in
4612 let ips = if l.pagecol
= 0 then 0 else conf
.interpagespace
in
4613 gotoghyll (pagey + pageh
+ ips)
4617 match state
.layout with
4619 let pageno = page_of_y state
.y in
4620 gotoghyll (getpagey
(pageno-1))
4622 match conf
.columns
with
4624 if conf
.presentation
&& l.pagey != 0
4626 gotoghyll (clamp (pgscale ~
-(state
.winh
)))
4628 let pageno = max
0 (l.pageno-1) in
4629 gotoghyll (getpagey
pageno)
4630 | Cmulti
((c, _, coverB
) as cl, _) ->
4631 if conf
.presentation
&&
4632 (existsinrow l.pageno cl (fun l -> l.pagey != 0))
4634 gotoghyll (clamp (pgscale ~
-(state
.winh
)))
4637 if l.pageno = state
.pagecount
- coverB
4641 let pageno = max
0 (l.pageno-decr) in
4642 gotoghyll (getpagey
pageno)
4650 let pageno = max
0 (l.pageno-1) in
4651 let pagey, pageh
= getpageyh
pageno in
4654 let pagey, pageh
= getpageyh
l.pageno in
4655 pagey + pageh
* (l.pagecol
-1) - conf
.interpagespace
4661 if emptystr conf
.savecmd
4662 then error
"don't know where to save modified document"
4664 let savecmd = Str.global_replace percentsre state
.path conf
.savecmd in
4667 (fun s -> error
"failed to obtain path to the saved copy: %s" s)
4672 let tmp = path ^
".tmp" in
4674 Unix.rename
tmp path;
4677 let viewkeyboard key mask
=
4679 let mode = state
.mode in
4680 state
.mode <- Textentry
(te, fun _ -> state
.mode <- mode);
4683 G.postRedisplay "view:enttext"
4685 let ctrl = Wsi.withctrl mask
in
4687 if key >= 0xffb0 && key < 0xffb9 then key - 0xffb0 + 48 else key
4693 if hasunsavedchanges
()
4697 if conf
.angle
mod 360 = 0 && not
(isbirdseye state
.mode)
4699 state
.mode <- LinkNav
(Ltgendir
0);
4702 else impmsg "keyboard link navigation does not work under rotation"
4705 begin match state
.mstate
with
4708 G.postRedisplay "kill rect";
4711 | Mscrolly
| Mscrollx
4714 begin match state
.mode with
4717 G.postRedisplay "esc leave linknav"
4721 match state
.ranchors
with
4723 | (path, password, anchor, origin
) :: rest
->
4724 state
.ranchors
<- rest
;
4725 state
.anchor <- anchor;
4726 state
.origin
<- origin
;
4727 state
.nameddest
<- E.s;
4728 opendoc path password
4733 gotoghyll (getnav ~
-1)
4744 Hashtbl.iter
(fun _ opaque ->
4746 Hashtbl.clear state
.prects
) state
.pagemap
;
4747 G.postRedisplay "dehighlight";
4749 | @slash
| @question
->
4750 let ondone isforw
s =
4751 cbput state
.hists
.pat
s;
4752 state
.searchpattern
<- s;
4755 let s = String.make
1 (Char.chr
key) in
4756 enttext (s, E.s, Some
(onhist state
.hists
.pat
),
4757 textentry, ondone (key = @slash
), true)
4759 | @plus
| @kpplus
| @equals
when ctrl ->
4760 let incr = if conf
.zoom +. 0.01 > 0.1 then 0.1 else 0.01 in
4761 setzoom (conf
.zoom +. incr)
4763 | @plus
| @kpplus
->
4766 try int_of_string
s with exc
->
4767 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exc
;
4773 state
.text <- "page bias is now " ^ string_of_int
n;
4776 enttext ("page bias: ", E.s, None
, intentry, ondone, true)
4778 | @minus
| @kpminus
when ctrl ->
4779 let decr = if conf
.zoom -. 0.1 < 0.1 then 0.01 else 0.1 in
4780 setzoom (max
0.01 (conf
.zoom -. decr))
4782 | @minus
| @kpminus
->
4783 let ondone msg
= state
.text <- msg
in
4785 "option [acfhilpstvxACFPRSZTISM]: ", E.s, None
,
4786 optentry state
.mode, ondone, true
4797 | (@1 | @2) when ctrl && conf
.fitmodel
!= FitPage
-> (* ctrl-1/2 *)
4799 match conf
.columns
with
4800 | Csingle
_ | Cmulti
_ -> 1
4801 | Csplit
(n, _) -> n
4803 let h = state
.winh
-
4804 conf
.interpagespace
lsl (if conf
.presentation
then 1 else 0)
4806 let zoom = zoomforh state
.winw
h (vscrollw ()) cols in
4807 if zoom > 0.0 && (key = 50 || zoom < 1.0)
4812 match conf
.fitmodel
with
4813 | FitWidth
-> FitProportional
4814 | FitProportional
-> FitPage
4815 | FitPage
-> FitWidth
4817 state
.text <- "fit model: " ^
FMTE.to_string
fm;
4818 reqlayout conf
.angle
fm
4826 | (48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57)
4827 when not
ctrl -> (* 0..9 *)
4830 try int_of_string
s with exc
->
4831 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exc
;
4837 cbput state
.hists
.pag
(string_of_int
n);
4838 gotopage1 (n + conf
.pagebias
- 1) 0;
4841 let pageentry text key =
4842 match Char.unsafe_chr
key with
4843 | '
g'
-> TEdone
text
4844 | _ -> intentry text key
4846 let text = String.make
1 (Char.chr
key) in
4847 enttext (":", text, Some
(onhist state
.hists
.pag
),
4848 pageentry, ondone, true)
4851 conf
.scrollb
<- if conf
.scrollb
= 0 then (scrollbvv
lor scrollbhv
) else 0;
4852 reshape state
.winw state
.winh
;
4855 state
.bzoom
<- not state
.bzoom
;
4857 showtext ' '
("block zoom " ^
if state
.bzoom
then "on" else "off")
4860 conf
.hlinks
<- not conf
.hlinks
;
4861 state
.text <- "highlightlinks " ^
if conf
.hlinks
then "on" else "off";
4862 G.postRedisplay "toggle highlightlinks";
4865 if conf
.angle
mod 360 = 0
4867 state
.glinks
<- true;
4868 let mode = state
.mode in
4871 (":", E.s, None
, linknentry, linknact gotounder, false),
4873 state
.glinks
<- false;
4877 G.postRedisplay "view:linkent(F)"
4879 else impmsg "hint mode does not work under rotation"
4882 state
.glinks
<- true;
4883 let mode = state
.mode in
4884 state
.mode <- Textentry
(
4886 ":", E.s, None
, linknentry, linknact (fun under ->
4887 selstring (undertext under);
4891 state
.glinks
<- false;
4895 G.postRedisplay "view:linkent"
4898 begin match state
.autoscroll
with
4900 conf
.autoscrollstep
<- step
;
4901 state
.autoscroll
<- None
4903 if conf
.autoscrollstep
= 0
4904 then state
.autoscroll
<- Some
1
4905 else state
.autoscroll
<- Some conf
.autoscrollstep
4909 launchpath () (* XXX where do error messages go? *)
4912 setpresentationmode (not conf
.presentation
);
4913 showtext ' '
("presentation mode " ^
4914 if conf
.presentation
then "on" else "off");
4917 if List.mem
Wsi.Fullscreen state
.winstate
4918 then Wsi.reshape conf
.cwinw conf
.cwinh
4919 else Wsi.fullscreen
()
4922 search state
.searchpattern
false
4925 search state
.searchpattern
true
4928 begin match state
.layout with
4931 gotoghyll (getpagey
l.pageno)
4937 | @delete
| @kpdelete
-> (* delete *)
4941 showtext ' '
(describe_location ());
4944 begin match state
.layout with
4947 Wsi.reshape (l.pagew
+ vscrollw ()) l.pageh
;
4952 enterbookmarkmode
()
4960 | @e when Buffer.length state
.errmsgs
> 0 ->
4965 match state
.layout with
4970 (s, 0, Oanchor
(getanchor1
l)) :: state
.bookmarks
4973 enttext ("bookmark: ", E.s, None
, textentry, ondone, true)
4977 showtext ' '
"Quick bookmark added";
4980 begin match state
.layout with
4982 let rect = getpdimrect
l.pagedimno
in
4986 (truncate
(1.8 *. (rect.(1) -. rect.(0))),
4987 truncate
(1.2 *. (rect.(3) -. rect.(0))))
4989 (truncate
(rect.(1) -. rect.(0)),
4990 truncate
(rect.(3) -. rect.(0)))
4992 let w = truncate
((float w)*.conf
.zoom)
4993 and h = truncate
((float h)*.conf
.zoom) in
4996 state
.anchor <- getanchor
();
4997 Wsi.reshape (w + vscrollw ()) (h + conf
.interpagespace
)
4999 G.postRedisplay "z";
5004 | @x -> state
.roam
()
5007 reqlayout (conf
.angle
+
5008 (if key = @Gt
then 30 else -30)) conf
.fitmodel
5012 bound
(conf
.colorscale
+. (if key = 93 then 0.1 else -0.1)) 0.0 1.0
5014 G.postRedisplay "brightness";
5016 | @c when state
.mode = View
->
5021 let m = (wadjsb () + state
.winw
- state
.w) / 2 in
5023 gotoy_and_clear_text state
.y
5027 match state
.prevcolumns
with
5028 | None
-> (1, 0, 0), 1.0
5029 | Some
(columns
, z
) ->
5032 | Csplit
(c, _) -> -c, 0, 0
5033 | Cmulti
((c, a, b), _) -> c, a, b
5034 | Csingle
_ -> 1, 0, 0
5038 setcolumns View
c a b;
5041 | @down
| @up
when ctrl && Wsi.withshift mask
->
5042 let zoom, x = state
.prevzoom
in
5046 | @k
| @up
| @kpup
->
5047 begin match state
.autoscroll
with
5049 begin match state
.mode with
5050 | Birdseye beye
-> upbirdseye 1 beye
5055 then gotoy_and_clear_text (clamp ~
-(state
.winh
/2))
5057 if not
(Wsi.withshift mask
) && conf
.presentation
5059 else gotoghyll1 true (clamp (-conf
.scrollstep
))
5063 setautoscrollspeed n false
5066 | @j
| @down
| @kpdown
->
5067 begin match state
.autoscroll
with
5069 begin match state
.mode with
5070 | Birdseye beye
-> downbirdseye 1 beye
5075 then gotoy_and_clear_text (clamp (state
.winh
/2))
5077 if not
(Wsi.withshift mask
) && conf
.presentation
5079 else gotoghyll1 true (clamp (conf
.scrollstep
))
5083 setautoscrollspeed n true
5086 | @left | @right
| @kpleft
| @kpright
when not
(Wsi.withalt mask
) ->
5092 else conf
.hscrollstep
5094 let dx = if key = @left || key = @kpleft
then dx else -dx in
5095 state
.x <- panbound (state
.x + dx);
5096 gotoy_and_clear_text state
.y
5099 G.postRedisplay "left/right"
5102 | @prior
| @kpprior
->
5106 match state
.layout with
5108 | l :: _ -> state
.y - l.pagey
5110 clamp (pgscale (-state
.winh
))
5114 | @next | @kpnext
->
5118 match List.rev state
.layout with
5120 | l :: _ -> getpagey
l.pageno
5122 clamp (pgscale state
.winh
)
5126 | @g | @home
| @kphome
->
5129 | @G
| @jend
| @kpend
->
5131 gotoghyll (clamp state
.maxy)
5133 | @right
| @kpright
when Wsi.withalt mask
->
5134 gotoghyll (getnav 1)
5135 | @left | @kpleft
when Wsi.withalt mask
->
5136 gotoghyll (getnav ~
-1)
5141 | @v when conf
.debug
->
5144 match getopaque l.pageno with
5147 let x0, y0, x1, y1 = pagebbox
opaque in
5148 let a,b = float x0, float y0 in
5149 let c,d = float x1, float y0 in
5150 let e,f = float x1, float y1 in
5151 let h,j
= float x0, float y1 in
5152 let rect = (a,b,c,d,e,f,h,j
) in
5154 let color = (0.0, 0.0, 1.0 /. (l.pageno mod 3 |> float), 0.5) in
5155 state
.rects
<- (l.pageno, color, rect) :: state
.rects
;
5157 G.postRedisplay "v";
5160 let mode = state
.mode in
5161 let cmd = ref E.s in
5162 let onleave = function
5163 | Cancel
-> state
.mode <- mode
5166 match getopaque l.pageno with
5167 | Some
opaque -> pipesel opaque !cmd
5168 | None
-> ()) state
.layout;
5172 cbput state
.hists
.sel
s;
5176 "| ", !cmd, Some
(onhist state
.hists
.sel
), textentry, ondone, true
5178 G.postRedisplay "|";
5179 state
.mode <- Textentry
(te, onleave);
5182 vlog "huh? %s" (Wsi.keyname
key)
5185 let linknavkeyboard key mask
linknav =
5186 let getpage pageno =
5187 let rec loop = function
5189 | l :: _ when l.pageno = pageno -> Some
l
5190 | _ :: rest
-> loop rest
5191 in loop state
.layout
5193 let doexact (pageno, n) =
5194 match getopaque pageno, getpage pageno with
5195 | Some
opaque, Some
l ->
5196 if key = @enter || key = @kpenter
5198 let under = getlink
opaque n in
5199 G.postRedisplay "link gotounder";
5206 Some
(findlink
opaque LDfirst
), -1
5209 Some
(findlink
opaque LDlast
), 1
5212 Some
(findlink
opaque (LDleft
n)), -1
5215 Some
(findlink
opaque (LDright
n)), 1
5218 Some
(findlink
opaque (LDup
n)), -1
5221 Some
(findlink
opaque (LDdown
n)), 1
5226 begin match findpwl
l.pageno dir with
5230 state
.mode <- LinkNav
(Ltgendir
dir);
5231 let y, h = getpageyh
pageno in
5234 then y + h - state
.winh
5239 begin match getopaque pageno, getpage pageno with
5240 | Some
opaque, Some
_ ->
5242 let ld = if dir > 0 then LDfirst
else LDlast
in
5245 begin match link with
5247 showlinktype (getlink
opaque m);
5248 state
.mode <- LinkNav
(Ltexact
(pageno, m));
5249 G.postRedisplay "linknav jpage";
5250 | Lnotfound
-> notfound dir
5256 begin match opt with
5257 | Some Lnotfound
-> pwl l dir;
5258 | Some
(Lfound
m) ->
5262 let _, y0, _, y1 = getlinkrect
opaque m in
5264 then gotopage1 l.pageno y0
5266 let d = fstate
.fontsize
+ 1 in
5267 if y1 - l.pagey > l.pagevh - d
5268 then gotopage1 l.pageno (y1 - state
.winh
- hscrollh () + d)
5269 else G.postRedisplay "linknav";
5271 showlinktype (getlink
opaque m);
5272 state
.mode <- LinkNav
(Ltexact
(l.pageno, m));
5275 | None
-> viewkeyboard key mask
5277 | _ -> viewkeyboard key mask
5282 G.postRedisplay "leave linknav"
5286 | Ltgendir
_ | Ltnotready
_ -> viewkeyboard key mask
5287 | Ltexact exact
-> doexact exact
5290 let keyboard key mask
=
5291 if (key = @g && Wsi.withctrl mask
) && not
(istextentry state
.mode)
5292 then wcmd "interrupt"
5293 else state
.uioh <- state
.uioh#
key key mask
5296 let birdseyekeyboard key mask
5297 ((oconf
, leftx
, pageno, hooverpageno
, anchor) as beye
) =
5299 match conf
.columns
with
5301 | Cmulti
((c, _, _), _) -> c
5302 | Csplit
_ -> failwith
"bird's eye split mode"
5304 let pgh layout = List.fold_left
5305 (fun m l -> max
l.pageh
m) state
.winh
layout in
5307 | @l when Wsi.withctrl mask
->
5308 let y, h = getpageyh
pageno in
5309 let top = (state
.winh
- h) / 2 in
5310 gotoy (max
0 (y - top))
5311 | @enter | @kpenter
-> leavebirdseye beye
false
5312 | @escape
-> leavebirdseye beye
true
5313 | @up
-> upbirdseye incr beye
5314 | @down
-> downbirdseye incr beye
5315 | @left -> upbirdseye 1 beye
5316 | @right
-> downbirdseye 1 beye
5319 begin match state
.layout with
5323 state
.mode <- Birdseye
(
5324 oconf
, leftx
, l.pageno, hooverpageno
, anchor
5326 gotopage1 l.pageno 0;
5329 let layout = layout state
.x (state
.y-state
.winh
)
5331 (pgh state
.layout) in
5333 | [] -> gotoy (clamp (-state
.winh
))
5335 state
.mode <- Birdseye
(
5336 oconf
, leftx
, l.pageno, hooverpageno
, anchor
5338 gotopage1 l.pageno 0
5341 | [] -> gotoy (clamp (-state
.winh
))
5345 begin match List.rev state
.layout with
5347 let layout = layout state
.x
5348 (state
.y + (pgh state
.layout))
5349 state
.winw state
.winh
in
5350 begin match layout with
5352 let incr = l.pageh
- l.pagevh in
5357 oconf
, leftx
, state
.pagecount
- 1, hooverpageno
, anchor
5359 G.postRedisplay "birdseye pagedown";
5361 else gotoy (clamp (incr + conf
.interpagespace
*2));
5365 Birdseye
(oconf
, leftx
, l.pageno, hooverpageno
, anchor);
5366 gotopage1 l.pageno 0;
5369 | [] -> gotoy (clamp state
.winh
)
5373 state
.mode <- Birdseye
(oconf
, leftx
, 0, hooverpageno
, anchor);
5377 let pageno = state
.pagecount
- 1 in
5378 state
.mode <- Birdseye
(oconf
, leftx
, pageno, hooverpageno
, anchor);
5379 if not
(pagevisible state
.layout pageno)
5382 match List.rev state
.pdims
with
5384 | (_, _, h, _) :: _ -> h
5386 gotoy (max
0 (getpagey
pageno - (state
.winh
- h - conf
.interpagespace
)))
5387 else G.postRedisplay "birdseye end";
5389 | _ -> viewkeyboard key mask
5394 match state
.mode with
5395 | Textentry
_ -> scalecolor 0.4
5397 | View
-> scalecolor 1.0
5398 | Birdseye
(_, _, pageno, hooverpageno
, _) ->
5399 if l.pageno = hooverpageno
5402 if l.pageno = pageno
5404 let c = scalecolor 1.0 in
5406 GlDraw.line_width
3.0;
5407 let dispx = xadjsb () + l.pagedispx in
5409 (float (dispx-1)) (float (l.pagedispy-1))
5410 (float (dispx+l.pagevw+1))
5411 (float (l.pagedispy+l.pagevh+1))
5413 GlDraw.line_width
1.0;
5422 let postdrawpage l linkindexbase
=
5423 match getopaque l.pageno with
5425 if tileready l l.pagex
l.pagey
5427 let x = l.pagedispx - l.pagex
+ xadjsb ()
5428 and y = l.pagedispy - l.pagey in
5430 match conf
.columns
with
5431 | Csingle
_ | Cmulti
_ ->
5432 (if conf
.hlinks
then 1 else 0)
5434 && not
(isbirdseye state
.mode) then 2 else 0)
5438 match state
.mode with
5439 | Textentry
((_, s, _, _, _, _), _) when state
.glinks
-> s
5445 Hashtbl.find_all state
.prects
l.pageno |>
5446 List.iter
(fun vals
-> drawprect
opaque x y vals
);
5447 postprocess
opaque hlmask x y (linkindexbase
, s, conf
.hfsize
);
5452 let scrollindicator () =
5453 let sbw, ph
, sh = state
.uioh#
scrollph in
5454 let sbh, pw, sw = state
.uioh#scrollpw
in
5459 else ((state
.winw
- sbw), state
.winw
, 0)
5462 GlDraw.color (0.64, 0.64, 0.64);
5463 filledrect (float x0) 0. (float x1) (float state
.winh
);
5465 (float hx0
) (float (state
.winh
- sbh))
5466 (float (hx0
+ wadjsb () + state
.winw
)) (float state
.winh
)
5468 GlDraw.color (0.0, 0.0, 0.0);
5470 filledrect (float x0) ph
(float x1) (ph
+. sh);
5471 let pw = pw +. float hx0
in
5472 filledrect pw (float (state
.winh
- sbh)) (pw +. sw) (float state
.winh
);
5476 match state
.mstate
with
5477 | Mnone
| Mscrolly
| Mscrollx
| Mpan
_ | Mzoom
_ | Mzoomrect
_ ->
5480 | Msel
((x0, y0), (x1, y1)) ->
5481 let identify opaque l px py = Some
(opaque, l.pageno, px, py) in
5482 let o0,n0
,px0
,py0
= onppundermouse identify x0 y0 (~
< E.s, -1, 0, 0) in
5483 let _o1,n1
,px1
,py1
= onppundermouse identify x1 y1 (~
< E.s, -1, 0, 0) in
5484 if n0
!= -1 && n0
= n1
then seltext
o0 (px0
, py0
, px1
, py1
);
5487 let showrects = function [] -> () | rects
->
5489 GlDraw.color (0.0, 0.0, 1.0) ~
alpha:0.5;
5490 GlFunc.blend_func ~
src:`src_alpha ~dst
:`one_minus_src_alpha
;
5492 (fun (pageno, c, (x0, y0, x1, y1, x2
, y2
, x3
, y3
)) ->
5494 if l.pageno = pageno
5496 let dx = float (l.pagedispx - l.pagex
) in
5497 let dy = float (l.pagedispy - l.pagey) in
5498 let r, g, b, alpha = c in
5499 GlDraw.color (r, g, b) ~
alpha;
5500 Raw.sets_float state
.vraw ~
pos:0
5505 GlArray.vertex `two state
.vraw
;
5506 GlArray.draw_arrays `triangle_strip ~
first:0 ~count
:4;
5515 GlClear.color (scalecolor2 conf
.bgcolor
);
5516 GlClear.clear
[`
color];
5517 List.iter
drawpage state
.layout;
5519 match state
.mode with
5520 | LinkNav
(Ltexact
(pageno, linkno
)) ->
5521 begin match getopaque pageno with
5523 let dx = xadjsb () in
5524 let x0, y0, x1, y1 = getlinkrect
opaque linkno
in
5525 let x0 = x0 + dx and x1 = x1 + dx in
5526 let color = (0.0, 0.0, 0.5, 0.5) in
5533 | None
-> state
.rects
5535 | LinkNav
(Ltgendir
_) | LinkNav
(Ltnotready
_)
5538 | View
-> state
.rects
5541 let rec postloop linkindexbase
= function
5543 let linkindexbase = linkindexbase + postdrawpage l linkindexbase in
5544 postloop linkindexbase rest
5548 postloop 0 state
.layout;
5550 begin match state
.mstate
with
5551 | Mzoomrect
((x0, y0), (x1, y1)) ->
5553 GlDraw.color (0.3, 0.3, 0.3) ~
alpha:0.5;
5554 GlFunc.blend_func ~
src:`src_alpha ~dst
:`one_minus_src_alpha
;
5555 filledrect (float x0) (float y0) (float x1) (float y1);
5559 | Mscrolly
| Mscrollx
5568 let zoomrect x y x1 y1 =
5571 and y0 = min
y y1 in
5572 gotoy (state
.y + y0);
5573 state
.anchor <- getanchor
();
5574 let zoom = (float state
.w) /. float (x1 - x0) in
5577 let adjw = wadjsb () + state
.winw
in
5579 then (adjw - state
.w) / 2
5582 match conf
.fitmodel
with
5583 | FitWidth
| FitProportional
-> simple ()
5585 match conf
.columns
with
5587 onppundermouse (fun _ l _ _ -> Some
l.pagedispx) x0 y0 x0
5588 | Cmulti
_ | Csingle
_ -> simple ()
5590 state
.x <- (state
.x + margin) - x0;
5595 let annot inline
x y =
5596 match unproject x y with
5597 | Some
(opaque, n, ux
, uy
) ->
5599 addannot
opaque ux uy
text;
5600 wcmd "freepage %s" (~
> opaque);
5601 Hashtbl.remove state
.pagemap
(n, state
.gen
);
5607 let ondone s = add s in
5608 let mode = state
.mode in
5609 state
.mode <- Textentry
(
5610 ("annotation: ", E.s, None
, textentry, ondone, true),
5611 fun _ -> state
.mode <- mode);
5614 G.postRedisplay "annot"
5616 add @@ getusertext E.s
5621 let g opaque l px py =
5622 match rectofblock
opaque px py with
5624 let x0 = a.(0) -. 20. in
5625 let x1 = a.(1) +. 20. in
5626 let y0 = a.(2) -. 20. in
5627 let zoom = (float state
.w) /. (x1 -. x0) in
5628 let pagey = getpagey
l.pageno in
5629 gotoy_and_clear_text (pagey + truncate
y0);
5630 state
.anchor <- getanchor
();
5631 let margin = (state
.w - l.pagew
)/2 in
5632 state
.x <- -truncate
x0 - margin;
5637 match conf
.columns
with
5639 impmsg "block zooming does not work properly in split columns mode"
5640 | Cmulti
_ | Csingle
_ -> onppundermouse g x y ()
5644 let winw = wadjsb () + state
.winw - 1 in
5645 let s = float x /. float winw in
5646 let destx = truncate
(float (state
.w + winw) *. s) in
5647 state
.x <- winw - destx;
5648 gotoy_and_clear_text state
.y;
5649 state
.mstate
<- Mscrollx
;
5653 let s = float y /. float state
.winh
in
5654 let desty = truncate
(float (state
.maxy - state
.winh
) *. s) in
5655 gotoy_and_clear_text desty;
5656 state
.mstate
<- Mscrolly
;
5659 let viewmulticlick clicks
x y mask
=
5660 let g opaque l px py =
5668 if markunder
opaque px py mark
5672 match getopaque l.pageno with
5674 | Some
opaque -> pipesel opaque cmd
5676 state
.roam
<- (fun () -> dopipe conf
.paxcmd
);
5677 if not
(Wsi.withctrl mask
) then dopipe conf
.selcmd
;
5682 G.postRedisplay "viewmulticlick";
5683 onppundermouse g x y (fun () -> impmsg "nothing to select") ();
5687 match conf
.columns
with
5689 | Csingle
_ | Cmulti
_ -> conf
.angle
mod 360 = 0
5692 let viewmouse button down
x y mask
=
5694 | n when (n == 4 || n == 5) && not down
->
5695 if Wsi.withctrl mask
5697 match state
.mstate
with
5698 | Mzoom
(oldn
, i
) ->
5706 if conf
.zoom +. 0.01 > 0.1 then 0.1 else 0.01
5708 if conf
.zoom -. 0.1 < 0.1 then -0.01 else -0.1
5710 let zoom = conf
.zoom -. incr in
5712 state
.mstate
<- Mzoom
(n, 0);
5714 state
.mstate
<- Mzoom
(n, i
+1);
5716 else state
.mstate
<- Mzoom
(n, 0)
5720 | Mscrolly
| Mscrollx
5722 | Mnone
-> state
.mstate
<- Mzoom
(n, 0)
5725 match state
.autoscroll
with
5726 | Some step
-> setautoscrollspeed step
(n=4)
5728 if conf
.wheelbypage
|| conf
.presentation
5737 then -conf
.scrollstep
5738 else conf
.scrollstep
5740 let incr = incr * 2 in
5741 let y = clamp incr in
5742 gotoy_and_clear_text y
5745 | n when (n = 6 || n = 7) && not down
&& canpan () ->
5747 panbound (state
.x + (if n = 7 then -2 else 2) * conf
.hscrollstep
);
5748 gotoy_and_clear_text state
.y
5750 | 1 when Wsi.withshift mask
->
5751 state
.mstate
<- Mnone
;
5754 match unproject x y with
5756 | Some
(_, pageno, ux
, uy
) ->
5757 let cmd = Printf.sprintf
5759 conf
.stcmd state
.path pageno ux uy
5761 match spawn
cmd [] with
5762 | (exception exn
) ->
5763 impmsg "execution of synctex command(%S) failed: %S"
5764 conf
.stcmd
@@ exntos exn
5768 | 1 when Wsi.withctrl mask
->
5771 Wsi.setcursor
Wsi.CURSOR_FLEUR
;
5772 state
.mstate
<- Mpan
(x, y)
5775 state
.mstate
<- Mnone
5780 if Wsi.withshift mask
5782 annot conf
.annotinline
x y;
5783 G.postRedisplay "addannot"
5787 Wsi.setcursor
Wsi.CURSOR_CYCLE
;
5788 state
.mstate
<- Mzoomrect
(p, p)
5791 match state
.mstate
with
5792 | Mzoomrect
((x0, y0), _) ->
5793 if abs
(x-x0) > 10 && abs
(y - y0) > 10
5794 then zoomrect x0 y0 x y
5797 G.postRedisplay "kill accidental zoom rect";
5801 | Mscrolly
| Mscrollx
5807 | 1 when vscrollhit x ->
5810 let _, position, sh = state
.uioh#
scrollph in
5811 if y > truncate
position && y < truncate
(position +. sh)
5812 then state
.mstate
<- Mscrolly
5815 state
.mstate
<- Mnone
5817 | 1 when y > state
.winh
- hscrollh () ->
5820 let _, position, sw = state
.uioh#scrollpw
in
5821 if x > truncate
position && x < truncate
(position +. sw)
5822 then state
.mstate
<- Mscrollx
5825 state
.mstate
<- Mnone
5827 | 1 when state
.bzoom
-> if not down
then zoomblock x y
5830 let dest = if down
then getunder x y else Unone
in
5831 begin match dest with
5834 | Uremote
_ | Uremotedest
_
5835 | Uunexpected
_ | Ulaunch
_ | Unamed
_ ->
5838 | Unone
when down
->
5839 Wsi.setcursor
Wsi.CURSOR_FLEUR
;
5840 state
.mstate
<- Mpan
(x, y);
5842 | Uannotation
(opaque, slinkindex
) -> enterannotmode opaque slinkindex
5844 | Unone
| Utext
_ ->
5849 state
.mstate
<- Msel
((x, y), (x, y));
5850 G.postRedisplay "mouse select";
5854 match state
.mstate
with
5857 | Mzoom
_ | Mscrollx
| Mscrolly
->
5858 state
.mstate
<- Mnone
5860 | Mzoomrect
((x0, y0), _) ->
5864 Wsi.setcursor
Wsi.CURSOR_INHERIT
;
5865 state
.mstate
<- Mnone
5867 | Msel
((x0, y0), (x1, y1)) ->
5868 let rec loop = function
5872 let a0 = l.pagedispy in
5873 let a1 = a0 + l.pagevh in
5874 let b0 = l.pagedispx in
5875 let b1 = b0 + l.pagevw in
5876 ((y0 >= a0 && y0 <= a1) || (y1 >= a0 && y1 <= a1))
5877 && ((x0 >= b0 && x0 <= b1) || (x1 >= b0 && x1 <= b1))
5881 match getopaque l.pageno with
5884 match Unix.pipe
() with
5885 | (exception exn
) ->
5886 impmsg "cannot create sel pipe: %s" @@
5890 Ne.clo fd
(fun msg
->
5891 dolog
"%s close failed: %s" what msg
)
5894 try spawn
cmd [r, 0; w, -1]
5896 dolog
"cannot execute %S: %s"
5903 G.postRedisplay "copysel";
5905 else clo "Msel pipe/w" w;
5906 clo "Msel pipe/r" r;
5908 dosel conf
.selcmd
();
5909 state
.roam
<- dosel conf
.paxcmd
;
5921 let birdseyemouse button down
x y mask
5922 (conf
, leftx
, _, hooverpageno
, anchor) =
5925 let rec loop = function
5928 if y > l.pagedispy && y < l.pagedispy + l.pagevh
5929 && x > l.pagedispx && x < l.pagedispx + l.pagevw
5931 leavebirdseye (conf
, leftx
, l.pageno, hooverpageno
, anchor) false;
5937 | _ -> viewmouse button down
x y mask
5943 method key key mask
=
5944 begin match state
.mode with
5945 | Textentry
textentry -> textentrykeyboard key mask
textentry
5946 | Birdseye
birdseye -> birdseyekeyboard key mask
birdseye
5947 | View
-> viewkeyboard key mask
5948 | LinkNav
linknav -> linknavkeyboard key mask
linknav
5952 method button button bstate
x y mask
=
5953 begin match state
.mode with
5955 | View
-> viewmouse button bstate
x y mask
5956 | Birdseye beye
-> birdseyemouse button bstate
x y mask beye
5961 method multiclick clicks
x y mask
=
5962 begin match state
.mode with
5964 | View
-> viewmulticlick clicks
x y mask
5971 begin match state
.mode with
5973 | View
| Birdseye
_ | LinkNav
_ ->
5974 match state
.mstate
with
5975 | Mzoom
_ | Mnone
-> ()
5980 state
.mstate
<- Mpan
(x, y);
5982 then state
.x <- panbound (state
.x + dx);
5984 gotoy_and_clear_text y
5987 state
.mstate
<- Msel
(a, (x, y));
5988 G.postRedisplay "motion select";
5991 let y = min state
.winh
(max
0 y) in
5995 let x = min state
.winw (max
0 x) in
5998 | Mzoomrect
(p0
, _) ->
5999 state
.mstate
<- Mzoomrect
(p0
, (x, y));
6000 G.postRedisplay "motion zoomrect";
6004 method pmotion
x y =
6005 begin match state
.mode with
6006 | Birdseye
(conf
, leftx
, pageno, hooverpageno
, anchor) ->
6007 let rec loop = function
6009 if hooverpageno
!= -1
6011 state
.mode <- Birdseye
(conf
, leftx
, pageno, -1, anchor);
6012 G.postRedisplay "pmotion birdseye no hoover";
6015 if y > l.pagedispy && y < l.pagedispy + l.pagevh
6016 && x > l.pagedispx && x < l.pagedispx + l.pagevw
6018 state
.mode <- Birdseye
(conf
, leftx
, pageno, l.pageno, anchor);
6019 G.postRedisplay "pmotion birdseye hoover";
6029 match state
.mstate
with
6030 | Mpan
_ | Msel
_ | Mzoom
_ | Mscrolly
| Mscrollx
| Mzoomrect
_ -> ()
6038 let past, _, _ = !r in
6040 let delta = now -. past in
6043 else r := (now, x, y)
6047 method infochanged
_ = ()
6050 let maxy = state
.maxy - (if conf
.maxhfit
then state
.winh
else 0) in
6053 then 0.0, float state
.winh
6054 else scrollph state
.y maxy
6059 let winw = wadjsb () + state
.winw in
6060 let fwinw = float winw in
6062 let sw = fwinw /. float state
.w in
6063 let sw = fwinw *. sw in
6064 max
sw (float conf
.scrollh
)
6067 let maxx = state
.w + winw in
6068 let x = winw - state
.x in
6069 let percent = float x /. float maxx in
6070 (fwinw -. sw) *. percent
6072 hscrollh (), position, sw
6076 match state
.mode with
6077 | LinkNav
_ -> "links"
6078 | Textentry
_ -> "textentry"
6079 | Birdseye
_ -> "birdseye"
6082 findkeyhash conf
modename
6084 method eformsgs
= true
6085 method alwaysscrolly
= false
6088 let adderrmsg src msg
=
6089 Buffer.add_string state
.errmsgs msg
;
6090 state
.newerrmsgs
<- true;
6094 let adderrfmt src fmt
=
6095 Format.ksprintf
(fun s -> adderrmsg src s) fmt
;
6098 let addrect pageno r g b a x0 y0 x1 y1 =
6099 Hashtbl.add state
.prects
pageno [|r; g; b; a; x0; y0; x1; y1|];
6103 let cl = splitatspace cmds
in
6105 try Scanf.sscanf
s fmt
f
6107 adderrfmt "remote exec"
6108 "error processing '%S': %s\n" cmds
@@ exntos exn
6110 let rectx s pageno (r, g, b, a) x0 y0 x1 y1 =
6111 vlog "%s page %d color (%f %f %f %f) x0,y0,x1,y1 = %f %f %f %f"
6112 s pageno r g b a x0 y0 x1 y1;
6116 let _,w1,h1
,_ = getpagedim
pageno in
6117 let sw = float w1 /. float w
6118 and sh = float h1
/. float h in
6122 and y1s
= y1 *. sh in
6123 let rect = (x0s,y0s
,x1s
,y0s
,x1s
,y1s
,x0s,y1s
) in
6124 let color = (r, g, b, a) in
6125 if conf
.verbose
then debugrect rect;
6126 state
.rects <- (pageno, color, rect) :: state
.rects;
6131 | "reload" :: [] -> reload ()
6132 | "goto" :: args
:: [] ->
6133 scan args
"%u %f %f"
6135 let cmd, _ = state
.geomcmds
in
6137 then gotopagexy pageno x y
6140 gotopagexy pageno x y;
6143 state
.reprf
<- f state
.reprf
6145 | "goto1" :: args
:: [] -> scan args
"%u %f" gotopage
6146 | "gotor" :: args
:: [] ->
6148 (fun filename
pageno -> gotounder (Uremote
(filename
, pageno)))
6149 | "gotord" :: args
:: [] ->
6151 (fun filename
dest -> gotounder (Uremotedest
(filename
, dest)))
6152 | "rect" :: args
:: [] ->
6153 scan args
"%u %u %f %f %f %f"
6154 (fun pageno c x0 y0 x1 y1 ->
6155 let color = (0.0, 0.0, 1.0 /. float c, 0.5) in
6156 rectx "rect" pageno color x0 y0 x1 y1;
6158 | "prect" :: args
:: [] ->
6159 scan args
"%u %f %f %f %f %f %f %f %f"
6160 (fun pageno r g b alpha x0 y0 x1 y1 ->
6161 addrect pageno r g b alpha x0 y0 x1 y1;
6162 G.postRedisplay "prect"
6164 | "pgoto" :: args
:: [] ->
6165 scan args
"%u %f %f"
6168 match getopaque pageno with
6169 | Some
opaque -> opaque
6172 pgoto optopaque pageno x y;
6173 let rec fixx = function
6176 if l.pageno = pageno
6178 state
.x <- state
.x - l.pagedispx;
6185 match conf
.columns
with
6186 | Csingle
_ | Csplit
_ -> 1
6187 | Cmulti
((n, _, _), _) -> n
6189 layout 0 state
.y (state
.winw * mult) state
.winh
6193 | "activatewin" :: [] -> Wsi.activatewin
()
6194 | "quit" :: [] -> raise Quit
6195 | "clearrects" :: [] ->
6196 Hashtbl.clear state
.prects
;
6197 G.postRedisplay "clearrects"
6199 adderrfmt "remote command"
6200 "error processing remote command: %S\n" cmds
;
6204 let scratch = Bytes.create
80 in
6205 let buf = Buffer.create
80 in
6207 match tempfailureretry
(Unix.read fd
scratch 0) 80 with
6208 | (exception Unix.Unix_error
(Unix.EAGAIN
, _, _)) -> None
6211 if Buffer.length
buf > 0
6213 let s = Buffer.contents
buf in
6221 match Bytes.index_from
scratch ppos '
\n'
with
6222 | pos -> if pos >= n then -1 else pos
6223 | (exception Not_found
) -> -1
6227 Buffer.add_subbytes
buf scratch ppos
(nlpos-ppos
);
6228 let s = Buffer.contents
buf in
6234 Buffer.add_subbytes
buf scratch ppos
(n-ppos
);
6240 let remoteopen path =
6241 try Some
(Unix.openfile
path [Unix.O_NONBLOCK
; Unix.O_RDONLY
] 0o0)
6243 adderrfmt "remoteopen" "error opening %S: %s" path @@ exntos exn
;
6248 let gcconfig = ref E.s in
6249 let trimcachepath = ref E.s in
6250 let rcmdpath = ref E.s in
6251 let pageno = ref None
in
6252 let rootwid = ref 0 in
6253 let openlast = ref false in
6254 let nofc = ref false in
6255 let doreap = ref false in
6256 selfexec := Sys.executable_name
;
6259 [("-p", Arg.String
(fun s -> state
.password <- s),
6260 "<password> Set password");
6264 Config.fontpath
:= s;
6265 selfexec := !selfexec ^
" -f " ^
Filename.quote
s;
6267 "<path> Set path to the user interface font");
6271 selfexec := !selfexec ^
" -c " ^
Filename.quote
s;
6272 Config.confpath
:= s),
6273 "<path> Set path to the configuration file");
6275 ("-last", Arg.Set
openlast, " Open last document");
6277 ("-page", Arg.Int
(fun pageno1
-> pageno := Some
(pageno1
-1)),
6278 "<page-number> Jump to page");
6280 ("-tcf", Arg.String
(fun s -> trimcachepath := s),
6281 "<path> Set path to the trim cache file");
6283 ("-dest", Arg.String
(fun s -> state
.nameddest
<- s),
6284 "<named-destination> Set named destination");
6286 ("-wtmode", Arg.Set
wtmode, " Operate in wt mode");
6287 ("-cxack", Arg.Set
cxack, " Cut corners");
6289 ("-remote", Arg.String
(fun s -> rcmdpath := s),
6290 "<path> Set path to the remote commands source");
6292 ("-origin", Arg.String
(fun s -> state
.origin
<- s),
6293 "<original-path> Set original path");
6295 ("-gc", Arg.Set_string
gcconfig,
6296 "<script-path> Collect garbage with the help of a script");
6298 ("-nofc", Arg.Set
nofc, " Do not use fontconfig");
6300 ("-v", Arg.Unit
(fun () ->
6302 "%s\nconfiguration path: %s\n"
6306 exit
0), " Print version and exit");
6308 ("-embed", Arg.Set_int
rootwid,
6309 "<window-id> Embed into window")
6312 (fun s -> state
.path <- s)
6313 ("Usage: " ^
Sys.argv
.(0) ^
" [options] some.pdf\nOptions:")
6316 then selfexec := !selfexec ^
" -wtmode";
6318 let histmode = emptystr state
.path && not
!openlast in
6320 if not
(Config.load !openlast)
6321 then dolog
"failed to load configuration";
6322 begin match !pageno with
6323 | Some
pageno -> state
.anchor <- (pageno, 0.0, 0.0)
6327 if nonemptystr
!gcconfig
6330 match Unix.socketpair
Unix.PF_UNIX
Unix.SOCK_STREAM
0 with
6331 | (exception exn
) -> error
"socketpair for gc failed: %s" @@ exntos exn
6334 match spawn
!gcconfig [(c, 0); (c, 1); (s, -1)] with
6335 | (exception exn
) -> error
"failed to execute gc script: %s" @@ exntos exn
6337 Ne.clo c @@ (fun s -> error
"failed to close gc fd %s" s);
6342 let wsfd, winw, winh
= Wsi.init
(object (self)
6343 val mutable m_clicks
= 0
6344 val mutable m_click_x
= 0
6345 val mutable m_click_y
= 0
6346 val mutable m_lastclicktime
= infinity
6348 method private cleanup =
6349 state
.roam
<- noroam
;
6350 Hashtbl.iter
(fun _ opaque -> clearmark
opaque) state
.pagemap
6351 method expose
= G.postRedisplay"expose"
6355 | Wsi.Unobscured
-> "unobscured"
6356 | Wsi.PartiallyObscured
-> "partiallyobscured"
6357 | Wsi.FullyObscured
-> "fullyobscured"
6359 vlog "visibility change %s" name
6360 method display = display ()
6361 method map mapped
= vlog "mappped %b" mapped
6362 method reshape w h =
6365 method mouse
b d x y m =
6366 if d && canselect ()
6368 (* http://blogs.msdn.com/b/oldnewthing/archive/2004/10/18/243925.aspx *)
6374 if abs
x - m_click_x
> 10
6375 || abs
y - m_click_y
> 10
6376 || abs_float
(t -. m_lastclicktime
) > 0.3
6378 m_clicks
<- m_clicks
+ 1;
6379 m_lastclicktime
<- t;
6383 G.postRedisplay "cleanup";
6384 state
.uioh <- state
.uioh#button
b d x y m;
6386 else state
.uioh <- state
.uioh#multiclick m_clicks
x y m
6391 m_lastclicktime
<- infinity
;
6392 state
.uioh <- state
.uioh#button
b d x y m
6396 state
.uioh <- state
.uioh#button
b d x y m
6399 state
.mpos
<- (x, y);
6400 state
.uioh <- state
.uioh#motion
x y
6401 method pmotion
x y =
6402 state
.mpos
<- (x, y);
6403 state
.uioh <- state
.uioh#pmotion
x y
6405 let mascm = m land (
6406 Wsi.altmask
+ Wsi.shiftmask
+ Wsi.ctrlmask
+ Wsi.metamask
6409 let x = state
.x and y = state
.y in
6411 if x != state
.x || y != state
.y then self#
cleanup
6413 match state
.keystate
with
6415 let km = k
, mascm in
6418 let modehash = state
.uioh#
modehash in
6419 try Hashtbl.find modehash km
6421 try Hashtbl.find (findkeyhash conf
"global") km
6422 with Not_found
-> KMinsrt
(k
, m)
6424 | KMinsrt
(k
, m) -> keyboard k
m
6425 | KMinsrl
l -> List.iter
(fun (k
, m) -> keyboard k
m) l
6426 | KMmulti
(l, r) -> state
.keystate
<- KSinto
(l, r)
6428 | KSinto
((k'
, m'
) :: [], insrt
) when k'
=k
&& m'
land mascm = m'
->
6429 List.iter
(fun (k
, m) -> keyboard k
m) insrt
;
6430 state
.keystate
<- KSnone
6431 | KSinto
((k'
, m'
) :: keys, insrt
) when k'
=k
&& m'
land mascm = m'
->
6432 state
.keystate
<- KSinto
(keys, insrt
)
6433 | KSinto
_ -> state
.keystate
<- KSnone
6436 state
.mpos
<- (x, y);
6437 state
.uioh <- state
.uioh#pmotion
x y
6438 method leave = state
.mpos
<- (-1, -1)
6439 method winstate wsl
= state
.winstate
<- wsl
6440 method quit
= raise Quit
6441 end) !rootwid conf
.cwinw conf
.cwinh platform
in
6446 List.exists
GlMisc.check_extension
6447 [ "GL_ARB_texture_rectangle"
6448 ; "GL_EXT_texture_recangle"
6449 ; "GL_NV_texture_rectangle" ]
6451 then (dolog
"OpenGL does not suppport rectangular textures"; exit
1);
6454 let r = GlMisc.get_string `renderer
in
6455 let p = "Mesa DRI Intel(" in
6456 let l = String.length
p in
6457 String.length
r > l && String.sub
r 0 l = p
6460 defconf
.sliceheight
<- 1024;
6461 defconf
.texcount
<- 32;
6462 defconf
.usepbo
<- true;
6466 match Unix.socketpair
Unix.PF_UNIX
Unix.SOCK_STREAM
0 with
6467 | (exception exn
) ->
6468 dolog
"socketpair failed: %s" @@ exntos exn
;
6476 setcheckers conf
.checkers
;
6479 conf
.angle
, conf
.fitmodel
, (conf
.trimmargins
, conf
.trimfuzz
),
6480 conf
.texcount
, conf
.sliceheight
, conf
.mustoresize
, conf
.colorspace
,
6481 !Config.fontpath
, !trimcachepath,
6482 GlMisc.check_extension
"GL_ARB_pixel_buffer_object",
6485 List.iter
GlArray.enable
[`texture_coord
; `vertex
];
6487 reshape ~firsttime
:true winw winh
;
6491 Wsi.settitle
"llpp (history)";
6495 state
.text <- "Opening " ^
(mbtoutf8 state
.path);
6496 opendoc state
.path state
.password;
6500 Wsi.setcursor
Wsi.CURSOR_INHERIT
;
6501 Sys.set_signal
Sys.sighup
(Sys.Signal_handle
(fun _ -> reload ()));
6504 match Unix.waitpid
[Unix.WNOHANG
] ~
-1 with
6505 | (exception (Unix.Unix_error
(Unix.ECHILD
, _, _))) -> ()
6506 | (exception exn
) -> dolog
"Unix.waitpid: %s" @@ exntos exn
6508 | _pid
, _status
-> reap ()
6510 Sys.set_signal
Sys.sigchld
(Sys.Signal_handle
(fun _ -> doreap := true));
6514 if nonemptystr
!rcmdpath
6515 then remoteopen !rcmdpath
6520 let rec loop deadline
=
6526 let r = [state
.ss; state
.wsfd] in
6530 | Some fd
-> fd
:: r
6534 state
.redisplay
<- false;
6541 if deadline
= infinity
6543 else max
0.0 (deadline
-. now)
6548 try Unix.select
r [] [] timeout
6549 with Unix.Unix_error
(Unix.EINTR
, _, _) -> [], [], []
6555 if state
.ghyll
== noghyll
6557 match state
.autoscroll
with
6558 | Some step
when step
!= 0 ->
6559 let y = state
.y + step
in
6563 else if y >= state
.maxy then 0 else y
6565 if state
.mode = View
6566 then gotoy_and_clear_text y
6570 else deadline
+. 0.01
6575 let rec checkfds = function
6577 | fd
:: rest
when fd
= state
.ss ->
6578 let cmd = readcmd state
.ss in
6582 | fd
:: rest
when fd
= state
.wsfd ->
6586 | fd
:: rest
when Some fd
= !optrfd ->
6587 begin match remote fd
with
6588 | None
-> optrfd := remoteopen !rcmdpath;
6589 | opt -> optrfd := opt
6594 dolog
"select returned unknown descriptor";
6600 if deadline
= infinity
6604 match state
.autoscroll
with
6605 | Some step
when step
!= 0 -> deadline1
6606 | _ -> if state
.ghyll
== noghyll
then infinity
else deadline1
6614 Config.save leavebirdseye;
6615 if hasunsavedchanges
()