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
: 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) y 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 state
.x + (wadj + state
.winw
- w
) / 2
453 else dx + xoff
+ state
.x
460 let vw = wadj + state
.winw
- 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) y 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
508 let x = xoff
+ state
.x 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
527 if pagecolw < state
.winw
528 then pagedispx + ((wadj + state
.winw
- pagecolw) / 2)
532 let vw = wadj + state
.winw
- 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
566 if nogeomcmds state
.geomcmds
568 match conf
.columns
with
569 | Csingle
b -> layoutN ((1, 0, 0), b) y sh
570 | Cmulti
c -> layoutN c y sh
571 | Csplit
s -> layoutS s y 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 y =
825 let y = if y < state
.winh
then 0 else y - state
.winh
in
826 let h = state
.winh
*3 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
.y);
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 y 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 y state
.winh
in
902 G.postRedisplay "maxwait";
909 let layout = layout y 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
1001 (if conf
.preload then preloadlayout state
.y else state
.layout)
1004 let gotoy_and_clear_text y =
1005 if not conf
.verbose
then state
.text <- E.s;
1009 let getanchory (n, top
, dtop
) =
1010 let y, h = getpageyh
n in
1011 if conf
.presentation
1013 let ips = calcips
h in
1014 y + truncate
(top
*.float h -. dtop
*.float ips) + ips;
1016 y + truncate
(top
*.float h -. dtop
*.float conf
.interpagespace
)
1019 let gotoanchor anchor
=
1020 gotoy (getanchory anchor
);
1024 cbput state
.hists
.nav
(getanchor
());
1028 let anchor = cbgetc state
.hists
.nav dir
in
1032 let gotoghyll1 single
y =
1033 let scroll f n a
b =
1034 (* http://devmaster.net/forums/topic/9796-ease-in-ease-out-algorithm/ *)
1036 let s x = 3.0*.x**2.0 -. 2.0*.x**3.0 in
1038 then s (float f /. float a
)
1041 then 1.0 -. s ((float (f-b) /. float (n-b)))
1047 let ins = float a
*. 0.5
1048 and outs
= float (n-b) *. 0.5 in
1050 ins +. outs
+. float ones
1052 let rec set nab
y sy
=
1053 let (_N
, _A
, _B
), y =
1056 let scl = if y > sy
then 2 else -2 in
1057 let _N, _
, _
= nab
in
1058 (_N,0,_N), y+conf
.scrollstep
*scl
1060 let sum = summa
_N _A _B
in
1061 let dy = float (y - sy
) in
1065 then state
.ghyll
<- noghyll
1068 let s = scroll n _N _A _B
in
1069 let y1 = y1 +. ((s *. dy) /. sum) in
1070 gotoy_and_clear_text (truncate
y1);
1071 state
.ghyll
<- gf (n+1) y1;
1075 | Some
y'
when single
-> set nab
y' state
.y
1076 | Some
y'
-> set (_N/2, 1, 1) y' state
.y
1078 gf 0 (float state
.y)
1081 match conf
.ghyllscroll
with
1082 | Some nab
when not conf
.presentation
->
1083 if state
.ghyll
== noghyll
1084 then set nab
y state
.y
1085 else state
.ghyll
(Some
y)
1087 gotoy_and_clear_text y
1090 let gotoghyll = gotoghyll1 false;;
1092 let gotopage n top
=
1093 let y, h = getpageyh
n in
1094 let y = y + (truncate
(top
*. float h)) in
1098 let gotopage1 n top
=
1099 let y = getpagey
n in
1104 let invalidate s f =
1109 match state
.geomcmds
with
1110 | ps
, [] when emptystr ps
->
1112 state
.geomcmds
<- s, [];
1115 state
.geomcmds
<- ps
, [s, f];
1117 | ps
, (s'
, _
) :: rest
when s'
= s ->
1118 state
.geomcmds
<- ps
, ((s, f) :: rest
);
1121 state
.geomcmds
<- ps
, ((s, f) :: cmds
);
1125 Hashtbl.iter
(fun _ opaque
->
1126 wcmd "freepage %s" (~
> opaque
);
1128 Hashtbl.clear state
.pagemap
;
1132 if not
(Queue.is_empty state
.tilelru
)
1134 Queue.iter
(fun (k
, p
, s) ->
1135 wcmd "freetile %s" (~
> p
);
1136 state
.memused
<- state
.memused
- s;
1137 Hashtbl.remove state
.tilemap k
;
1139 state
.uioh#infochanged Memused
;
1140 Queue.clear state
.tilelru
;
1146 let h = truncate
(float h*.conf
.zoom
) in
1147 let d = conf
.interpagespace
lsl (if conf
.presentation
then 1 else 0) in
1151 let opendoc path password
=
1153 state
.password
<- password
;
1154 state
.gen
<- state
.gen
+ 1;
1155 state
.docinfo
<- [];
1156 state
.outlines
<- [||];
1159 setaalevel conf
.aalevel
;
1161 if emptystr state
.origin
1165 Wsi.settitle
("llpp " ^
(mbtoutf8
(Filename.basename
titlepath)));
1166 wcmd "open %d %d %s\000%s\000" (btod
!wtmode) (btod
!cxack) path password
;
1167 invalidate "reqlayout"
1169 wcmd "reqlayout %d %d %d %s\000"
1170 conf
.angle
(FMTE.to_int conf
.fitmodel
)
1171 (stateh state
.winh
) state
.nameddest
1176 state
.anchor <- getanchor
();
1177 opendoc state
.path state
.password
;
1181 let c = c *. conf
.colorscale
in
1185 let scalecolor2 (r
, g, b) =
1186 (r
*. conf
.colorscale
, g *. conf
.colorscale
, b *. conf
.colorscale
);
1189 let docolumns columns
=
1190 let wadj = wadjsb () in
1193 let a = Array.make state
.pagecount
(-1, -1, -1, (-1, -1, -1, -1)) in
1194 let wadj = wadjsb () in
1195 let rec loop pageno
pdimno pdim
y ph pdims
=
1196 if pageno
= state
.pagecount
1199 let pdimno, ((_
, w, h, xoff
) as pdim
), pdims
=
1201 | ((pageno'
, _
, _
, _
) as pdim
) :: rest
when pageno'
= pageno
->
1202 pdimno+1, pdim
, rest
1206 let x = max
0 (((wadj + state
.winw
- w) / 2) - xoff
) in
1208 (if conf
.presentation
1209 then (if pageno
= 0 then calcips
h else calcips ph
+ calcips
h)
1210 else (if pageno
= 0 then 0 else conf
.interpagespace
)
1213 a.(pageno
) <- (pdimno, x, y, pdim
);
1214 loop (pageno
+1) pdimno pdim
(y + h) h pdims
1216 loop 0 ~
-1 (-1,-1,-1,-1) 0 0 state
.pdims
;
1217 conf
.columns
<- Csingle
a;
1219 | Cmulti
((columns
, coverA
, coverB
), _
) ->
1220 let a = Array.make state
.pagecount
(-1, -1, -1, (-1, -1, -1, -1)) in
1221 let rec loop pageno
pdimno pdim
x y rowh pdims
=
1222 let rec fixrow m
= if m
= pageno
then () else
1223 let (pdimno, x, y, ((_
, _
, h, _
) as pdim
)) = a.(m
) in
1226 let y = y + (rowh
- h) / 2 in
1227 a.(m
) <- (pdimno, x, y, pdim
);
1231 if pageno
= state
.pagecount
1232 then fixrow (((pageno
- 1) / columns
) * columns
)
1234 let pdimno, ((_
, w, h, xoff
) as pdim
), pdims
=
1236 | ((pageno'
, _
, _
, _
) as pdim
) :: rest
when pageno'
= pageno
->
1237 pdimno+1, pdim
, rest
1242 if pageno
= coverA
- 1 || pageno
= state
.pagecount
- coverB
1244 let x = (wadj + state
.winw
- w) / 2 in
1246 if conf
.presentation
then calcips
h else conf
.interpagespace
in
1247 x, y + ips + rowh
, h
1250 if (pageno
- coverA
) mod columns
= 0
1252 let x = max
0 (wadj + state
.winw
- state
.w) / 2 in
1254 if conf
.presentation
1256 let ips = calcips
h in
1257 y + (if pageno
= 0 then 0 else calcips rowh
+ ips)
1259 y + (if pageno
= 0 then 0 else conf
.interpagespace
)
1263 else x, y, max rowh
h
1267 if pageno
> 1 && (pageno
- coverA
) mod columns
= 0
1270 if pageno
= columns
&& conf
.presentation
1272 let ips = calcips rowh
in
1273 for i
= 0 to pred columns
1275 let (pdimno, x, y, pdim
) = a.(i
) in
1276 a.(i
) <- (pdimno, x, y+ips, pdim
)
1282 fixrow (pageno
- columns
);
1287 a.(pageno
) <- (pdimno, x, y, pdim
);
1288 let x = x + w + xoff
*2 + conf
.interpagespace
in
1289 loop (pageno
+1) pdimno pdim
x y rowh' pdims
1291 loop 0 ~
-1 (-1,-1,-1,-1) 0 0 0 state
.pdims
;
1292 conf
.columns
<- Cmulti
((columns
, coverA
, coverB
), a);
1295 let a = Array.make
(state
.pagecount
*c) (-1, -1, -1, (-1, -1, -1, -1)) in
1296 let rec loop pageno
pdimno pdim
y pdims
=
1297 if pageno
= state
.pagecount
1300 let pdimno, ((_
, w, h, _
) as pdim
), pdims
=
1302 | ((pageno'
, _
, _
, _
) as pdim
) :: rest
when pageno'
= pageno
->
1303 pdimno+1, pdim
, rest
1308 let rec loop1 n x y =
1309 if n = c then y else (
1310 a.(pageno
*c + n) <- (pdimno, x, y, pdim
);
1311 loop1 (n+1) (x+cw) (y + h + conf
.interpagespace
)
1314 let y = loop1 0 0 y in
1315 loop (pageno
+1) pdimno pdim
y pdims
1317 loop 0 ~
-1 (-1,-1,-1,-1) 0 state
.pdims
;
1318 conf
.columns
<- Csplit
(c, a);
1322 docolumns conf
.columns
;
1323 state
.maxy
<- calcheight
();
1324 if state
.reprf
== noreprf
1326 match state
.mode
with
1327 | Birdseye
(_
, _
, pageno
, _
, _
) ->
1328 let y, h = getpageyh pageno
in
1329 let top = (state
.winh
- h) / 2 in
1330 gotoy (max
0 (y - top))
1333 | LinkNav _
-> gotoanchor state
.anchor
1337 state
.reprf
<- noreprf
;
1341 let reshape ?
(firsttime
=false) w h =
1342 GlDraw.viewport ~
x:0 ~
y:0 ~
w:w ~
h:h;
1343 if not firsttime
&& nogeomcmds state
.geomcmds
1344 then state
.anchor <- getanchor
();
1347 let w = wadjsb () + (truncate
(float w *. conf
.zoom
)) in
1350 setfontsize fstate
.fontsize
;
1351 GlMat.mode `modelview
;
1352 GlMat.load_identity
();
1354 GlMat.mode `projection
;
1355 GlMat.load_identity
();
1356 GlMat.rotate ~
x:1.0 ~angle
:180.0 ();
1357 GlMat.translate ~
x:~
-.1.0 ~
y:~
-.1.0 ();
1358 GlMat.scale3
(2.0 /. float state
.winw
, 2.0 /. float state
.winh
, 1.0);
1363 else float state
.x /. float state
.w
1365 invalidate "geometry"
1369 then state
.x <- truncate
(relx *. float w);
1371 match conf
.columns
with
1373 | Cmulti
((c, _
, _
), _
) -> (w - (c-1)*conf
.interpagespace
) / c
1374 | Csplit
(c, _
) -> w * c
1376 wcmd "geometry %d %d %d"
1377 w (stateh h) (FMTE.to_int conf
.fitmodel
)
1382 let len = String.length state
.text in
1383 let x0 = xadjsb () in
1386 match state
.mode
with
1387 | Textentry _
| View
| LinkNav _
->
1388 let h, _
, _
= state
.uioh#scrollpw
in
1393 filledrect x (float (state
.winh
- (fstate
.fontsize
+ 4) - hscrollh))
1394 (x+.w) (float (state
.winh
- hscrollh))
1397 let w = float (wadjsb () + state
.winw
- 1) in
1398 if state
.progress
>= 0.0 && state
.progress
< 1.0
1400 GlDraw.color (0.3, 0.3, 0.3);
1401 let w1 = w *. state
.progress
in
1403 GlDraw.color (0.0, 0.0, 0.0);
1404 rect (float x0+.w1) (float x0+.w-.w1)
1407 GlDraw.color (0.0, 0.0, 0.0);
1411 GlDraw.color (1.0, 1.0, 1.0);
1412 drawstring fstate
.fontsize
1413 (if conf
.leftscroll
then x0 + 2 else x0 + if len > 0 then 8 else 2)
1414 (state
.winh
- hscrollh - 5) s;
1417 match state
.mode
with
1418 | Textentry
((prefix
, text, _
, _
, _
, _
), _
) ->
1422 Printf.sprintf
"%s%s_ [%s]" prefix
text state
.text
1424 Printf.sprintf
"%s%s_" prefix
text
1430 | LinkNav _
-> state
.text
1435 if not
(istextentry state
.mode
) && state
.uioh#eformsgs
1437 let s1 = "(press 'e' to review error messasges)" in
1438 if nonemptystr
s then s ^
" " ^
s1 else s1
1448 let len = Queue.length state
.tilelru
in
1450 match state
.throttle
with
1453 then preloadlayout state
.y
1455 | Some
(layout, _
, _
) ->
1459 if state
.memused
<= conf
.memlimit
1464 let (k
, p
, s) as lruitem
= Queue.pop state
.tilelru
in
1465 let n, gen
, colorspace
, angle
, pagew
, pageh
, col, row = k
in
1466 let (_
, pw, ph
, _
) = getpagedim
n in
1469 && colorspace
= conf
.colorspace
1470 && angle
= conf
.angle
1474 let x = col*conf
.tilew
1475 and y = row*conf
.tileh
in
1476 tilevisible (Lazy.force_val
layout) n x y
1478 then Queue.push lruitem state
.tilelru
1481 wcmd "freetile %s" (~
> p
);
1482 state
.memused
<- state
.memused
- s;
1483 state
.uioh#infochanged Memused
;
1484 Hashtbl.remove state
.tilemap k
;
1492 let onpagerect pageno
f =
1494 match conf
.columns
with
1495 | Cmulti
(_
, b) -> b
1497 | Csplit
(_
, b) -> b
1499 if pageno
>= 0 && pageno
< Array.length
b
1501 let (_
, _
, _
, (_
, w, h, _
)) = b.(pageno
) in
1505 let gotopagexy1 pageno
x y =
1506 let _,w1,h1
,leftx
= getpagedim pageno
in
1507 let top = y /. (float h1
) in
1508 let left = x /. (float w1) in
1509 let py, w, h = getpageywh pageno
in
1510 let wh = state
.winh
- hscrollh () in
1511 let x = left *. (float w) in
1512 let x = leftx
+ state
.x + truncate
x in
1513 let wadj = wadjsb () in
1515 if x < 0 || x >= wadj + state
.winw
1519 let pdy = truncate
(top *. float h) in
1520 let y'
= py + pdy in
1521 let dy = y'
- state
.y in
1523 if x != state
.x || not
(dy > 0 && dy < wh)
1525 if conf
.presentation
1527 if abs
(py - y'
) > wh
1534 if state
.x != sx || state
.y != sy
1539 let ww = wadj + state
.winw
in
1541 and qy
= pdy / wh in
1543 and y = py + qy
* wh in
1544 let x = if -x + ww > w1 then -(w1-ww) else x
1545 and y'
= if y + wh > state
.maxy
then state
.maxy
- wh else y in
1547 if conf
.presentation
1549 if abs
(py - y'
) > wh
1559 gotoy_and_clear_text y;
1561 else gotoy_and_clear_text state
.y;
1564 let gotopagexy pageno
x y =
1565 match state
.mode
with
1566 | Birdseye
_ -> gotopage pageno
0.0
1569 | LinkNav
_ -> gotopagexy1 pageno
x y
1572 let getpassword () =
1573 let passcmd = getenvwithdef
"LLPP_ASKPASS" conf
.passcmd in
1578 impmsg "error getting password: %s" s;
1579 dolog
"%s" s) passcmd;
1582 let pgoto pageno
x y =
1583 let pdimno = getpdimno pageno
in
1584 let x, y = project pageno
pdimno x y in
1585 gotopagexy pageno
x y;
1589 (* dolog "%S" cmds; *)
1590 let cl = splitatspace cmds
in
1592 try Scanf.sscanf
s fmt
f
1594 dolog
"error processing '%S': %s" cmds
@@ exntos exn
;
1597 let addoutline outline
=
1598 match state
.currently
with
1599 | Outlining outlines
->
1600 state
.currently
<- Outlining
(outline
:: outlines
)
1601 | Idle
-> state
.currently
<- Outlining
[outline
]
1604 dolog
"invalid outlining state";
1605 logcurrently state
.currently
1609 state
.uioh#infochanged Pdim
;
1612 | "clearrects" :: [] ->
1613 state
.rects
<- state
.rects1
;
1614 G.postRedisplay "clearrects";
1616 | "continue" :: args
:: [] ->
1617 let n = scan args
"%u" (fun n -> n) in
1618 state
.pagecount
<- n;
1619 begin match state
.currently
with
1621 state
.currently
<- Idle
;
1622 state
.outlines
<- Array.of_list
(List.rev
l)
1628 let cur, cmds
= state
.geomcmds
in
1630 then failwith
"umpossible";
1632 begin match List.rev cmds
with
1634 state
.geomcmds
<- E.s, [];
1635 state
.throttle
<- None
;
1639 state
.geomcmds
<- s, List.rev rest
;
1641 if conf
.maxwait
= None
&& not
!wtmode
1642 then G.postRedisplay "continue";
1644 | "msg" :: args
:: [] ->
1647 | "vmsg" :: args
:: [] ->
1649 then showtext ' ' args
1651 | "emsg" :: args
:: [] ->
1652 Buffer.add_string state
.errmsgs args
;
1653 state
.newerrmsgs
<- true;
1654 G.postRedisplay "error message"
1656 | "progress" :: args
:: [] ->
1657 let progress, text =
1660 f, String.sub args pos
(String.length args
- pos
))
1663 state
.progress <- progress;
1664 G.postRedisplay "progress"
1666 | "firstmatch" :: args
:: [] ->
1667 let pageno, c, x0, y0, x1, y1, x2
, y2
, x3
, y3
=
1668 scan args
"%u %d %f %f %f %f %f %f %f %f"
1669 (fun p
c x0 y0 x1 y1 x2 y2 x3 y3
->
1670 (p
, c, x0, y0, x1, y1, x2
, y2
, x3
, y3
))
1672 let xoff = float (xadjsb ()) in
1676 and x3
= x3
+. xoff in
1677 let y = (getpagey
pageno) + truncate
y0 in
1680 let color = (0.0, 0.0, 1.0 /. float c, 0.5) in
1681 state
.rects1
<- [pageno, color, (x0, y0, x1, y1, x2
, y2
, x3
, y3
)]
1683 | "match" :: args
:: [] ->
1684 let pageno, c, x0, y0, x1, y1, x2
, y2
, x3
, y3
=
1685 scan args
"%u %d %f %f %f %f %f %f %f %f"
1686 (fun p
c x0 y0 x1 y1 x2 y2 x3 y3
->
1687 (p
, c, x0, y0, x1, y1, x2
, y2
, x3
, y3
))
1689 let xoff = float (xadjsb ()) in
1693 and x3
= x3
+. xoff in
1694 let color = (0.0, 0.0, 1.0 /. float c, 0.5) in
1696 (pageno, color, (x0, y0, x1, y1, x2
, y2
, x3
, y3
)) :: state
.rects1
1698 | "page" :: args
:: [] ->
1699 let pageopaques, t
= scan args
"%s %f" (fun p t
-> p
, t
) in
1700 let pageopaque = ~
< pageopaques in
1701 begin match state
.currently
with
1702 | Loading
(l, gen
) ->
1703 vlog "page %d took %f sec" l.pageno t
;
1704 Hashtbl.replace state
.pagemap
(l.pageno, gen
) pageopaque;
1705 begin match state
.throttle
with
1707 let preloadedpages =
1709 then preloadlayout state
.y
1714 List.fold_left
(fun s l -> IntSet.add
l.pageno s)
1715 IntSet.empty
preloadedpages
1718 Hashtbl.fold (fun ((pageno, _) as key) opaque
accu ->
1719 if not
(IntSet.mem
pageno set)
1721 wcmd "freepage %s" (~
> opaque
);
1727 List.iter
(Hashtbl.remove state
.pagemap
) evictedpages;
1730 state
.currently
<- Idle
;
1733 tilepage l.pageno pageopaque state
.layout;
1735 load preloadedpages;
1736 let visible = pagevisible state
.layout l.pageno in
1739 match state
.mode
with
1740 | LinkNav
(Ltnotready
(pageno, dir
)) ->
1741 if pageno = l.pageno
1746 then LDfirstvisible
(l.pagex
, l.pagey, dir
)
1748 if dir
> 0 then LDfirst
else LDlast
1751 findlink
pageopaque ld
1756 showlinktype (getlink
pageopaque n);
1757 state
.mode
<- LinkNav
(Ltexact
(l.pageno, n))
1759 | LinkNav
(Ltgendir
_)
1760 | LinkNav
(Ltexact
_)
1766 if visible && layoutready state
.layout
1768 G.postRedisplay "page";
1772 | Some
(layout, _, _) ->
1773 state
.currently
<- Idle
;
1774 tilepage l.pageno pageopaque layout;
1781 dolog
"Inconsistent loading state";
1782 logcurrently state
.currently
;
1786 | "tile" :: args
:: [] ->
1787 let (x, y, opaques
, size
, t
) =
1788 scan args
"%u %u %s %u %f"
1789 (fun x y p size t
-> (x, y, p
, size
, t
))
1791 let opaque = ~
< opaques
in
1792 begin match state
.currently
with
1793 | Tiling
(l, pageopaque, cs
, angle
, gen
, col, row, tilew
, tileh
) ->
1794 vlog "tile %d [%d,%d] took %f sec" l.pageno col row t
;
1797 if tilew
!= conf
.tilew
|| tileh
!= conf
.tileh
1799 wcmd "freetile %s" (~
> opaque);
1800 state
.currently
<- Idle
;
1804 puttileopaque l col row gen cs angle
opaque size t
;
1805 state
.memused
<- state
.memused
+ size
;
1806 state
.uioh#infochanged Memused
;
1808 Queue.push
((l.pageno, gen
, cs
, angle
, l.pagew
, l.pageh
, col, row),
1809 opaque, size
) state
.tilelru
;
1812 match state
.throttle
with
1813 | None
-> state
.layout
1814 | Some
(layout, _, _) -> layout
1817 state
.currently
<- Idle
;
1819 && conf
.colorspace
= cs
1820 && conf
.angle
= angle
1821 && tilevisible layout l.pageno x y
1822 then conttiling l.pageno pageopaque;
1824 begin match state
.throttle
with
1826 preload state
.layout;
1828 && conf
.colorspace
= cs
1829 && conf
.angle
= angle
1830 && tilevisible state
.layout l.pageno x y
1831 && (not
!wtmode || layoutready state
.layout)
1832 then G.postRedisplay "tile nothrottle";
1834 | Some
(layout, y, _) ->
1835 let ready = layoutready layout in
1839 state
.layout <- layout;
1840 state
.throttle
<- None
;
1841 G.postRedisplay "throttle";
1850 dolog
"Inconsistent tiling state";
1851 logcurrently state
.currently
;
1855 | "pdim" :: args
:: [] ->
1856 let (n, w, h, _) as pdim
=
1857 scan args
"%u %u %u %u" (fun n w h x -> n, w, h, x)
1860 match conf
.fitmodel
with
1862 | FitPage
| FitProportional
->
1863 match conf
.columns
with
1864 | Csplit
_ -> (n, w, h, 0)
1865 | Csingle
_ | Cmulti
_ -> pdim
1867 state
.uioh#infochanged Pdim
;
1868 state
.pdims
<- pdim :: state
.pdims
1870 | "o" :: args
:: [] ->
1871 let (l, n, t
, h, pos
) =
1872 scan args
"%u %u %d %u %n"
1873 (fun l n t
h pos
-> l, n, t
, h, pos
)
1875 let s = String.sub args pos
(String.length args
- pos
) in
1876 addoutline (s, l, Oanchor
(n, float t
/. float h, 0.0))
1878 | "ou" :: args
:: [] ->
1879 let (l, len, pos
) = scan args
"%u %u %n" (fun l len pos
-> l, len, pos
) in
1880 let s = String.sub args pos
len in
1881 let pos2 = pos
+ len + 1 in
1882 let uri = String.sub args
pos2 (String.length args
- pos2) in
1883 addoutline (s, l, Ouri
uri)
1885 | "on" :: args
:: [] ->
1886 let (l, pos
) = scan args
"%u %n" (fun l pos
-> l, pos
) in
1887 let s = String.sub args pos
(String.length args
- pos
) in
1888 addoutline (s, l, Onone
)
1890 | "a" :: args
:: [] ->
1892 scan args
"%u %d %d" (fun n l t
-> n, l, t
)
1894 state
.reprf
<- (fun () -> gotopagexy n (float l) (float t
))
1896 | "info" :: args
:: [] ->
1897 let pos = nindex args '
\t'
in
1898 if pos >= 0 && String.sub args
0 pos = "Title"
1900 let s = String.sub args
(pos+1) @@ String.length args
- pos - 1 in
1904 state
.docinfo
<- (1, args
) :: state
.docinfo
1906 | "infoend" :: [] ->
1907 state
.uioh#infochanged Docinfo
;
1908 state
.docinfo
<- List.rev state
.docinfo
1912 then Wsi.settitle
"Wrong password";
1913 let password = getpassword () in
1914 if emptystr
password
1915 then error
"document is password protected"
1916 else opendoc state
.path
password
1918 error
"unknown cmd `%S'" cmds
1923 let action = function
1924 | HCprev
-> cbget cb ~
-1
1925 | HCnext
-> cbget cb
1
1926 | HCfirst
-> cbget cb ~
-(cb
.rc)
1927 | HClast
-> cbget cb
(cb
.len - 1 - cb
.rc)
1928 and cancel
() = cb
.rc <- rc
1932 let search pattern forward
=
1933 match conf
.columns
with
1934 | Csplit
_ -> impmsg "searching does not work properly in split columns mode"
1937 if nonemptystr pattern
1940 match state
.layout with
1943 l.pageno, (l.pagey + if forward
then 0 else 0*l.pagevh)
1945 wcmd "search %d %d %d %d,%s\000"
1946 (btod conf
.icase
) pn py (btod forward
) pattern
;
1949 let intentry text key =
1951 if key >= 32 && key < 127
1957 let text = addchar
text c in
1961 state
.text <- Printf.sprintf
"invalid char (%d, `%c')" key c;
1969 let l = String.length
s in
1970 let rec loop pos n = if pos = l then n else
1971 let m = Char.code
s.[pos] - (if pos = 0 && l > 1 then 96 else 97) in
1972 loop (pos+1) (n*26 + m)
1975 let rec loop n = function
1978 match getopaque l.pageno with
1979 | None
-> loop n rest
1981 let m = getlinkcount
opaque in
1984 let under = getlink
opaque n in
1987 else loop (n-m) rest
1989 loop n state
.layout;
1993 let linknentry text key =
1995 if key >= 32 && key < 127
2001 let text = addchar
text c in
2002 linknact (fun under -> state
.text <- undertext ~nopath
:true under) text;
2006 state
.text <- Printf.sprintf
"invalid char (%d, `%c')" key c;
2010 let textentry text key =
2011 if key land 0xff00 = 0xff00
2013 else TEcont
(text ^ toutf8
key)
2016 let reqlayout angle fitmodel
=
2017 match state
.throttle
with
2019 if nogeomcmds state
.geomcmds
2020 then state
.anchor <- getanchor
();
2021 conf
.angle
<- angle
mod 360;
2024 match state
.mode
with
2025 | LinkNav
_ -> state
.mode
<- View
2030 conf
.fitmodel
<- fitmodel
;
2031 invalidate "reqlayout"
2033 wcmd "reqlayout %d %d %d"
2034 conf
.angle
(FMTE.to_int conf
.fitmodel
) (stateh state
.winh
)
2039 let settrim trimmargins trimfuzz
=
2040 if nogeomcmds state
.geomcmds
2041 then state
.anchor <- getanchor
();
2042 conf
.trimmargins
<- trimmargins
;
2043 conf
.trimfuzz
<- trimfuzz
;
2044 let x0, y0, x1, y1 = trimfuzz
in
2045 invalidate "settrim"
2047 wcmd "settrim %d %d %d %d %d" (btod conf
.trimmargins
) x0 y0 x1 y1);
2052 match state
.throttle
with
2054 let zoom = max
0.0001 zoom in
2055 if zoom <> conf
.zoom
2057 state
.prevzoom
<- (conf
.zoom, state
.x);
2059 reshape state
.winw state
.winh
;
2060 state
.text <- Printf.sprintf
"zoom is now %-5.2f" (zoom *. 100.0);
2063 | Some
(layout, y, started
) ->
2065 match conf
.maxwait
with
2069 let dt = now
() -. started
in
2077 let setcolumns mode columns coverA coverB
=
2078 state
.prevcolumns
<- Some
(conf
.columns
, conf
.zoom);
2082 then impmsg "split mode doesn't work in bird's eye"
2084 conf
.columns
<- Csplit
(-columns
, E.a);
2092 conf
.columns
<- Csingle
E.a;
2097 conf
.columns
<- Cmulti
((columns
, coverA
, coverB
), E.a);
2101 reshape state
.winw state
.winh
;
2104 let resetmstate () =
2105 state
.mstate
<- Mnone
;
2106 Wsi.setcursor
Wsi.CURSOR_INHERIT
;
2109 let enterbirdseye () =
2110 let zoom = float conf
.thumbw
/. float state
.winw
in
2111 let birdseyepageno =
2112 let cy = state
.winh
/ 2 in
2116 let rec fold best
= function
2119 let d = cy - (l.pagedispy + l.pagevh/2)
2120 and dbest
= cy - (best
.pagedispy + best
.pagevh/2) in
2121 if abs
d < abs dbest
2128 state
.mode
<- Birdseye
(
2129 { conf
with zoom = conf
.zoom }, state
.x, birdseyepageno, -1, getanchor
()
2133 conf
.presentation
<- false;
2134 conf
.interpagespace
<- 10;
2135 conf
.hlinks
<- false;
2136 conf
.fitmodel
<- FitPage
;
2138 conf
.maxwait
<- None
;
2140 match conf
.beyecolumns
with
2143 Cmulti
((c, 0, 0), E.a)
2144 | None
-> Csingle
E.a
2148 state
.text <- Printf.sprintf
"birds eye mode on (zoom %3.1f%%)"
2153 reshape state
.winw state
.winh
;
2156 let leavebirdseye (c, leftx
, pageno, _, anchor) goback
=
2158 conf
.zoom <- c.zoom;
2159 conf
.presentation
<- c.presentation
;
2160 conf
.interpagespace
<- c.interpagespace
;
2161 conf
.maxwait
<- c.maxwait
;
2162 conf
.hlinks
<- c.hlinks
;
2163 conf
.fitmodel
<- c.fitmodel
;
2164 conf
.beyecolumns
<- (
2165 match conf
.columns
with
2166 | Cmulti
((c, _, _), _) -> Some
c
2168 | Csplit
_ -> failwith
"leaving bird's eye split mode"
2171 match c.columns
with
2172 | Cmulti
(c, _) -> Cmulti
(c, E.a)
2173 | Csingle
_ -> Csingle
E.a
2174 | Csplit
(c, _) -> Csplit
(c, E.a)
2178 state
.text <- Printf.sprintf
"birds eye mode off (zoom %3.1f%%)"
2181 reshape state
.winw state
.winh
;
2182 state
.anchor <- if goback
then anchor else (pageno, 0.0, 1.0);
2186 let togglebirdseye () =
2187 match state
.mode
with
2188 | Birdseye vals
-> leavebirdseye vals
true
2189 | View
-> enterbirdseye ()
2194 let upbirdseye incr
(conf
, leftx
, pageno, hooverpageno
, anchor) =
2195 let pageno = max
0 (pageno - incr
) in
2196 let rec loop = function
2197 | [] -> gotopage1 pageno 0
2198 | l :: _ when l.pageno = pageno ->
2199 if l.pagedispy >= 0 && l.pagey = 0
2200 then G.postRedisplay "upbirdseye"
2201 else gotopage1 pageno 0
2202 | _ :: rest
-> loop rest
2206 state
.mode
<- Birdseye
(conf
, leftx
, pageno, hooverpageno
, anchor)
2209 let downbirdseye incr
(conf
, leftx
, pageno, hooverpageno
, anchor) =
2210 let pageno = min
(state
.pagecount
- 1) (pageno + incr
) in
2211 state
.mode
<- Birdseye
(conf
, leftx
, pageno, hooverpageno
, anchor);
2212 let rec loop = function
2214 let y, h = getpageyh
pageno in
2215 let dy = (y - state
.y) - (state
.winh
- h - conf
.interpagespace
) in
2217 | l :: _ when l.pageno = pageno ->
2218 if l.pagevh != l.pageh
2219 then gotoy (clamp (l.pageh
- l.pagevh + conf
.interpagespace
))
2220 else G.postRedisplay "downbirdseye"
2221 | _ :: rest
-> loop rest
2227 let optentry mode
_ key =
2228 let btos b = if b then "on" else "off" in
2229 if key >= 32 && key < 127
2231 let c = Char.chr
key in
2235 try conf
.scrollstep
<- int_of_string
s with exc
->
2236 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exc
2238 TEswitch
("scroll step: ", E.s, None
, intentry, ondone, true)
2243 conf
.autoscrollstep
<- boundastep state
.winh
(int_of_string
s);
2244 if state
.autoscroll
<> None
2245 then state
.autoscroll
<- Some conf
.autoscrollstep
2247 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exc
2249 TEswitch
("auto scroll step: ", E.s, None
, intentry, ondone, true)
2254 let n, a, b = multicolumns_of_string
s in
2255 setcolumns mode
n a b;
2257 state
.text <- Printf.sprintf
"bad columns `%s': %s" s @@ exntos exc
2259 TEswitch
("columns: ", E.s, None
, textentry, ondone, true)
2264 let zoom = float (int_of_string
s) /. 100.0 in
2267 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exc
2269 TEswitch
("zoom: ", E.s, None
, intentry, ondone, true)
2274 conf
.thumbw
<- bound
(int_of_string
s) 2 4096;
2276 Printf.sprintf
"thumbnail width is set to %d" conf
.thumbw
;
2277 begin match mode
with
2279 leavebirdseye beye
false;
2286 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exc
2288 TEswitch
("thumbnail width: ", E.s, None
, intentry, ondone, true)
2293 Some
(int_of_string
s)
2296 Printf.sprintf
"bad integer `%s': %s" s @@ exntos exc
;
2299 | Some angle
-> reqlayout angle conf
.fitmodel
2302 TEswitch
("rotation: ", E.s, None
, intentry, ondone, true)
2305 conf
.icase
<- not conf
.icase
;
2306 TEdone
("case insensitive search " ^
(btos conf
.icase
))
2309 conf
.preload <- not conf
.preload;
2311 TEdone
("preload " ^
(btos conf
.preload))
2314 conf
.verbose
<- not conf
.verbose
;
2315 TEdone
("verbose " ^
(btos conf
.verbose
))
2318 conf
.debug
<- not conf
.debug
;
2319 TEdone
("debug " ^
(btos conf
.debug
))
2322 conf
.maxhfit
<- not conf
.maxhfit
;
2323 state
.maxy
<- calcheight
();
2324 TEdone
("maxhfit " ^
(btos conf
.maxhfit
))
2327 conf
.crophack
<- not conf
.crophack
;
2328 TEdone
("crophack " ^
btos conf
.crophack
)
2332 match conf
.maxwait
with
2334 conf
.maxwait
<- Some infinity
;
2335 "always wait for page to complete"
2337 conf
.maxwait
<- None
;
2338 "show placeholder if page is not ready"
2343 conf
.underinfo
<- not conf
.underinfo
;
2344 TEdone
("underinfo " ^
btos conf
.underinfo
)
2347 conf
.savebmarks
<- not conf
.savebmarks
;
2348 TEdone
("persistent bookmarks " ^
btos conf
.savebmarks
)
2354 match state
.layout with
2359 conf
.interpagespace
<- int_of_string
s;
2360 docolumns conf
.columns
;
2361 state
.maxy
<- calcheight
();
2362 let y = getpagey
pageno in
2365 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exc
2367 TEswitch
("vertical margin: ", E.s, None
, intentry, ondone, true)
2371 match conf
.fitmodel
with
2372 | FitProportional
-> FitWidth
2373 | FitWidth
| FitPage
-> FitProportional
2375 reqlayout conf
.angle
fm;
2376 TEdone
("proportional display " ^
btos (fm == FitProportional
))
2379 settrim (not conf
.trimmargins
) conf
.trimfuzz
;
2380 TEdone
("trim margins " ^
btos conf
.trimmargins
)
2383 conf
.invert
<- not conf
.invert
;
2384 TEdone
("invert colors " ^
btos conf
.invert
)
2388 cbput state
.hists
.sel
s;
2391 TEswitch
("selection command: ", E.s, Some
(onhist state
.hists
.sel
),
2392 textentry, ondone, true)
2396 then conf
.pax
<- Some
(ref (0.0, 0, 0))
2397 else conf
.pax
<- None
;
2398 TEdone
("PAX " ^
btos (conf
.pax
!= None
))
2401 state
.text <- Printf.sprintf
"bad option %d `%c'" key c;
2407 class type lvsource
= object
2408 method getitemcount
: int
2409 method getitem
: int -> (string * int)
2410 method hasaction
: int -> bool
2418 method getactive
: int
2419 method getfirst
: int
2421 method getminfo
: (int * int) array
2424 class virtual lvsourcebase
= object
2425 val mutable m_active
= 0
2426 val mutable m_first
= 0
2427 val mutable m_pan
= 0
2428 method getactive
= m_active
2429 method getfirst
= m_first
2430 method getpan
= m_pan
2431 method getminfo
: (int * int) array
= E.a
2434 let textentrykeyboard
2435 key _mask
((c, text, opthist
, onkey
, ondone, cancelonempty
), onleave
) =
2438 if key >= 0xffb0 && key <= 0xffb9
2439 then key - 0xffb0 + 48 else key
2442 state
.mode
<- Textentry
(te
, onleave
);
2444 G.postRedisplay "textentrykeyboard enttext";
2446 let histaction cmd
=
2449 | Some
(action, _) ->
2450 state
.mode
<- Textentry
(
2451 (c, action cmd
, opthist
, onkey
, ondone, cancelonempty
), onleave
2453 G.postRedisplay "textentry histaction"
2457 if emptystr
text && cancelonempty
2460 G.postRedisplay "textentrykeyboard after cancel";
2463 let s = withoutlastutf8
text in
2464 enttext (c, s, opthist
, onkey
, ondone, cancelonempty
)
2466 | @enter
| @kpenter
->
2469 G.postRedisplay "textentrykeyboard after confirm"
2471 | @up
| @kpup
-> histaction HCprev
2472 | @down
| @kpdown
-> histaction HCnext
2473 | @home
| @kphome
-> histaction HCfirst
2474 | @jend
| @kpend
-> histaction HClast
2479 begin match opthist
with
2481 | Some
(_, onhistcancel
) -> onhistcancel
()
2485 G.postRedisplay "textentrykeyboard after cancel2"
2488 enttext (c, E.s, opthist
, onkey
, ondone, cancelonempty
)
2491 | @delete
| @kpdelete
-> ()
2494 && key land 0xff00 != 0xff00 (* keyboard *)
2495 && key land 0xfe00 != 0xfe00 (* xkb *)
2496 && key land 0xfd00 != 0xfd00 (* 3270 *)
2498 begin match onkey
text key with
2502 G.postRedisplay "textentrykeyboard after confirm2";
2505 enttext (c, text, opthist
, onkey
, ondone, cancelonempty
);
2509 G.postRedisplay "textentrykeyboard after cancel3"
2512 state
.mode
<- Textentry
(te
, onleave
);
2513 G.postRedisplay "textentrykeyboard switch";
2517 vlog "unhandled key %s" (Wsi.keyname
key)
2520 let firstof first active
=
2521 if first
> active
|| abs
(first
- active
) > fstate
.maxrows
- 1
2522 then max
0 (active
- (fstate
.maxrows
/2))
2526 let calcfirst first active
=
2529 let rows = active
- first
in
2530 if rows > fstate
.maxrows
then active
- fstate
.maxrows
else first
2534 let scrollph y maxy
=
2535 let sh = float (maxy
+ state
.winh
) /. float state
.winh
in
2536 let sh = float state
.winh
/. sh in
2537 let sh = max
sh (float conf
.scrollh
) in
2539 let percent = float y /. float maxy
in
2540 let position = (float state
.winh
-. sh) *. percent in
2543 if position +. sh > float state
.winh
2544 then float state
.winh
-. sh
2550 let coe s = (s :> uioh
);;
2552 class listview ~zebra ~helpmode ~
(source
:lvsource
) ~trusted ~modehash
=
2554 val m_pan
= source#getpan
2555 val m_first
= source#getfirst
2556 val m_active
= source#getactive
2558 val m_prev_uioh
= state
.uioh
2560 method private elemunder
y =
2564 let n = y / (fstate
.fontsize
+1) in
2565 if m_first
+ n < source#getitemcount
2567 if source#hasaction
(m_first
+ n)
2568 then Some
(m_first
+ n)
2575 GlFunc.blend_func ~src
:`src_alpha ~dst
:`one_minus_src_alpha
;
2576 GlDraw.color (0., 0., 0.) ~alpha
:0.85;
2577 filledrect 0. 0. (float state
.winw
) (float state
.winh
);
2578 GlDraw.color (1., 1., 1.);
2579 Gl.enable `texture_2d
;
2580 let fs = fstate
.fontsize
in
2582 let hw = (wadjsb () + xadjsb () + state
.winw
)/3 in
2583 let ww = fstate
.wwidth
in
2584 let tabw = 17.0*.ww in
2585 let itemcount = source#getitemcount
in
2586 let minfo = source#getminfo
in
2589 then float (xadjsb ()), float (state
.winw
- 1)
2590 else 0.0, float (state
.winw
- conf
.scrollbw
- 1)
2592 let xadj = xadjsb () in
2594 if (row - m_first
) > fstate
.maxrows
2597 if row >= 0 && row < itemcount
2599 let (s, level
) = source#getitem
row in
2600 let y = (row - m_first
) * nfs in
2602 (if conf
.leftscroll
then float xadj else 5.0)
2603 +. (float (level
+ m_pan
)) *. ww in
2606 (let c = if row land 1 = 0 then 1.0 else 0.92 in (c,c,c));
2610 Gl.disable `texture_2d
;
2611 let alpha = if source#hasaction
row then 0.9 else 0.3 in
2612 GlDraw.color (1., 1., 1.) ~
alpha;
2613 linerect (x0 +. 1.) (float (y + 1)) (x1) (float (y + fs + 3));
2614 Gl.enable `texture_2d
;
2617 if zebra
&& row land 1 = 1
2621 GlDraw.color (c,c,c);
2622 let drawtabularstring s =
2624 let x'
= truncate
(x0 +. x) in
2625 let pos = nindex
s '
\000'
in
2627 then drawstring1 fs x'
(y+nfs) s
2629 let s1 = String.sub
s 0 pos
2630 and s2
= String.sub
s (pos+1) (String.length
s - pos - 1) in
2635 let s'
= withoutlastutf8
s in
2636 let s = s' ^
"@Uellipsis" in
2637 let w = measurestr
fs s in
2638 if float x'
+. w +. ww < float (hw + x'
)
2643 if float x'
+. ww +. measurestr
fs s1 > float (hw + x'
)
2647 ignore
(drawstring1 fs x'
(y+nfs) s1);
2648 drawstring1 fs (hw + x'
) (y+nfs) s2
2652 let x = if helpmode
&& row > 0 then x +. ww else x in
2653 let tabpos = nindex
s '
\t'
in
2656 let len = String.length
s - tabpos - 1 in
2657 let s1 = String.sub
s 0 tabpos
2658 and s2
= String.sub
s (tabpos + 1) len in
2659 let nx = drawstr x s1 in
2661 let x = x +. (max
tabw sw) in
2664 let len = String.length
s - 2 in
2665 if len > 0 && s.[0] = '
\xc2'
&& s.[1] = '
\xb7'
2667 let s = String.sub
s 2 len in
2668 let x = if not helpmode
then x +. ww else x in
2669 GlDraw.color (1.2, 1.2, 1.2);
2670 let vinc = drawstring1 (fs+fs/4)
2671 (truncate
(x -. ww)) (y+nfs) s in
2672 GlDraw.color (1., 1., 1.);
2673 vinc +. (float fs *. 0.8)
2679 ignore
(drawtabularstring s);
2685 GlDraw.color (1.0, 1.0, 1.0) ~
alpha:0.5;
2686 let xadj = float (xadjsb () + 5) in
2688 if (row - m_first
) > fstate
.maxrows
2691 if row >= 0 && row < itemcount
2693 let (s, level
) = source#getitem
row in
2694 let pos0 = nindex
s '
\000'
in
2695 let y = (row - m_first
) * nfs in
2696 let x = float (level
+ m_pan
) *. ww in
2697 let (first
, last
) = minfo.(row) in
2699 if pos0 > 0 && first
> pos0
2700 then String.sub
s (pos0+1) (first
-pos0-1)
2701 else String.sub
s 0 first
2703 let suffix = String.sub
s first
(last
- first
) in
2704 let w1 = measurestr fstate
.fontsize
prefix in
2705 let w2 = measurestr fstate
.fontsize
suffix in
2706 let x = x +. if conf
.leftscroll
then xadj else 5.0 in
2707 let x = if pos0 > 0 && first
> pos0 then x +. float hw else x in
2709 and y0 = float (y+2) in
2711 and y1 = float (y+fs+3) in
2712 filledrect x0 y0 x1 y1;
2717 Gl.disable `texture_2d
;
2718 if Array.length
minfo > 0 then loop m_first
;
2721 method updownlevel incr
=
2722 let len = source#getitemcount
in
2724 if m_active
>= 0 && m_active
< len
2725 then snd
(source#getitem m_active
)
2729 if i
= len then i
-1 else if i
= -1 then 0 else
2730 let _, l = source#getitem i
in
2731 if l != curlevel then i
else flow (i
+incr
)
2733 let active = flow m_active
in
2734 let first = calcfirst m_first
active in
2735 G.postRedisplay "outline updownlevel";
2736 {< m_active
= active; m_first
= first >}
2738 method private key1
key mask
=
2739 let set1 active first qsearch
=
2740 coe {< m_active
= active; m_first
= first; m_qsearch
= qsearch
>}
2742 let search active pattern incr
=
2743 let active = if active = -1 then m_first
else active in
2746 if n >= 0 && n < source#getitemcount
2748 let s, _ = source#getitem
n in
2749 match Str.search_forward re
s 0 with
2750 | (exception Not_found
) -> loop (n + incr
)
2757 Str.regexp_case_fold pattern
|> dosearch
2759 let itemcount = source#getitemcount
in
2760 let find start incr
=
2762 if i
= -1 || i
= itemcount
2765 if source#hasaction i
2767 else find (i
+ incr
)
2772 let set active first =
2773 let first = bound
first 0 (itemcount - fstate
.maxrows
) in
2775 coe {< m_active
= active; m_first
= first; m_qsearch
= E.s >}
2778 let isvisible first n = n >= first && n - first <= fstate
.maxrows
in
2780 let incr1 = if incr
> 0 then 1 else -1 in
2781 if isvisible m_first m_active
2784 let next = m_active
+ incr
in
2786 if next < 0 || next >= itemcount
2788 else find next incr1
2790 if abs
(m_active
- next) > fstate
.maxrows
2796 let first = m_first
+ incr
in
2797 let first = bound
first 0 (itemcount - fstate
.maxrows
) in
2799 let next = m_active
+ incr
in
2800 let next = bound
next 0 (itemcount - 1) in
2807 if isvisible first next
2814 let first = min
next m_first
in
2816 if abs
(next - first) > fstate
.maxrows
2822 let first = m_first
+ incr
in
2823 let first = bound
first 0 (itemcount - 1) in
2825 let next = m_active
+ incr
in
2826 let next = bound
next 0 (itemcount - 1) in
2827 let next = find next incr1 in
2829 if next = -1 || abs
(m_active
- first) > fstate
.maxrows
2831 let active = if m_active
= -1 then next else m_active
in
2836 if isvisible first active
2842 G.postRedisplay "listview navigate";
2846 | (@r
|@s) when Wsi.withctrl mask
->
2847 let incr = if key = @r
then -1 else 1 in
2849 match search (m_active
+ incr) m_qsearch
incr with
2851 state
.text <- m_qsearch ^
" [not found]";
2854 state
.text <- m_qsearch
;
2855 active, firstof m_first
active
2857 G.postRedisplay "listview ctrl-r/s";
2858 set1 active first m_qsearch
;
2860 | @insert
when Wsi.withctrl mask
->
2861 if m_active
>= 0 && m_active
< source#getitemcount
2863 let s, _ = source#getitem m_active
in
2869 if emptystr m_qsearch
2872 let qsearch = withoutlastutf8 m_qsearch
in
2876 G.postRedisplay "listview empty qsearch";
2877 set1 m_active m_first
E.s;
2881 match search m_active
qsearch ~
-1 with
2883 state
.text <- qsearch ^
" [not found]";
2886 state
.text <- qsearch;
2887 active, firstof m_first
active
2889 G.postRedisplay "listview backspace qsearch";
2890 set1 active first qsearch
2893 | key when (key != 0 && key land 0xff00 != 0xff00) ->
2894 let pattern = m_qsearch ^ toutf8
key in
2896 match search m_active
pattern 1 with
2898 state
.text <- pattern ^
" [not found]";
2901 state
.text <- pattern;
2902 active, firstof m_first
active
2904 G.postRedisplay "listview qsearch add";
2905 set1 active first pattern;
2909 if emptystr m_qsearch
2911 G.postRedisplay "list view escape";
2912 let mx, my
= state
.mpos
in
2916 source#exit ~uioh
:(coe self
)
2917 ~cancel
:true ~
active:m_active ~
first:m_first ~pan
:m_pan
2919 | None
-> m_prev_uioh
2924 G.postRedisplay "list view kill qsearch";
2925 coe {< m_qsearch
= E.s >}
2928 | @enter
| @kpenter
->
2930 let self = {< m_qsearch
= E.s >} in
2932 G.postRedisplay "listview enter";
2933 if m_active
>= 0 && m_active
< source#getitemcount
2935 source#exit ~uioh
:(coe self) ~cancel
:false
2936 ~
active:m_active ~
first:m_first ~pan
:m_pan
;
2939 source#exit ~uioh
:(coe self) ~cancel
:true
2940 ~
active:m_active ~
first:m_first ~pan
:m_pan
;
2943 begin match opt with
2944 | None
-> m_prev_uioh
2948 | @delete
| @kpdelete
->
2951 | @up
| @kpup
-> navigate ~
-1
2952 | @down
| @kpdown
-> navigate 1
2953 | @prior
| @kpprior
-> navigate ~
-(fstate
.maxrows
)
2954 | @next | @kpnext
-> navigate fstate
.maxrows
2956 | @right
| @kpright
->
2958 G.postRedisplay "listview right";
2959 coe {< m_pan
= m_pan
- 1 >}
2961 | @left | @kpleft
->
2963 G.postRedisplay "listview left";
2964 coe {< m_pan
= m_pan
+ 1 >}
2966 | @home
| @kphome
->
2967 let active = find 0 1 in
2968 G.postRedisplay "listview home";
2972 let first = max
0 (itemcount - fstate
.maxrows
) in
2973 let active = find (itemcount - 1) ~
-1 in
2974 G.postRedisplay "listview end";
2977 | key when (key = 0 || key land 0xff00 = 0xff00) ->
2981 dolog
"listview unknown key %#x" key; coe self
2983 method key key mask
=
2984 match state
.mode
with
2985 | Textentry te
-> textentrykeyboard key mask te
; coe self
2988 | LinkNav
_ -> self#key1
key mask
2990 method button button down
x y _ =
2993 | 1 when vscrollhit x ->
2994 G.postRedisplay "listview scroll";
2997 let _, position, sh = self#
scrollph in
2998 if y > truncate
position && y < truncate
(position +. sh)
3000 state
.mstate
<- Mscrolly
;
3004 let s = float (max
0 (y - conf
.scrollh
)) /. float state
.winh
in
3005 let first = truncate
(s *. float source#getitemcount
) in
3006 let first = min source#getitemcount
first in
3007 Some
(coe {< m_first
= first; m_active
= first >})
3009 state
.mstate
<- Mnone
;
3013 begin match self#elemunder
y with
3015 G.postRedisplay "listview click";
3016 source#exit ~uioh
:(coe {< m_active
= n >})
3017 ~cancel
:false ~
active:n ~
first:m_first ~pan
:m_pan
3021 | n when (n == 4 || n == 5) && not down
->
3022 let len = source#getitemcount
in
3024 if n = 5 && m_first
+ fstate
.maxrows
>= len
3028 let first = m_first
+ (if n == 4 then -1 else 1) in
3029 bound
first 0 (len - 1)
3031 G.postRedisplay "listview wheel";
3032 Some
(coe {< m_first
= first >})
3033 | n when (n = 6 || n = 7) && not down
->
3034 let inc = if n = 7 then -1 else 1 in
3035 G.postRedisplay "listview hwheel";
3036 Some
(coe {< m_pan
= m_pan
+ inc >})
3041 | None
-> m_prev_uioh
3044 method multiclick
_ x y = self#button
1 true x y
3047 match state
.mstate
with
3049 let s = float (max
0 (y - conf
.scrollh
)) /. float state
.winh
in
3050 let first = truncate
(s *. float source#getitemcount
) in
3051 let first = min source#getitemcount
first in
3052 G.postRedisplay "listview motion";
3053 coe {< m_first
= first; m_active
= first >}
3061 method pmotion
x y =
3062 if x < state
.winw
- conf
.scrollbw
3065 match self#elemunder
y with
3066 | None
-> Wsi.setcursor
Wsi.CURSOR_INHERIT
; m_active
3067 | Some
n -> Wsi.setcursor
Wsi.CURSOR_INFO
; n
3071 then (G.postRedisplay "listview pmotion"; {< m_active
= n >})
3076 Wsi.setcursor
Wsi.CURSOR_INHERIT
;
3080 method infochanged
_ = ()
3082 method scrollpw
= (0, 0.0, 0.0)
3084 let nfs = fstate
.fontsize
+ 1 in
3085 let y = m_first
* nfs in
3086 let itemcount = source#getitemcount
in
3087 let maxi = max
0 (itemcount - fstate
.maxrows
) in
3088 let maxy = maxi * nfs in
3089 let p, h = scrollph y maxy in
3092 method modehash
= modehash
3093 method eformsgs
= false
3094 method alwaysscrolly
= true
3097 class outlinelistview ~zebra ~source
=
3098 let settext autonarrow
s =
3101 let ss = source#statestr
in
3105 else "{" ^
ss ^
"} [" ^
s ^
"]"
3106 else state
.text <- s
3112 ~source
:(source
:> lvsource
)
3114 ~modehash
:(findkeyhash conf
"outline")
3117 val m_autonarrow
= false
3119 method! key key mask
=
3121 if emptystr state
.text
3123 else fstate
.maxrows - 2
3125 let calcfirst first active =
3128 let rows = active - first in
3129 if rows > maxrows then active - maxrows else first
3133 let active = m_active
+ incr in
3134 let active = bound
active 0 (source#getitemcount
- 1) in
3135 let first = calcfirst m_first
active in
3136 G.postRedisplay "outline navigate";
3137 coe {< m_active
= active; m_first
= first >}
3139 let navscroll first =
3141 let dist = m_active
- first in
3147 else first + maxrows
3150 G.postRedisplay "outline navscroll";
3151 coe {< m_first
= first; m_active
= active >}
3153 let ctrl = Wsi.withctrl mask
in
3158 then (source#denarrow
; E.s)
3160 let pattern = source#renarrow
in
3161 if nonemptystr m_qsearch
3162 then (source#narrow m_qsearch
; m_qsearch
)
3166 settext (not m_autonarrow
) text;
3167 G.postRedisplay "toggle auto narrowing";
3168 coe {< m_first
= 0; m_active
= 0; m_autonarrow
= not m_autonarrow
>}
3170 | @slash
when emptystr m_qsearch
&& not m_autonarrow
->
3172 G.postRedisplay "toggle auto narrowing";
3173 coe {< m_first
= 0; m_active
= 0; m_autonarrow
= true >}
3176 source#narrow m_qsearch
;
3178 then source#add_narrow_pattern m_qsearch
;
3179 G.postRedisplay "outline ctrl-n";
3180 coe {< m_first
= 0; m_active
= 0 >}
3183 let active = source#calcactive
(getanchor
()) in
3184 let first = firstof m_first
active in
3185 G.postRedisplay "outline ctrl-s";
3186 coe {< m_first
= first; m_active
= active >}
3189 G.postRedisplay "outline ctrl-u";
3190 if m_autonarrow
&& nonemptystr m_qsearch
3192 ignore
(source#renarrow
);
3193 settext m_autonarrow
E.s;
3194 coe {< m_first
= 0; m_active
= 0; m_qsearch
= E.s >}
3197 source#del_narrow_pattern
;
3198 let pattern = source#renarrow
in
3200 if emptystr
pattern then E.s else "Narrowed to " ^
pattern
3202 settext m_autonarrow
text;
3203 coe {< m_first
= 0; m_active
= 0; m_qsearch
= E.s >}
3207 let first = max
0 (m_active
- (fstate
.maxrows / 2)) in
3208 G.postRedisplay "outline ctrl-l";
3209 coe {< m_first
= first >}
3211 | @tab
when m_autonarrow
->
3212 if nonemptystr m_qsearch
3214 G.postRedisplay "outline list view tab";
3215 source#add_narrow_pattern m_qsearch
;
3217 coe {< m_qsearch
= E.s >}
3221 | @escape
when m_autonarrow
->
3222 if nonemptystr m_qsearch
3223 then source#add_narrow_pattern m_qsearch
;
3226 | @enter
| @kpenter
when m_autonarrow
->
3227 if nonemptystr m_qsearch
3228 then source#add_narrow_pattern m_qsearch
;
3231 | key when m_autonarrow
&& (key != 0 && key land 0xff00 != 0xff00) ->
3232 let pattern = m_qsearch ^ toutf8
key in
3233 G.postRedisplay "outlinelistview autonarrow add";
3234 source#narrow
pattern;
3235 settext true pattern;
3236 coe {< m_first
= 0; m_active
= 0; m_qsearch
= pattern >}
3238 | key when m_autonarrow
&& key = @backspace
->
3239 if emptystr m_qsearch
3242 let pattern = withoutlastutf8 m_qsearch
in
3243 G.postRedisplay "outlinelistview autonarrow backspace";
3244 ignore
(source#renarrow
);
3245 source#narrow
pattern;
3246 settext true pattern;
3247 coe {< m_first
= 0; m_active
= 0; m_qsearch
= pattern >}
3249 | @up
| @kpup
when ctrl ->
3250 navscroll (max
0 (m_first
- 1))
3252 | @down
| @kpdown
when ctrl ->
3253 navscroll (min
(source#getitemcount
- 1) (m_first
+ 1))
3255 | @up
| @kpup
-> navigate ~
-1
3256 | @down
| @kpdown
-> navigate 1
3257 | @prior
| @kpprior
-> navigate ~
-(fstate
.maxrows)
3258 | @next | @kpnext
-> navigate fstate
.maxrows
3260 | @right
| @kpright
->
3264 G.postRedisplay "outline ctrl right";
3265 {< m_pan
= m_pan
+ 1 >}
3267 else self#updownlevel
1
3271 | @left | @kpleft
->
3275 G.postRedisplay "outline ctrl left";
3276 {< m_pan
= m_pan
- 1 >}
3278 else self#updownlevel ~
-1
3282 | @home
| @kphome
->
3283 G.postRedisplay "outline home";
3284 coe {< m_first
= 0; m_active
= 0 >}
3287 let active = source#getitemcount
- 1 in
3288 let first = max
0 (active - fstate
.maxrows) in
3289 G.postRedisplay "outline end";
3290 coe {< m_active
= active; m_first
= first >}
3292 | _ -> super#
key key mask
3295 let genhistoutlines () =
3297 |> List.sort
(fun (_, c1
, _, _, _, _) (_, c2
, _, _, _, _) ->
3298 compare c2
.lastvisit c1
.lastvisit
)
3300 (fun ((path
, c, _, _, _, origin
) as hist
) ->
3301 let path = if nonemptystr origin
then origin
else path in
3302 let base = mbtoutf8
@@ Filename.basename
path in
3303 (base ^
"\000" ^
c.title
, 1, Ohistory hist
)
3308 let gotohist (path, c, bookmarks
, x, anchor, origin
) =
3309 Config.save
leavebirdseye;
3310 state
.anchor <- anchor;
3311 state
.bookmarks
<- bookmarks
;
3312 state
.origin
<- origin
;
3315 let x0, y0, x1, y1 = conf
.trimfuzz
in
3316 wcmd "trimset %d %d %d %d %d" (btod conf
.trimmargins
) x0 y0 x1 y1;
3317 reshape ~firsttime
:true state
.winw state
.winh
;
3318 opendoc path origin
;
3322 let makecheckers () =
3323 (* Based on lablGL-1.04/LablGlut/examples/lablGL/checker.ml which had
3325 converted by Issac Trotts. July 25, 2002 *)
3326 let image = GlPix.create `ubyte ~format
:`luminance ~width
:2 ~height
:2 in
3327 Raw.sets_string
(GlPix.to_raw
image) ~
pos:0 "\255\200\200\255";
3328 let id = GlTex.gen_texture
() in
3329 GlTex.bind_texture ~target
:`texture_2d
id;
3330 GlPix.store
(`unpack_alignment
1);
3331 GlTex.image2d
image;
3332 List.iter
(GlTex.parameter ~target
:`texture_2d
)
3333 [ `mag_filter `nearest
; `min_filter `nearest
];
3337 let setcheckers enabled
=
3338 match state
.checkerstexid
with
3340 if enabled
then state
.checkerstexid
<- Some
(makecheckers ())
3342 | Some checkerstexid
->
3345 GlTex.delete_texture checkerstexid
;
3346 state
.checkerstexid
<- None
;
3350 let describe_location () =
3351 let fn = page_of_y state
.y in
3352 let ln = page_of_y
(state
.y + state
.winh
- hscrollh () - 1) in
3353 let maxy = state
.maxy - (if conf
.maxhfit
then state
.winh
else 0) in
3357 else (100. *. (float state
.y /. float maxy))
3361 Printf.sprintf
"page %d of %d [%.2f%%]"
3362 (fn+1) state
.pagecount
percent
3365 "pages %d-%d of %d [%.2f%%]"
3366 (fn+1) (ln+1) state
.pagecount
percent
3369 let setpresentationmode v
=
3370 let n = page_of_y state
.y in
3371 state
.anchor <- (n, 0.0, 1.0);
3372 conf
.presentation
<- v
;
3373 if conf
.fitmodel
= FitPage
3374 then reqlayout conf
.angle conf
.fitmodel
;
3379 let btos b = if b then "@Uradical" else E.s in
3380 let showextended = ref false in
3381 let leave mode
_ = state
.mode
<- mode
in
3384 val mutable m_l
= []
3385 val mutable m_a
= E.a
3386 val mutable m_prev_uioh
= nouioh
3387 val mutable m_prev_mode
= View
3389 inherit lvsourcebase
3391 method reset prev_mode prev_uioh
=
3392 m_a
<- Array.of_list
(List.rev m_l
);
3394 m_prev_mode
<- prev_mode
;
3395 m_prev_uioh
<- prev_uioh
;
3397 method int name get
set =
3399 (name
, `
int get
, 1, Action
(
3402 try set (int_of_string
s)
3404 state
.text <- Printf.sprintf
"bad integer `%s': %s"
3408 let te = name ^
": ", E.s, None
, intentry, ondone, true in
3409 state
.mode
<- Textentry
(te, leave m_prev_mode
);
3413 method int_with_suffix name get
set =
3415 (name
, `intws get
, 1, Action
(
3418 try set (int_of_string_with_suffix
s)
3420 state
.text <- Printf.sprintf
"bad integer `%s': %s"
3425 name ^
": ", E.s, None
, intentry_with_suffix, ondone, true
3427 state
.mode
<- Textentry
(te, leave m_prev_mode
);
3431 method bool ?
(offset
=1) ?
(btos=btos) name get
set =
3433 (name
, `
bool (btos, get
), offset
, Action
(
3440 method color name get
set =
3442 (name
, `
color get
, 1, Action
(
3444 let invalid = (nan
, nan
, nan
) in
3447 try color_of_string
s
3449 state
.text <- Printf.sprintf
"bad color `%s': %s"
3456 let te = name ^
": ", E.s, None
, textentry, ondone, true in
3457 state
.text <- color_to_string
(get
());
3458 state
.mode
<- Textentry
(te, leave m_prev_mode
);
3462 method string name get
set =
3464 (name
, `
string get
, 1, Action
(
3466 let ondone s = set s in
3467 let te = name ^
": ", E.s, None
, textentry, ondone, true in
3468 state
.mode
<- Textentry
(te, leave m_prev_mode
);
3472 method colorspace name get
set =
3474 (name
, `
string get
, 1, Action
(
3478 inherit lvsourcebase
3481 m_active
<- CSTE.to_int conf
.colorspace
;
3484 method getitemcount
=
3485 Array.length
CSTE.names
3488 method exit ~uioh ~cancel ~
active ~
first ~pan
=
3489 ignore
(uioh
, first, pan
);
3490 if not cancel
then set active;
3492 method hasaction
_ = true
3496 let modehash = findkeyhash conf
"info" in
3497 coe (new listview ~zebra
:false ~helpmode
:false
3498 ~
source ~trusted
:true ~
modehash)
3501 method paxmark name get
set =
3503 (name
, `
string get
, 1, Action
(
3507 inherit lvsourcebase
3510 m_active
<- MTE.to_int conf
.paxmark
;
3513 method getitemcount
= Array.length
MTE.names
3514 method getitem
n = (MTE.names
.(n), 0)
3515 method exit ~uioh ~cancel ~
active ~
first ~pan
=
3516 ignore
(uioh
, first, pan
);
3517 if not cancel
then set active;
3519 method hasaction
_ = true
3523 let modehash = findkeyhash conf
"info" in
3524 coe (new listview ~zebra
:false ~helpmode
:false
3525 ~
source ~trusted
:true ~
modehash)
3528 method fitmodel name get
set =
3530 (name
, `
string get
, 1, Action
(
3534 inherit lvsourcebase
3537 m_active
<- FMTE.to_int conf
.fitmodel
;
3540 method getitemcount
= Array.length
FMTE.names
3541 method getitem
n = (FMTE.names
.(n), 0)
3542 method exit ~uioh ~cancel ~
active ~
first ~pan
=
3543 ignore
(uioh
, first, pan
);
3544 if not cancel
then set active;
3546 method hasaction
_ = true
3550 let modehash = findkeyhash conf
"info" in
3551 coe (new listview ~zebra
:false ~helpmode
:false
3552 ~
source ~trusted
:true ~
modehash)
3555 method caption
s offset
=
3556 m_l
<- (s, `empty
, offset
, Noaction
) :: m_l
3558 method caption2
s f offset
=
3559 m_l
<- (s, `
string f, offset
, Noaction
) :: m_l
3561 method getitemcount
= Array.length m_a
3564 let tostr = function
3565 | `
int f -> string_of_int
(f ())
3566 | `intws
f -> string_with_suffix_of_int
(f ())
3568 | `
color f -> color_to_string
(f ())
3569 | `
bool (btos, f) -> btos (f ())
3572 let name, t
, offset
, _ = m_a
.(n) in
3573 ((let s = tostr t
in
3575 then Printf.sprintf
"%s\t%s" name s
3579 method exit ~uioh ~cancel ~
active ~
first ~pan
=
3584 match m_a
.(active) with
3585 | _, _, _, Action
f -> f uioh
3586 | _, _, _, Noaction
-> uioh
3597 method hasaction
n =
3599 | _, _, _, Action
_ -> true
3600 | _, _, _, Noaction
-> false
3602 initializer m_active
<- 1
3605 let rec fillsrc prevmode prevuioh
=
3606 let sep () = src#caption
E.s 0 in
3607 let colorp name get
set =
3609 (fun () -> color_to_string
(get
()))
3612 let c = color_of_string
v in
3615 state
.text <- Printf.sprintf
"bad color `%s': %s" v @@ exntos exn
3618 let oldmode = state
.mode
in
3619 let birdseye = isbirdseye state
.mode
in
3621 src#caption
(if birdseye then "Setup (Bird's eye)" else "Setup") 0;
3623 src#
bool "presentation mode"
3624 (fun () -> conf
.presentation
)
3625 (fun v -> setpresentationmode v);
3627 src#
bool "ignore case in searches"
3628 (fun () -> conf
.icase
)
3629 (fun v -> conf
.icase
<- v);
3632 (fun () -> conf
.preload)
3633 (fun v -> conf
.preload <- v);
3635 src#
bool "highlight links"
3636 (fun () -> conf
.hlinks
)
3637 (fun v -> conf
.hlinks
<- v);
3639 src#
bool "under info"
3640 (fun () -> conf
.underinfo
)
3641 (fun v -> conf
.underinfo
<- v);
3643 src#
bool "persistent bookmarks"
3644 (fun () -> conf
.savebmarks
)
3645 (fun v -> conf
.savebmarks
<- v);
3647 src#fitmodel
"fit model"
3648 (fun () -> FMTE.to_string conf
.fitmodel
)
3649 (fun v -> reqlayout conf
.angle
(FMTE.of_int
v));
3651 src#
bool "trim margins"
3652 (fun () -> conf
.trimmargins
)
3653 (fun v -> settrim v conf
.trimfuzz
; fillsrc prevmode prevuioh
);
3655 src#
bool "persistent location"
3656 (fun () -> conf
.jumpback
)
3657 (fun v -> conf
.jumpback
<- v);
3660 src#
int "inter-page space"
3661 (fun () -> conf
.interpagespace
)
3663 conf
.interpagespace
<- n;
3664 docolumns conf
.columns
;
3666 match state
.layout with
3671 state
.maxy <- calcheight
();
3672 let y = getpagey
pageno in
3677 (fun () -> conf
.pagebias
)
3678 (fun v -> conf
.pagebias
<- v);
3680 src#
int "scroll step"
3681 (fun () -> conf
.scrollstep
)
3682 (fun n -> conf
.scrollstep
<- n);
3684 src#
int "horizontal scroll step"
3685 (fun () -> conf
.hscrollstep
)
3686 (fun v -> conf
.hscrollstep
<- v);
3688 src#
int "auto scroll step"
3690 match state
.autoscroll
with
3692 | _ -> conf
.autoscrollstep
)
3694 let n = boundastep state
.winh
n in
3695 if state
.autoscroll
<> None
3696 then state
.autoscroll
<- Some
n;
3697 conf
.autoscrollstep
<- n);
3700 (fun () -> truncate
(conf
.zoom *. 100.))
3701 (fun v -> setzoom ((float v) /. 100.));
3704 (fun () -> conf
.angle
)
3705 (fun v -> reqlayout v conf
.fitmodel
);
3707 src#
int "scroll bar width"
3708 (fun () -> conf
.scrollbw
)
3711 reshape state
.winw state
.winh
;
3714 src#
int "scroll handle height"
3715 (fun () -> conf
.scrollh
)
3716 (fun v -> conf
.scrollh
<- v;);
3718 src#
int "thumbnail width"
3719 (fun () -> conf
.thumbw
)
3721 conf
.thumbw
<- min
4096 v;
3724 leavebirdseye beye
false;
3731 let mode = state
.mode in
3732 src#
string "columns"
3734 match conf
.columns
with
3736 | Cmulti
(multi
, _) -> multicolumns_to_string multi
3737 | Csplit
(count
, _) -> "-" ^ string_of_int count
3740 let n, a, b = multicolumns_of_string
v in
3741 setcolumns mode n a b);
3744 src#caption
"Pixmap cache" 0;
3745 src#int_with_suffix
"size (advisory)"
3746 (fun () -> conf
.memlimit
)
3747 (fun v -> conf
.memlimit
<- v);
3750 (fun () -> Printf.sprintf
"%s bytes, %d tiles"
3751 (string_with_suffix_of_int state
.memused
)
3752 (Hashtbl.length state
.tilemap
)) 1;
3755 src#caption
"Layout" 0;
3756 src#caption2
"Dimension"
3758 Printf.sprintf
"%dx%d (virtual %dx%d)"
3759 state
.winw state
.winh
3764 src#caption2
"Position" (fun () ->
3765 Printf.sprintf
"%dx%d" state
.x state
.y
3768 src#caption2
"Position" (fun () -> describe_location ()) 1
3772 src#
bool ~offset
:0 ~
btos:(fun v -> if v then "(on)" else "(off)")
3773 "Save these parameters as global defaults at exit"
3774 (fun () -> conf
.bedefault
)
3775 (fun v -> conf
.bedefault
<- v)
3779 let btos b = if b then "@Ulguillemet" else "@Urguillemet" in
3780 src#
bool ~offset
:0 ~
btos "Extended parameters"
3781 (fun () -> !showextended)
3782 (fun v -> showextended := v; fillsrc prevmode prevuioh
);
3786 (fun () -> conf
.checkers
)
3787 (fun v -> conf
.checkers
<- v; setcheckers v);
3788 src#
bool "update cursor"
3789 (fun () -> conf
.updatecurs
)
3790 (fun v -> conf
.updatecurs
<- v);
3791 src#
bool "scroll-bar on the left"
3792 (fun () -> conf
.leftscroll
)
3793 (fun v -> conf
.leftscroll
<- v);
3795 (fun () -> conf
.verbose
)
3796 (fun v -> conf
.verbose
<- v);
3797 src#
bool "invert colors"
3798 (fun () -> conf
.invert
)
3799 (fun v -> conf
.invert
<- v);
3801 (fun () -> conf
.maxhfit
)
3802 (fun v -> conf
.maxhfit
<- v);
3804 (fun () -> conf
.pax
!= None
)
3807 then conf
.pax
<- Some
(ref (now
(), 0, 0))
3808 else conf
.pax
<- None
);
3809 src#
string "uri launcher"
3810 (fun () -> conf
.urilauncher
)
3811 (fun v -> conf
.urilauncher
<- v);
3812 src#
string "path launcher"
3813 (fun () -> conf
.pathlauncher
)
3814 (fun v -> conf
.pathlauncher
<- v);
3815 src#
string "tile size"
3816 (fun () -> Printf.sprintf
"%dx%d" conf
.tilew conf
.tileh
)
3819 let w, h = Scanf.sscanf
v "%dx%d" (fun w h -> w, h) in
3820 conf
.tilew
<- max
64 w;
3821 conf
.tileh
<- max
64 h;
3824 state
.text <- Printf.sprintf
"bad tile size `%s': %s"
3827 src#
int "texture count"
3828 (fun () -> conf
.texcount
)
3831 then conf
.texcount
<- v
3832 else impmsg "failed to set texture count please retry later"
3834 src#
int "slice height"
3835 (fun () -> conf
.sliceheight
)
3837 conf
.sliceheight
<- v;
3838 wcmd "sliceh %d" conf
.sliceheight
;
3840 src#
int "anti-aliasing level"
3841 (fun () -> conf
.aalevel
)
3843 conf
.aalevel
<- bound
v 0 8;
3844 state
.anchor <- getanchor
();
3845 opendoc state
.path state
.password;
3847 src#
string "page scroll scaling factor"
3848 (fun () -> string_of_float conf
.pgscale)
3851 let s = float_of_string
v in
3854 state
.text <- Printf.sprintf
3855 "bad page scroll scaling factor `%s': %s" v @@ exntos exn
3858 src#
int "ui font size"
3859 (fun () -> fstate
.fontsize
)
3860 (fun v -> setfontsize (bound
v 5 100));
3861 src#
int "hint font size"
3862 (fun () -> conf
.hfsize
)
3863 (fun v -> conf
.hfsize
<- bound
v 5 100);
3864 colorp "background color"
3865 (fun () -> conf
.bgcolor
)
3866 (fun v -> conf
.bgcolor
<- v);
3867 src#
bool "crop hack"
3868 (fun () -> conf
.crophack
)
3869 (fun v -> conf
.crophack
<- v);
3870 src#
string "trim fuzz"
3871 (fun () -> irect_to_string conf
.trimfuzz
)
3874 conf
.trimfuzz
<- irect_of_string
v;
3876 then settrim true conf
.trimfuzz
;
3878 state
.text <- Printf.sprintf
"bad irect `%s': %s" v @@ exntos exn
3880 src#
string "throttle"
3882 match conf
.maxwait
with
3883 | None
-> "show place holder if page is not ready"
3886 then "wait for page to fully render"
3888 "wait " ^ string_of_float
time
3889 ^
" seconds before showing placeholder"
3893 let f = float_of_string
v in
3895 then conf
.maxwait
<- None
3896 else conf
.maxwait
<- Some
f
3898 state
.text <- Printf.sprintf
"bad time `%s': %s" v @@ exntos exn
3900 src#
string "ghyll scroll"
3902 match conf
.ghyllscroll
with
3904 | Some nab
-> ghyllscroll_to_string nab
3907 try conf
.ghyllscroll
<- ghyllscroll_of_string
v
3910 state
.text <- Printf.sprintf
"bad ghyll `%s': %s" v msg
3912 state
.text <- Printf.sprintf
"bad ghyll `%s': %s" v @@ exntos exn
3914 src#
string "selection command"
3915 (fun () -> conf
.selcmd
)
3916 (fun v -> conf
.selcmd
<- v);
3917 src#
string "synctex command"
3918 (fun () -> conf
.stcmd
)
3919 (fun v -> conf
.stcmd
<- v);
3920 src#
string "pax command"
3921 (fun () -> conf
.paxcmd
)
3922 (fun v -> conf
.paxcmd
<- v);
3923 src#
string "ask password command"
3924 (fun () -> conf
.passcmd)
3925 (fun v -> conf
.passcmd <- v);
3926 src#
string "save path command"
3927 (fun () -> conf
.savecmd
)
3928 (fun v -> conf
.savecmd
<- v);
3929 src#colorspace
"color space"
3930 (fun () -> CSTE.to_string conf
.colorspace
)
3932 conf
.colorspace
<- CSTE.of_int
v;
3936 src#paxmark
"pax mark method"
3937 (fun () -> MTE.to_string conf
.paxmark
)
3938 (fun v -> conf
.paxmark
<- MTE.of_int
v);
3942 (fun () -> conf
.usepbo
)
3943 (fun v -> conf
.usepbo
<- v);
3944 src#
bool "mouse wheel scrolls pages"
3945 (fun () -> conf
.wheelbypage
)
3946 (fun v -> conf
.wheelbypage
<- v);
3947 src#
bool "open remote links in a new instance"
3948 (fun () -> conf
.riani
)
3949 (fun v -> conf
.riani
<- v);
3950 src#
bool "edit annotations inline"
3951 (fun () -> conf
.annotinline
)
3952 (fun v -> conf
.annotinline
<- v);
3956 src#caption
"Document" 0;
3957 List.iter
(fun (_, s) -> src#caption
s 1) state
.docinfo
;
3958 src#caption2
"Pages"
3959 (fun () -> string_of_int state
.pagecount
) 1;
3960 src#caption2
"Dimensions"
3961 (fun () -> string_of_int
(List.length state
.pdims
)) 1;
3965 src#caption
"Trimmed margins" 0;
3966 src#caption2
"Dimensions"
3967 (fun () -> string_of_int
(List.length state
.pdims
)) 1;
3971 src#caption
"OpenGL" 0;
3972 src#caption
(Printf.sprintf
"Vendor\t%s" (GlMisc.get_string `vendor
)) 1;
3973 src#caption
(Printf.sprintf
"Renderer\t%s" (GlMisc.get_string `renderer
)) 1;
3976 src#caption
"Location" 0;
3977 if nonemptystr state
.origin
3978 then src#caption
("Orign\t" ^ mbtoutf8 state
.origin
) 1;
3979 src#caption
("Path\t" ^ mbtoutf8 state
.path) 1;
3981 src#reset prevmode prevuioh
;
3986 let prevmode = state
.mode
3987 and prevuioh
= state
.uioh in
3988 fillsrc prevmode prevuioh
;
3989 let source = (src :> lvsource
) in
3990 let modehash = findkeyhash conf
"info" in
3991 state
.uioh <- coe (object (self)
3992 inherit listview ~zebra
:false ~helpmode
:false
3993 ~
source ~trusted
:true ~
modehash as super
3994 val mutable m_prevmemused
= 0
3995 method! infochanged
= function
3997 if m_prevmemused
!= state
.memused
3999 m_prevmemused
<- state
.memused
;
4000 G.postRedisplay "memusedchanged";
4002 | Pdim
-> G.postRedisplay "pdimchanged"
4003 | Docinfo
-> fillsrc prevmode prevuioh
4005 method! key key mask
=
4006 if not
(Wsi.withctrl mask
)
4009 | @left | @kpleft
-> coe (self#updownlevel ~
-1)
4010 | @right
| @kpright
-> coe (self#updownlevel
1)
4011 | _ -> super#
key key mask
4012 else super#
key key mask
4014 G.postRedisplay "info";
4020 inherit lvsourcebase
4021 method getitemcount
= Array.length state
.help
4023 let s, l, _ = state
.help
.(n) in
4026 method exit ~
uioh ~cancel ~
active ~
first ~pan
=
4030 match state
.help
.(active) with
4031 | _, _, Action
f -> Some
(f uioh)
4032 | _, _, Noaction
-> Some
uioh
4041 method hasaction
n =
4042 match state
.help
.(n) with
4043 | _, _, Action
_ -> true
4044 | _, _, Noaction
-> false
4050 let modehash = findkeyhash conf
"help" in
4052 state
.uioh <- coe (new listview
4053 ~zebra
:false ~helpmode
:true
4054 ~
source ~trusted
:true ~
modehash);
4055 G.postRedisplay "help";
4061 inherit lvsourcebase
4062 val mutable m_items
= E.a
4064 method getitemcount
= 1 + Array.length m_items
4069 else m_items
.(n-1), 0
4071 method exit ~
uioh ~cancel ~
active ~
first ~pan
=
4076 then Buffer.clear state
.errmsgs
;
4083 method hasaction
n =
4087 state
.newerrmsgs
<- false;
4088 let l = Str.split newlinere
(Buffer.contents state
.errmsgs
) in
4089 m_items
<- Array.of_list
l
4098 let source = (msgsource :> lvsource
) in
4099 let modehash = findkeyhash conf
"listview" in
4100 state
.uioh <- coe (object
4101 inherit listview ~zebra
:false ~helpmode
:false
4102 ~
source ~trusted
:false ~
modehash as super
4105 then msgsource#reset
;
4108 G.postRedisplay "msgs";
4112 let editor = getenvwithdef
"EDITOR" E.s in
4116 let tmppath = Filename.temp_file
"llpp" "note" in
4119 let oc = open_out
tmppath in
4123 let execstr = editor ^
" " ^
tmppath in
4125 match spawn
execstr [] with
4126 | (exception exn
) ->
4127 impmsg "spawn(%S) failed: %s" execstr @@ exntos exn
;
4130 match Unix.waitpid
[] pid with
4131 | (exception exn
) ->
4132 impmsg "waitpid(%d) failed: %s" pid @@ exntos exn
;
4136 | Unix.WEXITED
0 -> filecontents
tmppath
4138 impmsg "editor process(%s) exited abnormally: %d" execstr n;
4140 | Unix.WSIGNALED
n ->
4141 impmsg "editor process(%s) was killed by signal %d" execstr n;
4143 | Unix.WSTOPPED
n ->
4144 impmsg "editor(%s) process was stopped by signal %d" execstr n;
4147 match Unix.unlink
tmppath with
4148 | (exception exn
) ->
4149 impmsg "failed to ulink %S: %s" tmppath @@ exntos exn
;
4154 let enterannotmode opaque slinkindex
=
4157 inherit lvsourcebase
4158 val mutable m_text
= E.s
4159 val mutable m_items
= E.a
4161 method getitemcount
= Array.length m_items
4164 let label, _func
= m_items
.(n) in
4167 method exit ~
uioh ~cancel ~
active ~
first ~pan
=
4168 ignore
(uioh, first, pan
);
4171 let _label, func
= m_items
.(active) in
4176 method hasaction
n = nonemptystr
@@ fst m_items
.(n)
4179 let rec split accu b i
=
4181 if p = String.length
s
4182 then (String.sub
s b (p-b), unit) :: accu
4184 if (i
> 70 && s.[p] = ' '
) || s.[p] = '
\r'
|| s.[p] = '
\n'
4186 let ss = if i
= 0 then E.s else String.sub
s b i
in
4187 split ((ss, unit)::accu) (p+1) 0
4192 wcmd "freepage %s" (~
> opaque);
4194 Hashtbl.fold (fun key opaque'
accu ->
4195 if opaque'
= opaque'
4196 then key :: accu else accu) state
.pagemap
[]
4198 List.iter
(Hashtbl.remove state
.pagemap
) keys;
4203 delannot
opaque slinkindex
;
4206 let edit inline
() =
4211 modannot
opaque slinkindex
s;
4217 let mode = state
.mode in
4220 ("annotation: ", m_text
, None
, textentry, update, true),
4221 fun _ -> state
.mode <- mode);
4225 let s = getusertext m_text
in
4230 ( "[Copy]", fun () -> selstring m_text
)
4231 :: ("[Delete]", dele)
4232 :: ("[Edit]", edit conf
.annotinline
)
4234 :: split [] 0 0 |> List.rev
|> Array.of_list
4241 let s = getannotcontents
opaque slinkindex
in
4244 let source = (msgsource :> lvsource
) in
4245 let modehash = findkeyhash conf
"listview" in
4246 state
.uioh <- coe (object
4247 inherit listview ~zebra
:false ~helpmode
:false
4248 ~
source ~trusted
:false ~
modehash
4250 G.postRedisplay "enterannotmode";
4253 let gotounder under =
4254 let getpath filename
=
4256 if nonemptystr filename
4258 if Filename.is_relative filename
4260 let dir = Filename.dirname state
.path in
4262 if Filename.is_implicit
dir
4263 then Filename.concat
(Sys.getcwd
()) dir
4266 Filename.concat
dir filename
4270 if Sys.file_exists
path
4275 | Ulinkgoto
(pageno, top) ->
4279 gotopage1 pageno top;
4282 | Ulinkuri
s -> gotouri
s
4284 | Uremote
(filename
, pageno) ->
4285 let path = getpath filename
in
4290 let command = Printf.sprintf
"%s -page %d %S" !selfexec pageno path in
4291 match spawn
command [] with
4293 | (exception exn
) ->
4294 dolog
"failed to execute `%s': %s" command @@ exntos exn
4296 let anchor = getanchor
() in
4297 let ranchor = state
.path, state
.password, anchor, state
.origin
in
4298 state
.origin
<- E.s;
4299 state
.anchor <- (pageno, 0.0, 0.0);
4300 state
.ranchors
<- ranchor :: state
.ranchors
;
4303 else impmsg "cannot find %s" filename
4305 | Uremotedest
(filename
, destname
) ->
4306 let path = getpath filename
in
4311 let command = !selfexec ^
" " ^
path ^
" -dest " ^ destname
in
4312 match spawn
command [] with
4313 | (exception exn
) ->
4314 dolog
"failed to execute `%s': %s" command @@ exntos exn
4317 let anchor = getanchor
() in
4318 let ranchor = state
.path, state
.password, anchor, state
.origin
in
4319 state
.origin
<- E.s;
4320 state
.nameddest
<- destname
;
4321 state
.ranchors
<- ranchor :: state
.ranchors
;
4324 else impmsg "cannot find %s" filename
4326 | Uunexpected
_ | Ulaunch
_ | Unamed
_ | Utext
_ | Unone
-> ()
4327 | Uannotation
(opaque, slinkindex
) -> enterannotmode opaque slinkindex
4330 let gotooutline (_, _, kind
) =
4334 let (pageno, y, _) = anchor in
4336 (if conf
.presentation
then (pageno, y, 1.0) else anchor)
4340 | Ouri
uri -> gotounder (Ulinkuri
uri)
4341 | Olaunch cmd
-> gotounder (Ulaunch cmd
)
4342 | Oremote remote
-> gotounder (Uremote remote
)
4343 | Ohistory hist
-> gotohist hist
4344 | Oremotedest remotedest
-> gotounder (Uremotedest remotedest
)
4347 let outlinesource fetchoutlines
=
4349 inherit lvsourcebase
4350 val mutable m_items
= E.a
4351 val mutable m_minfo
= E.a
4352 val mutable m_orig_items
= E.a
4353 val mutable m_orig_minfo
= E.a
4354 val mutable m_narrow_patterns
= []
4355 val mutable m_gen
= -1
4357 method getitemcount
= Array.length m_items
4360 let s, n, _ = m_items
.(n) in
4363 method exit ~
uioh ~cancel ~
active ~
first ~pan
=
4364 ignore
(uioh, first);
4366 if m_narrow_patterns
= []
4367 then m_orig_items
, m_orig_minfo
4368 else m_items
, m_minfo
4375 gotooutline m_items
.(active);
4383 method hasaction
_ = true
4386 if Array.length m_items
!= Array.length m_orig_items
4389 match m_narrow_patterns
with
4391 | many
-> String.concat
"@Uellipsis" (List.rev many
)
4393 "Narrowed to " ^
s ^
" (ctrl-u to restore)"
4397 match m_narrow_patterns
with
4400 | head
:: _ -> "@Uellipsis" ^ head
4402 method narrow
pattern =
4403 match Str.regexp_case_fold
pattern with
4404 | (exception _) -> ()
4406 let rec loop accu minfo n =
4409 m_items
<- Array.of_list
accu;
4410 m_minfo
<- Array.of_list
minfo;
4413 let (s, _, _) as o = m_items
.(n) in
4415 match Str.search_forward re
s 0 with
4416 | (exception Not_found
) -> accu, minfo
4417 | first -> o :: accu, (first, Str.match_end
()) :: minfo
4419 loop accu minfo (n-1)
4421 loop [] [] (Array.length m_items
- 1)
4423 method! getminfo
= m_minfo
4426 m_orig_items
<- fetchoutlines
();
4427 m_minfo
<- m_orig_minfo
;
4428 m_items
<- m_orig_items
4430 method add_narrow_pattern
pattern =
4431 m_narrow_patterns
<- pattern :: m_narrow_patterns
4433 method del_narrow_pattern
=
4434 match m_narrow_patterns
with
4435 | _ :: rest
-> m_narrow_patterns
<- rest
4440 match m_narrow_patterns
with
4441 | pattern :: [] -> self#narrow
pattern; pattern
4443 List.fold_left
(fun accu pattern ->
4444 self#narrow
pattern;
4445 pattern ^
"@Uellipsis" ^
accu) E.s list
4447 method calcactive
anchor =
4448 let rely = getanchory anchor in
4449 let rec loop n best bestd
=
4450 if n = Array.length m_items
4453 let _, _, kind
= m_items
.(n) in
4456 let orely = getanchory anchor in
4457 let d = abs
(orely - rely) in
4460 else loop (n+1) best bestd
4461 | Onone
| Oremote
_ | Olaunch
_
4462 | Oremotedest
_ | Ouri
_ | Ohistory
_ ->
4463 loop (n+1) best bestd
4467 method reset
anchor items =
4468 if state
.gen
!= m_gen
4470 m_orig_items
<- items;
4472 m_narrow_patterns
<- [];
4474 m_orig_minfo
<- E.a;
4478 if items != m_orig_items
4480 m_orig_items
<- items;
4481 if m_narrow_patterns
== []
4482 then m_items
<- items;
4485 let active = self#calcactive
anchor in
4487 m_first
<- firstof m_first
active
4491 let enteroutlinemode, enterbookmarkmode
, enterhistmode
=
4492 let mkselector sourcetype
=
4493 let fetchoutlines () =
4494 match sourcetype
with
4495 | `bookmarks
-> Array.of_list state
.bookmarks
4496 | `outlines
-> state
.outlines
4497 | `history
-> genhistoutlines ()
4499 let source = outlinesource fetchoutlines in
4501 let outlines = fetchoutlines () in
4502 if Array.length
outlines = 0
4504 showtext ' ' errmsg
;
4508 Wsi.setcursor
Wsi.CURSOR_INHERIT
;
4509 let anchor = getanchor
() in
4510 source#reset
anchor outlines;
4511 state
.text <- source#greetmsg
;
4513 coe (new outlinelistview ~zebra
:(sourcetype
=`history
) ~
source);
4514 G.postRedisplay "enter selector";
4517 let mkenter sourcetype errmsg
=
4518 let enter = mkselector sourcetype
in
4519 fun () -> enter errmsg
4521 (**)mkenter `
outlines "document has no outline"
4522 , mkenter `bookmarks
"document has no bookmarks (yet)"
4523 , mkenter `history
"history is empty"
4526 let quickbookmark ?title
() =
4527 match state
.layout with
4533 let tm = Unix.localtime
(now
()) in
4535 "Quick (page %d) (bookmarked at %02d/%02d/%d %02d:%02d)"
4539 (tm.Unix.tm_year
+ 1900)
4542 | Some
title -> title
4544 state
.bookmarks
<- (title, 0, Oanchor
(getanchor1
l)) :: state
.bookmarks
4547 let setautoscrollspeed step goingdown
=
4548 let incr = max
1 ((abs step
) / 2) in
4549 let incr = if goingdown
then incr else -incr in
4550 let astep = boundastep state
.winh
(step
+ incr) in
4551 state
.autoscroll
<- Some
astep;
4555 match conf
.columns
with
4557 | Csingle
_ | Cmulti
_ -> state
.x != 0 || conf
.zoom > 1.0
4560 let panbound x = bound
x (-state
.w) (wadjsb () + state
.winw
);;
4562 let existsinrow pageno (columns
, coverA
, coverB
) p =
4563 let last = ((pageno - coverA
) mod columns
) + columns
in
4564 let rec any = function
4567 if l.pageno = coverA
- 1 || l.pageno = state
.pagecount
- coverB
4571 then (if l.pageno = last then false else any rest
)
4579 match state
.layout with
4581 let pageno = page_of_y state
.y in
4582 gotoghyll (getpagey
(pageno+1))
4584 match conf
.columns
with
4586 if conf
.presentation
&& rest
== [] && l.pageh
> l.pagey + l.pagevh
4588 let y = clamp (pgscale state
.winh
) in
4591 let pageno = min
(l.pageno+1) (state
.pagecount
-1) in
4592 gotoghyll (getpagey
pageno)
4593 | Cmulti
((c, _, _) as cl, _) ->
4594 if conf
.presentation
4595 && (existsinrow l.pageno cl
4596 (fun l -> l.pageh
> l.pagey + l.pagevh))
4598 let y = clamp (pgscale state
.winh
) in
4601 let pageno = min
(l.pageno+c) (state
.pagecount
-1) in
4602 gotoghyll (getpagey
pageno)
4604 if l.pageno < state
.pagecount
- 1 || l.pagecol
< n - 1
4606 let pagey, pageh
= getpageyh
l.pageno in
4607 let pagey = pagey + pageh
* l.pagecol
in
4608 let ips = if l.pagecol
= 0 then 0 else conf
.interpagespace
in
4609 gotoghyll (pagey + pageh
+ ips)
4613 match state
.layout with
4615 let pageno = page_of_y state
.y in
4616 gotoghyll (getpagey
(pageno-1))
4618 match conf
.columns
with
4620 if conf
.presentation
&& l.pagey != 0
4622 gotoghyll (clamp (pgscale ~
-(state
.winh
)))
4624 let pageno = max
0 (l.pageno-1) in
4625 gotoghyll (getpagey
pageno)
4626 | Cmulti
((c, _, coverB
) as cl, _) ->
4627 if conf
.presentation
&&
4628 (existsinrow l.pageno cl (fun l -> l.pagey != 0))
4630 gotoghyll (clamp (pgscale ~
-(state
.winh
)))
4633 if l.pageno = state
.pagecount
- coverB
4637 let pageno = max
0 (l.pageno-decr) in
4638 gotoghyll (getpagey
pageno)
4646 let pageno = max
0 (l.pageno-1) in
4647 let pagey, pageh
= getpageyh
pageno in
4650 let pagey, pageh
= getpageyh
l.pageno in
4651 pagey + pageh
* (l.pagecol
-1) - conf
.interpagespace
4657 if emptystr conf
.savecmd
4658 then error
"don't know where to save modified document"
4660 let savecmd = Str.global_replace percentsre state
.path conf
.savecmd in
4663 (fun s -> error
"failed to obtain path to the saved copy: %s" s)
4668 let tmp = path ^
".tmp" in
4670 Unix.rename
tmp path;
4673 let viewkeyboard key mask
=
4675 let mode = state
.mode in
4676 state
.mode <- Textentry
(te, fun _ -> state
.mode <- mode);
4679 G.postRedisplay "view:enttext"
4681 let ctrl = Wsi.withctrl mask
in
4683 if key >= 0xffb0 && key < 0xffb9 then key - 0xffb0 + 48 else key
4689 if hasunsavedchanges
()
4693 if conf
.angle
mod 360 = 0 && not
(isbirdseye state
.mode)
4695 state
.mode <- LinkNav
(Ltgendir
0);
4698 else impmsg "keyboard link navigation does not work under rotation"
4701 begin match state
.mstate
with
4704 G.postRedisplay "kill rect";
4707 | Mscrolly
| Mscrollx
4710 begin match state
.mode with
4713 G.postRedisplay "esc leave linknav"
4717 match state
.ranchors
with
4719 | (path, password, anchor, origin
) :: rest
->
4720 state
.ranchors
<- rest
;
4721 state
.anchor <- anchor;
4722 state
.origin
<- origin
;
4723 state
.nameddest
<- E.s;
4724 opendoc path password
4729 gotoghyll (getnav ~
-1)
4740 Hashtbl.iter
(fun _ opaque ->
4742 Hashtbl.clear state
.prects
) state
.pagemap
;
4743 G.postRedisplay "dehighlight";
4745 | @slash
| @question
->
4746 let ondone isforw
s =
4747 cbput state
.hists
.pat
s;
4748 state
.searchpattern
<- s;
4751 let s = String.make
1 (Char.chr
key) in
4752 enttext (s, E.s, Some
(onhist state
.hists
.pat
),
4753 textentry, ondone (key = @slash
), true)
4755 | @plus
| @kpplus
| @equals
when ctrl ->
4756 let incr = if conf
.zoom +. 0.01 > 0.1 then 0.1 else 0.01 in
4757 setzoom (conf
.zoom +. incr)
4759 | @plus
| @kpplus
->
4762 try int_of_string
s with exc
->
4763 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exc
;
4769 state
.text <- "page bias is now " ^ string_of_int
n;
4772 enttext ("page bias: ", E.s, None
, intentry, ondone, true)
4774 | @minus
| @kpminus
when ctrl ->
4775 let decr = if conf
.zoom -. 0.1 < 0.1 then 0.01 else 0.1 in
4776 setzoom (max
0.01 (conf
.zoom -. decr))
4778 | @minus
| @kpminus
->
4779 let ondone msg
= state
.text <- msg
in
4781 "option [acfhilpstvxACFPRSZTISM]: ", E.s, None
,
4782 optentry state
.mode, ondone, true
4793 | (@1 | @2) when ctrl && conf
.fitmodel
!= FitPage
-> (* ctrl-1/2 *)
4795 match conf
.columns
with
4796 | Csingle
_ | Cmulti
_ -> 1
4797 | Csplit
(n, _) -> n
4799 let h = state
.winh
-
4800 conf
.interpagespace
lsl (if conf
.presentation
then 1 else 0)
4802 let zoom = zoomforh state
.winw
h (vscrollw ()) cols in
4803 if zoom > 0.0 && (key = 50 || zoom < 1.0)
4808 match conf
.fitmodel
with
4809 | FitWidth
-> FitProportional
4810 | FitProportional
-> FitPage
4811 | FitPage
-> FitWidth
4813 state
.text <- "fit model: " ^
FMTE.to_string
fm;
4814 reqlayout conf
.angle
fm
4822 | (48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57)
4823 when not
ctrl -> (* 0..9 *)
4826 try int_of_string
s with exc
->
4827 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exc
;
4833 cbput state
.hists
.pag
(string_of_int
n);
4834 gotopage1 (n + conf
.pagebias
- 1) 0;
4837 let pageentry text key =
4838 match Char.unsafe_chr
key with
4839 | '
g'
-> TEdone
text
4840 | _ -> intentry text key
4842 let text = String.make
1 (Char.chr
key) in
4843 enttext (":", text, Some
(onhist state
.hists
.pag
),
4844 pageentry, ondone, true)
4847 conf
.scrollb
<- if conf
.scrollb
= 0 then (scrollbvv
lor scrollbhv
) else 0;
4848 reshape state
.winw state
.winh
;
4851 state
.bzoom
<- not state
.bzoom
;
4853 showtext ' '
("block zoom " ^
if state
.bzoom
then "on" else "off")
4856 conf
.hlinks
<- not conf
.hlinks
;
4857 state
.text <- "highlightlinks " ^
if conf
.hlinks
then "on" else "off";
4858 G.postRedisplay "toggle highlightlinks";
4861 if conf
.angle
mod 360 = 0
4863 state
.glinks
<- true;
4864 let mode = state
.mode in
4867 (":", E.s, None
, linknentry, linknact gotounder, false),
4869 state
.glinks
<- false;
4873 G.postRedisplay "view:linkent(F)"
4875 else impmsg "hint mode does not work under rotation"
4878 state
.glinks
<- true;
4879 let mode = state
.mode in
4880 state
.mode <- Textentry
(
4882 ":", E.s, None
, linknentry, linknact (fun under ->
4883 selstring (undertext under);
4887 state
.glinks
<- false;
4891 G.postRedisplay "view:linkent"
4894 begin match state
.autoscroll
with
4896 conf
.autoscrollstep
<- step
;
4897 state
.autoscroll
<- None
4899 if conf
.autoscrollstep
= 0
4900 then state
.autoscroll
<- Some
1
4901 else state
.autoscroll
<- Some conf
.autoscrollstep
4905 launchpath () (* XXX where do error messages go? *)
4908 setpresentationmode (not conf
.presentation
);
4909 showtext ' '
("presentation mode " ^
4910 if conf
.presentation
then "on" else "off");
4913 if List.mem
Wsi.Fullscreen state
.winstate
4914 then Wsi.reshape conf
.cwinw conf
.cwinh
4915 else Wsi.fullscreen
()
4918 search state
.searchpattern
false
4921 search state
.searchpattern
true
4924 begin match state
.layout with
4927 gotoghyll (getpagey
l.pageno)
4933 | @delete
| @kpdelete
-> (* delete *)
4937 showtext ' '
(describe_location ());
4940 begin match state
.layout with
4943 Wsi.reshape (l.pagew
+ vscrollw ()) l.pageh
;
4948 enterbookmarkmode
()
4956 | @e when Buffer.length state
.errmsgs
> 0 ->
4961 match state
.layout with
4966 (s, 0, Oanchor
(getanchor1
l)) :: state
.bookmarks
4969 enttext ("bookmark: ", E.s, None
, textentry, ondone, true)
4973 showtext ' '
"Quick bookmark added";
4976 begin match state
.layout with
4978 let rect = getpdimrect
l.pagedimno
in
4982 (truncate
(1.8 *. (rect.(1) -. rect.(0))),
4983 truncate
(1.2 *. (rect.(3) -. rect.(0))))
4985 (truncate
(rect.(1) -. rect.(0)),
4986 truncate
(rect.(3) -. rect.(0)))
4988 let w = truncate
((float w)*.conf
.zoom)
4989 and h = truncate
((float h)*.conf
.zoom) in
4992 state
.anchor <- getanchor
();
4993 Wsi.reshape (w + vscrollw ()) (h + conf
.interpagespace
)
4995 G.postRedisplay "z";
5000 | @x -> state
.roam
()
5003 reqlayout (conf
.angle
+
5004 (if key = @Gt
then 30 else -30)) conf
.fitmodel
5008 bound
(conf
.colorscale
+. (if key = 93 then 0.1 else -0.1)) 0.0 1.0
5010 G.postRedisplay "brightness";
5012 | @c when state
.mode = View
->
5017 let m = (wadjsb () + state
.winw
- state
.w) / 2 in
5019 gotoy_and_clear_text state
.y
5023 match state
.prevcolumns
with
5024 | None
-> (1, 0, 0), 1.0
5025 | Some
(columns
, z
) ->
5028 | Csplit
(c, _) -> -c, 0, 0
5029 | Cmulti
((c, a, b), _) -> c, a, b
5030 | Csingle
_ -> 1, 0, 0
5034 setcolumns View
c a b;
5037 | @down
| @up
when ctrl && Wsi.withshift mask
->
5038 let zoom, x = state
.prevzoom
in
5042 | @k
| @up
| @kpup
->
5043 begin match state
.autoscroll
with
5045 begin match state
.mode with
5046 | Birdseye beye
-> upbirdseye 1 beye
5051 then gotoy_and_clear_text (clamp ~
-(state
.winh
/2))
5053 if not
(Wsi.withshift mask
) && conf
.presentation
5055 else gotoghyll1 true (clamp (-conf
.scrollstep
))
5059 setautoscrollspeed n false
5062 | @j
| @down
| @kpdown
->
5063 begin match state
.autoscroll
with
5065 begin match state
.mode with
5066 | Birdseye beye
-> downbirdseye 1 beye
5071 then gotoy_and_clear_text (clamp (state
.winh
/2))
5073 if not
(Wsi.withshift mask
) && conf
.presentation
5075 else gotoghyll1 true (clamp (conf
.scrollstep
))
5079 setautoscrollspeed n true
5082 | @left | @right
| @kpleft
| @kpright
when not
(Wsi.withalt mask
) ->
5088 else conf
.hscrollstep
5090 let dx = if key = @left || key = @kpleft
then dx else -dx in
5091 state
.x <- panbound (state
.x + dx);
5092 gotoy_and_clear_text state
.y
5095 G.postRedisplay "left/right"
5098 | @prior
| @kpprior
->
5102 match state
.layout with
5104 | l :: _ -> state
.y - l.pagey
5106 clamp (pgscale (-state
.winh
))
5110 | @next | @kpnext
->
5114 match List.rev state
.layout with
5116 | l :: _ -> getpagey
l.pageno
5118 clamp (pgscale state
.winh
)
5122 | @g | @home
| @kphome
->
5125 | @G
| @jend
| @kpend
->
5127 gotoghyll (clamp state
.maxy)
5129 | @right
| @kpright
when Wsi.withalt mask
->
5130 gotoghyll (getnav 1)
5131 | @left | @kpleft
when Wsi.withalt mask
->
5132 gotoghyll (getnav ~
-1)
5137 | @v when conf
.debug
->
5140 match getopaque l.pageno with
5143 let x0, y0, x1, y1 = pagebbox
opaque in
5144 let a,b = float x0, float y0 in
5145 let c,d = float x1, float y0 in
5146 let e,f = float x1, float y1 in
5147 let h,j
= float x0, float y1 in
5148 let rect = (a,b,c,d,e,f,h,j
) in
5150 let color = (0.0, 0.0, 1.0 /. (l.pageno mod 3 |> float), 0.5) in
5151 state
.rects
<- (l.pageno, color, rect) :: state
.rects
;
5153 G.postRedisplay "v";
5156 let mode = state
.mode in
5157 let cmd = ref E.s in
5158 let onleave = function
5159 | Cancel
-> state
.mode <- mode
5162 match getopaque l.pageno with
5163 | Some
opaque -> pipesel opaque !cmd
5164 | None
-> ()) state
.layout;
5168 cbput state
.hists
.sel
s;
5172 "| ", !cmd, Some
(onhist state
.hists
.sel
), textentry, ondone, true
5174 G.postRedisplay "|";
5175 state
.mode <- Textentry
(te, onleave);
5178 vlog "huh? %s" (Wsi.keyname
key)
5181 let linknavkeyboard key mask
linknav =
5182 let getpage pageno =
5183 let rec loop = function
5185 | l :: _ when l.pageno = pageno -> Some
l
5186 | _ :: rest
-> loop rest
5187 in loop state
.layout
5189 let doexact (pageno, n) =
5190 match getopaque pageno, getpage pageno with
5191 | Some
opaque, Some
l ->
5192 if key = @enter || key = @kpenter
5194 let under = getlink
opaque n in
5195 G.postRedisplay "link gotounder";
5202 Some
(findlink
opaque LDfirst
), -1
5205 Some
(findlink
opaque LDlast
), 1
5208 Some
(findlink
opaque (LDleft
n)), -1
5211 Some
(findlink
opaque (LDright
n)), 1
5214 Some
(findlink
opaque (LDup
n)), -1
5217 Some
(findlink
opaque (LDdown
n)), 1
5222 begin match findpwl
l.pageno dir with
5226 state
.mode <- LinkNav
(Ltgendir
dir);
5227 let y, h = getpageyh
pageno in
5230 then y + h - state
.winh
5235 begin match getopaque pageno, getpage pageno with
5236 | Some
opaque, Some
_ ->
5238 let ld = if dir > 0 then LDfirst
else LDlast
in
5241 begin match link with
5243 showlinktype (getlink
opaque m);
5244 state
.mode <- LinkNav
(Ltexact
(pageno, m));
5245 G.postRedisplay "linknav jpage";
5246 | Lnotfound
-> notfound dir
5252 begin match opt with
5253 | Some Lnotfound
-> pwl l dir;
5254 | Some
(Lfound
m) ->
5258 let _, y0, _, y1 = getlinkrect
opaque m in
5260 then gotopage1 l.pageno y0
5262 let d = fstate
.fontsize
+ 1 in
5263 if y1 - l.pagey > l.pagevh - d
5264 then gotopage1 l.pageno (y1 - state
.winh
- hscrollh () + d)
5265 else G.postRedisplay "linknav";
5267 showlinktype (getlink
opaque m);
5268 state
.mode <- LinkNav
(Ltexact
(l.pageno, m));
5271 | None
-> viewkeyboard key mask
5273 | _ -> viewkeyboard key mask
5278 G.postRedisplay "leave linknav"
5282 | Ltgendir
_ | Ltnotready
_ -> viewkeyboard key mask
5283 | Ltexact exact
-> doexact exact
5286 let keyboard key mask
=
5287 if (key = @g && Wsi.withctrl mask
) && not
(istextentry state
.mode)
5288 then wcmd "interrupt"
5289 else state
.uioh <- state
.uioh#
key key mask
5292 let birdseyekeyboard key mask
5293 ((oconf
, leftx
, pageno, hooverpageno
, anchor) as beye
) =
5295 match conf
.columns
with
5297 | Cmulti
((c, _, _), _) -> c
5298 | Csplit
_ -> failwith
"bird's eye split mode"
5300 let pgh layout = List.fold_left
5301 (fun m l -> max
l.pageh
m) state
.winh
layout in
5303 | @l when Wsi.withctrl mask
->
5304 let y, h = getpageyh
pageno in
5305 let top = (state
.winh
- h) / 2 in
5306 gotoy (max
0 (y - top))
5307 | @enter | @kpenter
-> leavebirdseye beye
false
5308 | @escape
-> leavebirdseye beye
true
5309 | @up
-> upbirdseye incr beye
5310 | @down
-> downbirdseye incr beye
5311 | @left -> upbirdseye 1 beye
5312 | @right
-> downbirdseye 1 beye
5315 begin match state
.layout with
5319 state
.mode <- Birdseye
(
5320 oconf
, leftx
, l.pageno, hooverpageno
, anchor
5322 gotopage1 l.pageno 0;
5325 let layout = layout (state
.y-state
.winh
) (pgh state
.layout) in
5327 | [] -> gotoy (clamp (-state
.winh
))
5329 state
.mode <- Birdseye
(
5330 oconf
, leftx
, l.pageno, hooverpageno
, anchor
5332 gotopage1 l.pageno 0
5335 | [] -> gotoy (clamp (-state
.winh
))
5339 begin match List.rev state
.layout with
5341 let layout = layout (state
.y + (pgh state
.layout)) state
.winh
in
5342 begin match layout with
5344 let incr = l.pageh
- l.pagevh in
5349 oconf
, leftx
, state
.pagecount
- 1, hooverpageno
, anchor
5351 G.postRedisplay "birdseye pagedown";
5353 else gotoy (clamp (incr + conf
.interpagespace
*2));
5357 Birdseye
(oconf
, leftx
, l.pageno, hooverpageno
, anchor);
5358 gotopage1 l.pageno 0;
5361 | [] -> gotoy (clamp state
.winh
)
5365 state
.mode <- Birdseye
(oconf
, leftx
, 0, hooverpageno
, anchor);
5369 let pageno = state
.pagecount
- 1 in
5370 state
.mode <- Birdseye
(oconf
, leftx
, pageno, hooverpageno
, anchor);
5371 if not
(pagevisible state
.layout pageno)
5374 match List.rev state
.pdims
with
5376 | (_, _, h, _) :: _ -> h
5378 gotoy (max
0 (getpagey
pageno - (state
.winh
- h - conf
.interpagespace
)))
5379 else G.postRedisplay "birdseye end";
5381 | _ -> viewkeyboard key mask
5386 match state
.mode with
5387 | Textentry
_ -> scalecolor 0.4
5389 | View
-> scalecolor 1.0
5390 | Birdseye
(_, _, pageno, hooverpageno
, _) ->
5391 if l.pageno = hooverpageno
5394 if l.pageno = pageno
5396 let c = scalecolor 1.0 in
5398 GlDraw.line_width
3.0;
5399 let dispx = xadjsb () + l.pagedispx in
5401 (float (dispx-1)) (float (l.pagedispy-1))
5402 (float (dispx+l.pagevw+1))
5403 (float (l.pagedispy+l.pagevh+1))
5405 GlDraw.line_width
1.0;
5414 let postdrawpage l linkindexbase
=
5415 match getopaque l.pageno with
5417 if tileready l l.pagex
l.pagey
5419 let x = l.pagedispx - l.pagex
+ xadjsb ()
5420 and y = l.pagedispy - l.pagey in
5422 match conf
.columns
with
5423 | Csingle
_ | Cmulti
_ ->
5424 (if conf
.hlinks
then 1 else 0)
5426 && not
(isbirdseye state
.mode) then 2 else 0)
5430 match state
.mode with
5431 | Textentry
((_, s, _, _, _, _), _) when state
.glinks
-> s
5437 Hashtbl.find_all state
.prects
l.pageno |>
5438 List.iter
(fun vals
-> drawprect
opaque x y vals
);
5439 postprocess
opaque hlmask x y (linkindexbase
, s, conf
.hfsize
);
5444 let scrollindicator () =
5445 let sbw, ph
, sh = state
.uioh#
scrollph in
5446 let sbh, pw, sw = state
.uioh#scrollpw
in
5451 else ((state
.winw
- sbw), state
.winw
, 0)
5454 GlDraw.color (0.64, 0.64, 0.64);
5455 filledrect (float x0) 0. (float x1) (float state
.winh
);
5457 (float hx0
) (float (state
.winh
- sbh))
5458 (float (hx0
+ wadjsb () + state
.winw
)) (float state
.winh
)
5460 GlDraw.color (0.0, 0.0, 0.0);
5462 filledrect (float x0) ph
(float x1) (ph
+. sh);
5463 let pw = pw +. float hx0
in
5464 filledrect pw (float (state
.winh
- sbh)) (pw +. sw) (float state
.winh
);
5468 match state
.mstate
with
5469 | Mnone
| Mscrolly
| Mscrollx
| Mpan
_ | Mzoom
_ | Mzoomrect
_ ->
5472 | Msel
((x0, y0), (x1, y1)) ->
5473 let identify opaque l px py = Some
(opaque, l.pageno, px, py) in
5474 let o0,n0
,px0
,py0
= onppundermouse identify x0 y0 (~
< E.s, -1, 0, 0) in
5475 let _o1,n1
,px1
,py1
= onppundermouse identify x1 y1 (~
< E.s, -1, 0, 0) in
5476 if n0
!= -1 && n0
= n1
then seltext
o0 (px0
, py0
, px1
, py1
);
5479 let showrects = function [] -> () | rects
->
5481 GlDraw.color (0.0, 0.0, 1.0) ~
alpha:0.5;
5482 GlFunc.blend_func ~
src:`src_alpha ~dst
:`one_minus_src_alpha
;
5484 (fun (pageno, c, (x0, y0, x1, y1, x2
, y2
, x3
, y3
)) ->
5486 if l.pageno = pageno
5488 let dx = float (l.pagedispx - l.pagex
) in
5489 let dy = float (l.pagedispy - l.pagey) in
5490 let r, g, b, alpha = c in
5491 GlDraw.color (r, g, b) ~
alpha;
5492 Raw.sets_float state
.vraw ~
pos:0
5497 GlArray.vertex `two state
.vraw
;
5498 GlArray.draw_arrays `triangle_strip ~
first:0 ~count
:4;
5507 GlClear.color (scalecolor2 conf
.bgcolor
);
5508 GlClear.clear
[`
color];
5509 List.iter
drawpage state
.layout;
5511 match state
.mode with
5512 | LinkNav
(Ltexact
(pageno, linkno
)) ->
5513 begin match getopaque pageno with
5515 let dx = xadjsb () in
5516 let x0, y0, x1, y1 = getlinkrect
opaque linkno
in
5517 let x0 = x0 + dx and x1 = x1 + dx in
5518 let color = (0.0, 0.0, 0.5, 0.5) in
5525 | None
-> state
.rects
5527 | LinkNav
(Ltgendir
_) | LinkNav
(Ltnotready
_)
5530 | View
-> state
.rects
5533 let rec postloop linkindexbase
= function
5535 let linkindexbase = linkindexbase + postdrawpage l linkindexbase in
5536 postloop linkindexbase rest
5540 postloop 0 state
.layout;
5542 begin match state
.mstate
with
5543 | Mzoomrect
((x0, y0), (x1, y1)) ->
5545 GlDraw.color (0.3, 0.3, 0.3) ~
alpha:0.5;
5546 GlFunc.blend_func ~
src:`src_alpha ~dst
:`one_minus_src_alpha
;
5547 filledrect (float x0) (float y0) (float x1) (float y1);
5551 | Mscrolly
| Mscrollx
5560 let zoomrect x y x1 y1 =
5563 and y0 = min
y y1 in
5564 gotoy (state
.y + y0);
5565 state
.anchor <- getanchor
();
5566 let zoom = (float state
.w) /. float (x1 - x0) in
5569 let adjw = wadjsb () + state
.winw
in
5571 then (adjw - state
.w) / 2
5574 match conf
.fitmodel
with
5575 | FitWidth
| FitProportional
-> simple ()
5577 match conf
.columns
with
5579 onppundermouse (fun _ l _ _ -> Some
l.pagedispx) x0 y0 x0
5580 | Cmulti
_ | Csingle
_ -> simple ()
5582 state
.x <- (state
.x + margin) - x0;
5587 let annot inline
x y =
5588 match unproject x y with
5589 | Some
(opaque, n, ux
, uy
) ->
5591 addannot
opaque ux uy
text;
5592 wcmd "freepage %s" (~
> opaque);
5593 Hashtbl.remove state
.pagemap
(n, state
.gen
);
5599 let ondone s = add s in
5600 let mode = state
.mode in
5601 state
.mode <- Textentry
(
5602 ("annotation: ", E.s, None
, textentry, ondone, true),
5603 fun _ -> state
.mode <- mode);
5606 G.postRedisplay "annot"
5608 add @@ getusertext E.s
5613 let g opaque l px py =
5614 match rectofblock
opaque px py with
5616 let x0 = a.(0) -. 20. in
5617 let x1 = a.(1) +. 20. in
5618 let y0 = a.(2) -. 20. in
5619 let zoom = (float state
.w) /. (x1 -. x0) in
5620 let pagey = getpagey
l.pageno in
5621 gotoy_and_clear_text (pagey + truncate
y0);
5622 state
.anchor <- getanchor
();
5623 let margin = (state
.w - l.pagew
)/2 in
5624 state
.x <- -truncate
x0 - margin;
5629 match conf
.columns
with
5631 impmsg "block zooming does not work properly in split columns mode"
5632 | Cmulti
_ | Csingle
_ -> onppundermouse g x y ()
5636 let winw = wadjsb () + state
.winw - 1 in
5637 let s = float x /. float winw in
5638 let destx = truncate
(float (state
.w + winw) *. s) in
5639 state
.x <- winw - destx;
5640 gotoy_and_clear_text state
.y;
5641 state
.mstate
<- Mscrollx
;
5645 let s = float y /. float state
.winh
in
5646 let desty = truncate
(float (state
.maxy - state
.winh
) *. s) in
5647 gotoy_and_clear_text desty;
5648 state
.mstate
<- Mscrolly
;
5651 let viewmulticlick clicks
x y mask
=
5652 let g opaque l px py =
5660 if markunder
opaque px py mark
5664 match getopaque l.pageno with
5666 | Some
opaque -> pipesel opaque cmd
5668 state
.roam
<- (fun () -> dopipe conf
.paxcmd
);
5669 if not
(Wsi.withctrl mask
) then dopipe conf
.selcmd
;
5674 G.postRedisplay "viewmulticlick";
5675 onppundermouse g x y (fun () -> impmsg "nothing to select") ();
5679 match conf
.columns
with
5681 | Csingle
_ | Cmulti
_ -> conf
.angle
mod 360 = 0
5684 let viewmouse button down
x y mask
=
5686 | n when (n == 4 || n == 5) && not down
->
5687 if Wsi.withctrl mask
5689 match state
.mstate
with
5690 | Mzoom
(oldn
, i
) ->
5698 if conf
.zoom +. 0.01 > 0.1 then 0.1 else 0.01
5700 if conf
.zoom -. 0.1 < 0.1 then -0.01 else -0.1
5702 let zoom = conf
.zoom -. incr in
5704 state
.mstate
<- Mzoom
(n, 0);
5706 state
.mstate
<- Mzoom
(n, i
+1);
5708 else state
.mstate
<- Mzoom
(n, 0)
5712 | Mscrolly
| Mscrollx
5714 | Mnone
-> state
.mstate
<- Mzoom
(n, 0)
5717 match state
.autoscroll
with
5718 | Some step
-> setautoscrollspeed step
(n=4)
5720 if conf
.wheelbypage
|| conf
.presentation
5729 then -conf
.scrollstep
5730 else conf
.scrollstep
5732 let incr = incr * 2 in
5733 let y = clamp incr in
5734 gotoy_and_clear_text y
5737 | n when (n = 6 || n = 7) && not down
&& canpan () ->
5739 panbound (state
.x + (if n = 7 then -2 else 2) * conf
.hscrollstep
);
5740 gotoy_and_clear_text state
.y
5742 | 1 when Wsi.withshift mask
->
5743 state
.mstate
<- Mnone
;
5746 match unproject x y with
5748 | Some
(_, pageno, ux
, uy
) ->
5749 let cmd = Printf.sprintf
5751 conf
.stcmd state
.path pageno ux uy
5753 match spawn
cmd [] with
5754 | (exception exn
) ->
5755 impmsg "execution of synctex command(%S) failed: %S"
5756 conf
.stcmd
@@ exntos exn
5760 | 1 when Wsi.withctrl mask
->
5763 Wsi.setcursor
Wsi.CURSOR_FLEUR
;
5764 state
.mstate
<- Mpan
(x, y)
5767 state
.mstate
<- Mnone
5772 if Wsi.withshift mask
5774 annot conf
.annotinline
x y;
5775 G.postRedisplay "addannot"
5779 Wsi.setcursor
Wsi.CURSOR_CYCLE
;
5780 state
.mstate
<- Mzoomrect
(p, p)
5783 match state
.mstate
with
5784 | Mzoomrect
((x0, y0), _) ->
5785 if abs
(x-x0) > 10 && abs
(y - y0) > 10
5786 then zoomrect x0 y0 x y
5789 G.postRedisplay "kill accidental zoom rect";
5793 | Mscrolly
| Mscrollx
5799 | 1 when vscrollhit x ->
5802 let _, position, sh = state
.uioh#
scrollph in
5803 if y > truncate
position && y < truncate
(position +. sh)
5804 then state
.mstate
<- Mscrolly
5807 state
.mstate
<- Mnone
5809 | 1 when y > state
.winh
- hscrollh () ->
5812 let _, position, sw = state
.uioh#scrollpw
in
5813 if x > truncate
position && x < truncate
(position +. sw)
5814 then state
.mstate
<- Mscrollx
5817 state
.mstate
<- Mnone
5819 | 1 when state
.bzoom
-> if not down
then zoomblock x y
5822 let dest = if down
then getunder x y else Unone
in
5823 begin match dest with
5826 | Uremote
_ | Uremotedest
_
5827 | Uunexpected
_ | Ulaunch
_ | Unamed
_ ->
5830 | Unone
when down
->
5831 Wsi.setcursor
Wsi.CURSOR_FLEUR
;
5832 state
.mstate
<- Mpan
(x, y);
5834 | Uannotation
(opaque, slinkindex
) -> enterannotmode opaque slinkindex
5836 | Unone
| Utext
_ ->
5841 state
.mstate
<- Msel
((x, y), (x, y));
5842 G.postRedisplay "mouse select";
5846 match state
.mstate
with
5849 | Mzoom
_ | Mscrollx
| Mscrolly
->
5850 state
.mstate
<- Mnone
5852 | Mzoomrect
((x0, y0), _) ->
5856 Wsi.setcursor
Wsi.CURSOR_INHERIT
;
5857 state
.mstate
<- Mnone
5859 | Msel
((x0, y0), (x1, y1)) ->
5860 let rec loop = function
5864 let a0 = l.pagedispy in
5865 let a1 = a0 + l.pagevh in
5866 let b0 = l.pagedispx in
5867 let b1 = b0 + l.pagevw in
5868 ((y0 >= a0 && y0 <= a1) || (y1 >= a0 && y1 <= a1))
5869 && ((x0 >= b0 && x0 <= b1) || (x1 >= b0 && x1 <= b1))
5873 match getopaque l.pageno with
5876 match Unix.pipe
() with
5877 | (exception exn
) ->
5878 impmsg "cannot create sel pipe: %s" @@
5882 Ne.clo fd
(fun msg
->
5883 dolog
"%s close failed: %s" what msg
)
5886 try spawn
cmd [r, 0; w, -1]
5888 dolog
"cannot execute %S: %s"
5895 G.postRedisplay "copysel";
5897 else clo "Msel pipe/w" w;
5898 clo "Msel pipe/r" r;
5900 dosel conf
.selcmd
();
5901 state
.roam
<- dosel conf
.paxcmd
;
5913 let birdseyemouse button down
x y mask
5914 (conf
, leftx
, _, hooverpageno
, anchor) =
5917 let rec loop = function
5920 if y > l.pagedispy && y < l.pagedispy + l.pagevh
5921 && x > l.pagedispx && x < l.pagedispx + l.pagevw
5923 leavebirdseye (conf
, leftx
, l.pageno, hooverpageno
, anchor) false;
5929 | _ -> viewmouse button down
x y mask
5935 method key key mask
=
5936 begin match state
.mode with
5937 | Textentry
textentry -> textentrykeyboard key mask
textentry
5938 | Birdseye
birdseye -> birdseyekeyboard key mask
birdseye
5939 | View
-> viewkeyboard key mask
5940 | LinkNav
linknav -> linknavkeyboard key mask
linknav
5944 method button button bstate
x y mask
=
5945 begin match state
.mode with
5947 | View
-> viewmouse button bstate
x y mask
5948 | Birdseye beye
-> birdseyemouse button bstate
x y mask beye
5953 method multiclick clicks
x y mask
=
5954 begin match state
.mode with
5956 | View
-> viewmulticlick clicks
x y mask
5963 begin match state
.mode with
5965 | View
| Birdseye
_ | LinkNav
_ ->
5966 match state
.mstate
with
5967 | Mzoom
_ | Mnone
-> ()
5972 state
.mstate
<- Mpan
(x, y);
5974 then state
.x <- panbound (state
.x + dx);
5976 gotoy_and_clear_text y
5979 state
.mstate
<- Msel
(a, (x, y));
5980 G.postRedisplay "motion select";
5983 let y = min state
.winh
(max
0 y) in
5987 let x = min state
.winw (max
0 x) in
5990 | Mzoomrect
(p0
, _) ->
5991 state
.mstate
<- Mzoomrect
(p0
, (x, y));
5992 G.postRedisplay "motion zoomrect";
5996 method pmotion
x y =
5997 begin match state
.mode with
5998 | Birdseye
(conf
, leftx
, pageno, hooverpageno
, anchor) ->
5999 let rec loop = function
6001 if hooverpageno
!= -1
6003 state
.mode <- Birdseye
(conf
, leftx
, pageno, -1, anchor);
6004 G.postRedisplay "pmotion birdseye no hoover";
6007 if y > l.pagedispy && y < l.pagedispy + l.pagevh
6008 && x > l.pagedispx && x < l.pagedispx + l.pagevw
6010 state
.mode <- Birdseye
(conf
, leftx
, pageno, l.pageno, anchor);
6011 G.postRedisplay "pmotion birdseye hoover";
6021 match state
.mstate
with
6022 | Mpan
_ | Msel
_ | Mzoom
_ | Mscrolly
| Mscrollx
| Mzoomrect
_ -> ()
6030 let past, _, _ = !r in
6032 let delta = now -. past in
6035 else r := (now, x, y)
6039 method infochanged
_ = ()
6042 let maxy = state
.maxy - (if conf
.maxhfit
then state
.winh
else 0) in
6045 then 0.0, float state
.winh
6046 else scrollph state
.y maxy
6051 let winw = wadjsb () + state
.winw in
6052 let fwinw = float winw in
6054 let sw = fwinw /. float state
.w in
6055 let sw = fwinw *. sw in
6056 max
sw (float conf
.scrollh
)
6059 let maxx = state
.w + winw in
6060 let x = winw - state
.x in
6061 let percent = float x /. float maxx in
6062 (fwinw -. sw) *. percent
6064 hscrollh (), position, sw
6068 match state
.mode with
6069 | LinkNav
_ -> "links"
6070 | Textentry
_ -> "textentry"
6071 | Birdseye
_ -> "birdseye"
6074 findkeyhash conf
modename
6076 method eformsgs
= true
6077 method alwaysscrolly
= false
6080 let adderrmsg src msg
=
6081 Buffer.add_string state
.errmsgs msg
;
6082 state
.newerrmsgs
<- true;
6086 let adderrfmt src fmt
=
6087 Format.ksprintf
(fun s -> adderrmsg src s) fmt
;
6090 let addrect pageno r g b a x0 y0 x1 y1 =
6091 Hashtbl.add state
.prects
pageno [|r; g; b; a; x0; y0; x1; y1|];
6095 let cl = splitatspace cmds
in
6097 try Scanf.sscanf
s fmt
f
6099 adderrfmt "remote exec"
6100 "error processing '%S': %s\n" cmds
@@ exntos exn
6102 let rectx s pageno (r, g, b, a) x0 y0 x1 y1 =
6103 vlog "%s page %d color (%f %f %f %f) x0,y0,x1,y1 = %f %f %f %f"
6104 s pageno r g b a x0 y0 x1 y1;
6108 let _,w1,h1
,_ = getpagedim
pageno in
6109 let sw = float w1 /. float w
6110 and sh = float h1
/. float h in
6114 and y1s
= y1 *. sh in
6115 let rect = (x0s,y0s
,x1s
,y0s
,x1s
,y1s
,x0s,y1s
) in
6116 let color = (r, g, b, a) in
6117 if conf
.verbose
then debugrect rect;
6118 state
.rects <- (pageno, color, rect) :: state
.rects;
6123 | "reload" :: [] -> reload ()
6124 | "goto" :: args
:: [] ->
6125 scan args
"%u %f %f"
6127 let cmd, _ = state
.geomcmds
in
6129 then gotopagexy pageno x y
6132 gotopagexy pageno x y;
6135 state
.reprf
<- f state
.reprf
6137 | "goto1" :: args
:: [] -> scan args
"%u %f" gotopage
6138 | "gotor" :: args
:: [] ->
6140 (fun filename
pageno -> gotounder (Uremote
(filename
, pageno)))
6141 | "gotord" :: args
:: [] ->
6143 (fun filename
dest -> gotounder (Uremotedest
(filename
, dest)))
6144 | "rect" :: args
:: [] ->
6145 scan args
"%u %u %f %f %f %f"
6146 (fun pageno c x0 y0 x1 y1 ->
6147 let color = (0.0, 0.0, 1.0 /. float c, 0.5) in
6148 rectx "rect" pageno color x0 y0 x1 y1;
6150 | "prect" :: args
:: [] ->
6151 scan args
"%u %f %f %f %f %f %f %f %f"
6152 (fun pageno r g b alpha x0 y0 x1 y1 ->
6153 addrect pageno r g b alpha x0 y0 x1 y1;
6154 G.postRedisplay "prect"
6156 | "pgoto" :: args
:: [] ->
6157 scan args
"%u %f %f"
6160 let rec fixx = function
6163 if l.pageno = pageno
6165 state
.x <- state
.x - l.pagedispx;
6172 let ww = state
.winw in
6173 state
.winw <- state
.winw * 10;
6174 let res = layout state
.y state
.winh
in
6181 | "activatewin" :: [] -> Wsi.activatewin
()
6182 | "quit" :: [] -> raise Quit
6183 | "clearrects" :: [] ->
6184 Hashtbl.clear state
.prects
;
6185 G.postRedisplay "clearrects"
6187 adderrfmt "remote command"
6188 "error processing remote command: %S\n" cmds
;
6192 let scratch = Bytes.create
80 in
6193 let buf = Buffer.create
80 in
6195 match tempfailureretry
(Unix.read fd
scratch 0) 80 with
6196 | (exception Unix.Unix_error
(Unix.EAGAIN
, _, _)) -> None
6199 if Buffer.length
buf > 0
6201 let s = Buffer.contents
buf in
6209 match Bytes.index_from
scratch ppos '
\n'
with
6210 | pos -> if pos >= n then -1 else pos
6211 | (exception Not_found
) -> -1
6215 Buffer.add_subbytes
buf scratch ppos
(nlpos-ppos
);
6216 let s = Buffer.contents
buf in
6222 Buffer.add_subbytes
buf scratch ppos
(n-ppos
);
6228 let remoteopen path =
6229 try Some
(Unix.openfile
path [Unix.O_NONBLOCK
; Unix.O_RDONLY
] 0o0)
6231 adderrfmt "remoteopen" "error opening %S: %s" path @@ exntos exn
;
6236 let gcconfig = ref E.s in
6237 let trimcachepath = ref E.s in
6238 let rcmdpath = ref E.s in
6239 let pageno = ref None
in
6240 let rootwid = ref 0 in
6241 let openlast = ref false in
6242 let nofc = ref false in
6243 let doreap = ref false in
6244 selfexec := Sys.executable_name
;
6247 [("-p", Arg.String
(fun s -> state
.password <- s),
6248 "<password> Set password");
6252 Config.fontpath
:= s;
6253 selfexec := !selfexec ^
" -f " ^
Filename.quote
s;
6255 "<path> Set path to the user interface font");
6259 selfexec := !selfexec ^
" -c " ^
Filename.quote
s;
6260 Config.confpath
:= s),
6261 "<path> Set path to the configuration file");
6263 ("-last", Arg.Set
openlast, " Open last document");
6265 ("-page", Arg.Int
(fun pageno1
-> pageno := Some
(pageno1
-1)),
6266 "<page-number> Jump to page");
6268 ("-tcf", Arg.String
(fun s -> trimcachepath := s),
6269 "<path> Set path to the trim cache file");
6271 ("-dest", Arg.String
(fun s -> state
.nameddest
<- s),
6272 "<named-destination> Set named destination");
6274 ("-wtmode", Arg.Set
wtmode, " Operate in wt mode");
6275 ("-cxack", Arg.Set
cxack, " Cut corners");
6277 ("-remote", Arg.String
(fun s -> rcmdpath := s),
6278 "<path> Set path to the remote commands source");
6280 ("-origin", Arg.String
(fun s -> state
.origin
<- s),
6281 "<original-path> Set original path");
6283 ("-gc", Arg.Set_string
gcconfig,
6284 "<script-path> Collect garbage with the help of a script");
6286 ("-nofc", Arg.Set
nofc, " Do not use fontconfig");
6288 ("-v", Arg.Unit
(fun () ->
6290 "%s\nconfiguration path: %s\n"
6294 exit
0), " Print version and exit");
6296 ("-embed", Arg.Set_int
rootwid,
6297 "<window-id> Embed into window")
6300 (fun s -> state
.path <- s)
6301 ("Usage: " ^
Sys.argv
.(0) ^
" [options] some.pdf\nOptions:")
6304 then selfexec := !selfexec ^
" -wtmode";
6306 let histmode = emptystr state
.path && not
!openlast in
6308 if not
(Config.load !openlast)
6309 then dolog
"failed to load configuration";
6310 begin match !pageno with
6311 | Some
pageno -> state
.anchor <- (pageno, 0.0, 0.0)
6315 if nonemptystr
!gcconfig
6318 match Unix.socketpair
Unix.PF_UNIX
Unix.SOCK_STREAM
0 with
6319 | (exception exn
) -> error
"socketpair for gc failed: %s" @@ exntos exn
6322 match spawn
!gcconfig [(c, 0); (c, 1); (s, -1)] with
6323 | (exception exn
) -> error
"failed to execute gc script: %s" @@ exntos exn
6325 Ne.clo c @@ (fun s -> error
"failed to close gc fd %s" s);
6330 let wsfd, winw, winh
= Wsi.init
(object (self)
6331 val mutable m_clicks
= 0
6332 val mutable m_click_x
= 0
6333 val mutable m_click_y
= 0
6334 val mutable m_lastclicktime
= infinity
6336 method private cleanup =
6337 state
.roam
<- noroam
;
6338 Hashtbl.iter
(fun _ opaque -> clearmark
opaque) state
.pagemap
6339 method expose
= G.postRedisplay"expose"
6343 | Wsi.Unobscured
-> "unobscured"
6344 | Wsi.PartiallyObscured
-> "partiallyobscured"
6345 | Wsi.FullyObscured
-> "fullyobscured"
6347 vlog "visibility change %s" name
6348 method display = display ()
6349 method map mapped
= vlog "mappped %b" mapped
6350 method reshape w h =
6353 method mouse
b d x y m =
6354 if d && canselect ()
6356 (* http://blogs.msdn.com/b/oldnewthing/archive/2004/10/18/243925.aspx *)
6362 if abs
x - m_click_x
> 10
6363 || abs
y - m_click_y
> 10
6364 || abs_float
(t -. m_lastclicktime
) > 0.3
6366 m_clicks
<- m_clicks
+ 1;
6367 m_lastclicktime
<- t;
6371 G.postRedisplay "cleanup";
6372 state
.uioh <- state
.uioh#button
b d x y m;
6374 else state
.uioh <- state
.uioh#multiclick m_clicks
x y m
6379 m_lastclicktime
<- infinity
;
6380 state
.uioh <- state
.uioh#button
b d x y m
6384 state
.uioh <- state
.uioh#button
b d x y m
6387 state
.mpos
<- (x, y);
6388 state
.uioh <- state
.uioh#motion
x y
6389 method pmotion
x y =
6390 state
.mpos
<- (x, y);
6391 state
.uioh <- state
.uioh#pmotion
x y
6393 let mascm = m land (
6394 Wsi.altmask
+ Wsi.shiftmask
+ Wsi.ctrlmask
+ Wsi.metamask
6397 let x = state
.x and y = state
.y in
6399 if x != state
.x || y != state
.y then self#
cleanup
6401 match state
.keystate
with
6403 let km = k
, mascm in
6406 let modehash = state
.uioh#
modehash in
6407 try Hashtbl.find modehash km
6409 try Hashtbl.find (findkeyhash conf
"global") km
6410 with Not_found
-> KMinsrt
(k
, m)
6412 | KMinsrt
(k
, m) -> keyboard k
m
6413 | KMinsrl
l -> List.iter
(fun (k
, m) -> keyboard k
m) l
6414 | KMmulti
(l, r) -> state
.keystate
<- KSinto
(l, r)
6416 | KSinto
((k'
, m'
) :: [], insrt
) when k'
=k
&& m'
land mascm = m'
->
6417 List.iter
(fun (k
, m) -> keyboard k
m) insrt
;
6418 state
.keystate
<- KSnone
6419 | KSinto
((k'
, m'
) :: keys, insrt
) when k'
=k
&& m'
land mascm = m'
->
6420 state
.keystate
<- KSinto
(keys, insrt
)
6421 | KSinto
_ -> state
.keystate
<- KSnone
6424 state
.mpos
<- (x, y);
6425 state
.uioh <- state
.uioh#pmotion
x y
6426 method leave = state
.mpos
<- (-1, -1)
6427 method winstate wsl
= state
.winstate
<- wsl
6428 method quit
= raise Quit
6429 end) !rootwid conf
.cwinw conf
.cwinh platform
in
6434 List.exists
GlMisc.check_extension
6435 [ "GL_ARB_texture_rectangle"
6436 ; "GL_EXT_texture_recangle"
6437 ; "GL_NV_texture_rectangle" ]
6439 then (dolog
"OpenGL does not suppport rectangular textures"; exit
1);
6442 let r = GlMisc.get_string `renderer
in
6443 let p = "Mesa DRI Intel(" in
6444 let l = String.length
p in
6445 String.length
r > l && String.sub
r 0 l = p
6448 defconf
.sliceheight
<- 1024;
6449 defconf
.texcount
<- 32;
6450 defconf
.usepbo
<- true;
6454 match Unix.socketpair
Unix.PF_UNIX
Unix.SOCK_STREAM
0 with
6455 | (exception exn
) ->
6456 dolog
"socketpair failed: %s" @@ exntos exn
;
6464 setcheckers conf
.checkers
;
6467 conf
.angle
, conf
.fitmodel
, (conf
.trimmargins
, conf
.trimfuzz
),
6468 conf
.texcount
, conf
.sliceheight
, conf
.mustoresize
, conf
.colorspace
,
6469 !Config.fontpath
, !trimcachepath,
6470 GlMisc.check_extension
"GL_ARB_pixel_buffer_object",
6473 List.iter
GlArray.enable
[`texture_coord
; `vertex
];
6475 reshape ~firsttime
:true winw winh
;
6479 Wsi.settitle
"llpp (history)";
6483 state
.text <- "Opening " ^
(mbtoutf8 state
.path);
6484 opendoc state
.path state
.password;
6488 Wsi.setcursor
Wsi.CURSOR_INHERIT
;
6489 Sys.set_signal
Sys.sighup
(Sys.Signal_handle
(fun _ -> reload ()));
6492 match Unix.waitpid
[Unix.WNOHANG
] ~
-1 with
6493 | (exception (Unix.Unix_error
(Unix.ECHILD
, _, _))) -> ()
6494 | (exception exn
) -> dolog
"Unix.waitpid: %s" @@ exntos exn
6496 | _pid
, _status
-> reap ()
6498 Sys.set_signal
Sys.sigchld
(Sys.Signal_handle
(fun _ -> doreap := true));
6502 if nonemptystr
!rcmdpath
6503 then remoteopen !rcmdpath
6508 let rec loop deadline
=
6514 let r = [state
.ss; state
.wsfd] in
6518 | Some fd
-> fd
:: r
6522 state
.redisplay
<- false;
6529 if deadline
= infinity
6531 else max
0.0 (deadline
-. now)
6536 try Unix.select
r [] [] timeout
6537 with Unix.Unix_error
(Unix.EINTR
, _, _) -> [], [], []
6543 if state
.ghyll
== noghyll
6545 match state
.autoscroll
with
6546 | Some step
when step
!= 0 ->
6547 let y = state
.y + step
in
6551 else if y >= state
.maxy then 0 else y
6553 if state
.mode = View
6554 then gotoy_and_clear_text y
6558 else deadline
+. 0.01
6563 let rec checkfds = function
6565 | fd
:: rest
when fd
= state
.ss ->
6566 let cmd = readcmd state
.ss in
6570 | fd
:: rest
when fd
= state
.wsfd ->
6574 | fd
:: rest
when Some fd
= !optrfd ->
6575 begin match remote fd
with
6576 | None
-> optrfd := remoteopen !rcmdpath;
6577 | opt -> optrfd := opt
6582 dolog
"select returned unknown descriptor";
6588 if deadline
= infinity
6592 match state
.autoscroll
with
6593 | Some step
when step
!= 0 -> deadline1
6594 | _ -> if state
.ghyll
== noghyll
then infinity
else deadline1
6602 Config.save leavebirdseye;
6603 if hasunsavedchanges
()