6 external init
: Unix.file_descr
-> params
-> unit = "ml_init";;
7 external seltext
: opaque
-> (int * int * int * int) -> unit = "ml_seltext";;
8 external hassel
: opaque
-> bool = "ml_hassel";;
9 external copysel
: Unix.file_descr
-> opaque
-> unit = "ml_copysel";;
10 external getpdimrect
: int -> float array
= "ml_getpdimrect";;
11 external whatsunder
: opaque
-> int -> int -> under
= "ml_whatsunder";;
12 external markunder
: opaque
-> int -> int -> mark
-> bool = "ml_markunder";;
13 external clearmark
: opaque
-> unit = "ml_clearmark";;
14 external zoomforh
: int -> int -> int -> int -> float = "ml_zoom_for_height";;
15 external getmaxw
: unit -> float = "ml_getmaxw";;
16 external drawstr
: int -> int -> int -> string -> float = "ml_draw_string";;
17 external measurestr
: int -> string -> float = "ml_measure_string";;
18 external postprocess
:
19 opaque
-> int -> int -> int -> (int * string * int) -> int
21 external pagebbox
: opaque
-> (int * int * int * int) = "ml_getpagebox";;
22 external setaalevel
: int -> unit = "ml_setaalevel";;
23 external realloctexts
: int -> bool = "ml_realloctexts";;
24 external findlink
: opaque
-> linkdir
-> link
= "ml_findlink";;
25 external getlink
: opaque
-> int -> under
= "ml_getlink";;
26 external getlinkrect
: opaque
-> int -> irect
= "ml_getlinkrect";;
27 external getlinkcount
: opaque
-> int = "ml_getlinkcount";;
28 external findpwl
: int -> int -> pagewithlinks
= "ml_find_page_with_links";;
29 external getpbo
: width
-> height
-> colorspace
-> opaque
= "ml_getpbo";;
30 external freepbo
: opaque
-> unit = "ml_freepbo";;
31 external unmappbo
: opaque
-> unit = "ml_unmappbo";;
32 external pbousable
: unit -> bool = "ml_pbo_usable";;
33 external unproject
: opaque
-> int -> int -> (int * int) option
35 external project
: opaque
-> int -> int -> float -> float -> (float * float)
37 external drawtile
: tileparams
-> opaque
-> unit = "ml_drawtile";;
38 external rectofblock
: opaque
-> int -> int -> float array
option
40 external begintiles
: unit -> unit = "ml_begintiles";;
41 external endtiles
: unit -> unit = "ml_endtiles";;
42 external addannot
: opaque
-> int -> int -> string -> unit = "ml_addannot";;
43 external modannot
: opaque
-> slinkindex
-> string -> unit = "ml_modannot";;
44 external delannot
: opaque
-> slinkindex
-> unit = "ml_delannot";;
45 external hasunsavedchanges
: unit -> bool = "ml_hasunsavedchanges";;
46 external savedoc
: string -> unit = "ml_savedoc";;
47 external getannotcontents
: opaque
-> slinkindex
-> string
48 = "ml_getannotcontents";;
49 external drawprect
: opaque
-> int -> int -> float array
-> unit =
52 let selfexec = ref E.s
;;
54 let drawstring size x y s
=
56 Gl.enable `texture_2d
;
57 GlFunc.blend_func ~src
:`src_alpha ~dst
:`one_minus_src_alpha
;
58 ignore
(drawstr size x y s
);
60 Gl.disable `texture_2d
;
63 let drawstring1 size x y s
=
67 let drawstring2 size x y fmt
=
68 Printf.kprintf
(drawstring size
(x
+1) (y
+size
+1)) fmt
72 dolog
"l %d dim=%d {" l
.pageno l
.pagedimno
;
73 dolog
" WxH %dx%d" l
.pagew l
.pageh
;
74 dolog
" vWxH %dx%d" l
.pagevw l
.pagevh
;
75 dolog
" pagex,y %d,%d" l
.pagex l
.pagey
;
76 dolog
" dispx,y %d,%d" l
.pagedispx l
.pagedispy
;
77 dolog
" column %d" l
.pagecol
;
81 let debugrect (x0
, y0
, x1
, y1
, x2
, y2
, x3
, y3
) =
83 dolog
" x0,y0=(% f, % f)" x0 y0
;
84 dolog
" x1,y1=(% f, % f)" x1 y1
;
85 dolog
" x2,y2=(% f, % f)" x2 y2
;
86 dolog
" x3,y3=(% f, % f)" x3 y3
;
90 let isbirdseye = function
97 let istextentry = function
104 let wtmode = ref false;;
105 let cxack = ref false;;
107 let pgscale h
= truncate
(float h
*. conf
.pgscale);;
110 if not state
.uioh#alwaysscrolly
&& (conf
.scrollb
land scrollbhv
= 0)
111 || (state
.x
= 0 && state
.w
<= state
.winw
- conf
.scrollbw
)
117 if not state
.uioh#alwaysscrolly
&& (conf
.scrollb
land scrollbvv
= 0)
125 else x
> state
.winw
- vscrollw ()
128 let wadjsb () = -vscrollw ();;
129 let xadjsb () = if conf
.leftscroll
then vscrollw () else 0;;
132 fstate
.fontsize
<- n
;
133 fstate
.wwidth
<- measurestr fstate
.fontsize
"w";
134 fstate
.maxrows
<- (state
.winh
- fstate
.fontsize
- 1) / (fstate
.fontsize
+ 1);
140 else Printf.kprintf ignore fmt
144 if emptystr conf
.pathlauncher
145 then dolog
"%s" state
.path
147 let command = Str.global_replace percentsre state
.path conf
.pathlauncher
in
148 match spawn
command [] with
151 dolog
"failed to execute `%s': %s" command @@ exntos exn
157 let postRedisplay who
=
158 vlog "redisplay for [%S]" who
;
159 state
.redisplay
<- true;
163 let getopaque pageno
=
164 try Some
(Hashtbl.find state
.pagemap
(pageno
, state
.gen
))
165 with Not_found
-> None
168 let pagetranslatepoint l x y
=
169 let dy = y
- l
.pagedispy
in
170 let y = dy + l
.pagey
in
171 let dx = x
- l
.pagedispx
in
172 let x = dx + l
.pagex
in
176 let onppundermouse g
x y d
=
179 begin match getopaque l
.pageno
with
181 let x0 = l
.pagedispx
in
182 let x1 = x0 + l
.pagevw
in
183 let y0 = l
.pagedispy
in
184 let y1 = y0 + l
.pagevh
in
185 if y >= y0 && y <= y1 && x >= x0 && x <= x1
187 let px, py
= pagetranslatepoint l
x y in
188 match g opaque l
px py
with
201 let g opaque l
px py
=
204 match rectofblock opaque
px py
with
205 | Some
[|x0;x1;y0;y1|] ->
206 let ox = xadjsb () |> float in
207 let rect = (x0+.ox, y0, x1+.ox, y0, x1+.ox, y1, x0+.ox, y1) in
208 let color = (0.0, 0.0, 1.0 /. (l
.pageno
mod 3 |> float), 0.5) in
209 state
.rects
<- [l
.pageno
, color, rect];
210 G.postRedisplay "getunder";
213 let under = whatsunder opaque
px py
in
214 if under = Unone
then None
else Some
under
216 onppundermouse g x y Unone
221 match unproject opaque
x y with
222 | Some
(x, y) -> Some
(Some
(opaque
, l
.pageno
, x, y))
225 onppundermouse g x y None
;
229 state
.text
<- Printf.sprintf
"%c%s" c s
;
230 G.postRedisplay "showtext";
234 Format.ksprintf
(fun s
-> showtext '
!' s
) fmt
;
237 let pipesel opaque cmd
=
240 match Unix.pipe
() with
241 | (exception exn
) -> dolog
"pipesel cannot create pipe: %S" @@ exntos exn
;
243 let doclose what fd
=
244 Ne.clo fd
(fun msg
-> dolog
"%s close failed: %s" what msg
)
247 try spawn cmd
[r
, 0; w
, -1]
249 dolog
"cannot execute %S: %s" cmd
@@ exntos exn
;
255 G.postRedisplay "pipesel";
257 else doclose "pipesel pipe/w" w
;
258 doclose "pipesel pipe/r" r
;
262 let g opaque l
px py
=
263 if markunder opaque
px py conf
.paxmark
266 match getopaque l
.pageno
with
268 | Some opaque
-> pipesel opaque conf
.paxcmd
273 G.postRedisplay "paxunder";
274 if conf
.paxmark
= Mark_page
277 match getopaque l
.pageno
with
279 | Some opaque
-> clearmark opaque
) state
.layout
;
280 state
.roam
<- onppundermouse g x y (fun () -> impmsg "whoopsie daisy");
284 match Unix.pipe
() with
285 | (exception exn
) -> impmsg "pipe failed: %s" @@ exntos exn
288 Ne.clo fd
(fun msg
-> impmsg "failed to close %s: %s" cap msg
)
291 try spawn conf
.selcmd
[r
, 0; w
, -1]
293 impmsg "failed to execute %s: %s" conf
.selcmd
@@ exntos exn
;
299 let l = String.length s
in
300 let bytes = Bytes.unsafe_of_string s
in
301 let n = tempfailureretry
(Unix.write w
bytes 0) l in
303 then impmsg "failed to write %d characters to sel pipe, wrote %d"
306 impmsg "failed to write to sel pipe: %s" @@ exntos exn
309 clo "selstring pipe/r" r
;
310 clo "selstring pipe/w" w
;
313 let undertext ?
(nopath
=false) = function
316 | Ulinkgoto
(pageno
, _
) ->
318 then "page " ^ string_of_int
(pageno
+1)
319 else Printf.sprintf
"%s: page %d" state
.path
(pageno
+1)
320 | Utext s
-> "font: " ^ s
321 | Uunexpected s
-> "unexpected: " ^ s
322 | Ulaunch s
-> "launch: " ^ s
323 | Unamed s
-> "named: " ^ s
324 | Uremote
(filename
, pageno
) ->
325 Printf.sprintf
"%s: page %d" filename
(pageno
+1)
326 | Uremotedest
(filename
, destname
) ->
327 Printf.sprintf
"%s: destination %S" filename destname
328 | Uannotation
(opaque
, slinkindex
) ->
329 "annotation: " ^ getannotcontents opaque slinkindex
332 let updateunder x y =
333 match getunder x y with
334 | Unone
-> Wsi.setcursor
Wsi.CURSOR_INHERIT
336 if conf
.underinfo
then showtext 'u'
("ri: " ^ uri
);
337 Wsi.setcursor
Wsi.CURSOR_INFO
338 | Ulinkgoto
(pageno
, _
) ->
340 then showtext 'p'
("age: " ^ string_of_int
(pageno
+1));
341 Wsi.setcursor
Wsi.CURSOR_INFO
343 if conf
.underinfo
then showtext '
f'
("ont: " ^ s
);
344 Wsi.setcursor
Wsi.CURSOR_TEXT
346 if conf
.underinfo
then showtext 'u'
("nexpected: " ^ s
);
347 Wsi.setcursor
Wsi.CURSOR_INHERIT
349 if conf
.underinfo
then showtext '
l'
("aunch: " ^ s
);
350 Wsi.setcursor
Wsi.CURSOR_INHERIT
352 if conf
.underinfo
then showtext '
n'
("amed: " ^ s
);
353 Wsi.setcursor
Wsi.CURSOR_INHERIT
354 | Uremote
(filename
, pageno
) ->
355 if conf
.underinfo
then showtext 'r'
356 (Printf.sprintf
"emote: %s (%d)" filename
(pageno
+1));
357 Wsi.setcursor
Wsi.CURSOR_INFO
358 | Uremotedest
(filename
, destname
) ->
359 if conf
.underinfo
then showtext 'r'
360 (Printf.sprintf
"emote destination: %s (%S)" filename destname
);
361 Wsi.setcursor
Wsi.CURSOR_INFO
363 if conf
.underinfo
then showtext 'a'
"nnotation";
364 Wsi.setcursor
Wsi.CURSOR_INFO
367 let showlinktype under =
368 if conf
.underinfo
&& under != Unone
369 then showtext ' '
@@ undertext under
372 let intentry_with_suffix text key
=
374 if key
>= 32 && key
< 127
378 match Char.lowercase
c with
380 let text = addchar
text c in
384 let text = addchar
text c in
388 state
.text <- Printf.sprintf
"invalid char (%d, `%c')" key
c;
393 let s = Bytes.create
4 in
394 let n = tempfailureretry
(Unix.read fd
s 0) 4 in
395 if n != 4 then error
"incomplete read(len) = %d" n;
396 let len = (Char.code
(Bytes.get
s 0) lsl 24)
397 lor (Char.code
(Bytes.get
s 1) lsl 16)
398 lor (Char.code
(Bytes.get
s 2) lsl 8)
399 lor (Char.code
(Bytes.get
s 3))
401 let s = Bytes.create
len in
402 let n = tempfailureretry
(Unix.read fd
s 0) len in
403 if n != len then error
"incomplete read(data) %d vs %d" n len;
408 let b = Buffer.create
16 in
409 Buffer.add_string
b "llll";
412 let s = Buffer.to_bytes
b in
413 let n = Bytes.length
s in
415 (* dolog "wcmd %S" (String.sub s 4 len); *)
416 Bytes.set
s 0 (Char.chr
((len lsr 24) land 0xff));
417 Bytes.set
s 1 (Char.chr
((len lsr 16) land 0xff));
418 Bytes.set
s 2 (Char.chr
((len lsr 8) land 0xff));
419 Bytes.set
s 3 (Char.chr
(len land 0xff));
420 let n'
= tempfailureretry
(Unix.write state
.ss
s 0) n in
421 if n'
!= n then error
"write failed %d vs %d" n'
n;
425 let nogeomcmds cmds
=
427 | s, [] -> emptystr
s
431 let layoutN ((columns
, coverA
, coverB
), b) x y sw sh
=
432 let sh = sh - (hscrollh ()) in
433 let wadj = wadjsb () in
434 let rec fold accu
n =
435 if n = Array.length
b
438 let pdimno, dx, vy
, (_
, w
, h
, xoff
) = b.(n) in
441 || n = state
.pagecount
- coverB
442 || (n - coverA
) mod columns
= columns
- 1)
448 let pagey = max
0 (y - vy
) in
449 let pagedispy = if pagey > 0 then 0 else vy
- y in
450 let pagedispx, pagex
=
452 if n = coverA
- 1 || n = state
.pagecount
- coverB
453 then x + (wadj + sw
- w
) / 2
461 let vw = wadj + sw
- pagedispx in
462 let pw = w
- pagex
in
465 let pagevh = min
(h
- pagey) (sh - pagedispy) in
466 if pagevw > 0 && pagevh > 0
477 ; pagedispx = pagedispx
478 ; pagedispy = pagedispy
490 if Array.length
b = 0
492 else List.rev
(fold [] (page_of_y
y))
495 let layoutS (columns
, b) x y sw
sh =
496 let sh = sh - hscrollh () in
497 let wadj = wadjsb () in
498 let rec fold accu n =
499 if n = Array.length
b
502 let pdimno, px, vy
, (_
, pagew
, pageh
, xoff
) = b.(n) in
510 let pagey = max
0 (y - vy
) in
511 let pagedispy = if pagey > 0 then 0 else vy
- y in
512 let pagedispx, pagex
=
526 let pagecolw = pagew
/columns
in
529 then pagedispx + ((wadj + sw
- pagecolw) / 2)
533 let vw = wadj + sw
- pagedispx in
534 let pw = pagew
- pagex
in
537 let pagevw = min
pagevw pagecolw in
538 let pagevh = min
(pageh
- pagey) (sh - pagedispy) in
539 if pagevw > 0 && pagevh > 0
550 ; pagedispx = pagedispx
551 ; pagedispy = pagedispy
552 ; pagecol
= n mod columns
566 let layout x y sw
sh =
567 if nogeomcmds state
.geomcmds
569 match conf
.columns
with
570 | Csingle
b -> layoutN ((1, 0, 0), b) x y sw
sh
571 | Cmulti
c -> layoutN c x y sw
sh
572 | Csplit
s -> layoutS s x y sw
sh
577 let y = state
.y + incr
in
579 let y = min
y (state
.maxy
- (if conf
.maxhfit
then state
.winh
else 0)) in
584 let tilex = l.pagex
mod conf
.tilew
in
585 let tiley = l.pagey mod conf
.tileh
in
587 let col = l.pagex
/ conf
.tilew
in
588 let row = l.pagey / conf
.tileh
in
590 let xadj = xadjsb () in
591 let rec rowloop row y0 dispy h
=
595 let dh = conf
.tileh
- y0 in
597 let rec colloop col x0 dispx w
=
601 let dw = conf
.tilew
- x0 in
603 let dispx'
= xadj + dispx in
604 f col row dispx' dispy
x0 y0 dw dh;
605 colloop (col+1) 0 (dispx+dw) (w
-dw)
608 colloop col tilex l.pagedispx l.pagevw;
609 rowloop (row+1) 0 (dispy
+dh) (h
-dh)
612 if l.pagevw > 0 && l.pagevh > 0
613 then rowloop row tiley l.pagedispy l.pagevh;
616 let gettileopaque l col row =
618 l.pageno
, state
.gen
, conf
.colorspace
, conf
.angle
, l.pagew
, l.pageh
, col, row
620 try Some
(Hashtbl.find state
.tilemap
key)
621 with Not_found
-> None
624 let puttileopaque l col row gen colorspace angle opaque size elapsed
=
625 let key = l.pageno
, gen
, colorspace
, angle
, l.pagew
, l.pageh
, col, row in
626 Hashtbl.add state
.tilemap
key (opaque
, size
, elapsed
)
629 let filledrect x0 y0 x1 y1 =
630 GlArray.disable `texture_coord
;
631 Raw.sets_float state
.vraw ~pos
:0 [| x0; y0; x0; y1; x1; y0; x1; y1 |];
632 GlArray.vertex `two state
.vraw
;
633 GlArray.draw_arrays `triangle_strip ~first
:0 ~count
:4;
634 GlArray.enable `texture_coord
;
637 let linerect x0 y0 x1 y1 =
638 GlArray.disable `texture_coord
;
639 Raw.sets_float state
.vraw ~pos
:0 [| x0; y0; x0; y1; x1; y1; x1; y0 |];
640 GlArray.vertex `two state
.vraw
;
641 GlArray.draw_arrays `line_loop ~first
:0 ~count
:4;
642 GlArray.enable `texture_coord
;
645 let drawtiles l color =
647 let wadj = wadjsb () in
649 let f col row x y tilex tiley w h
=
650 match gettileopaque l col row with
651 | Some
(opaque
, _
, t
) ->
652 let params = x, y, w
, h
, tilex, tiley in
654 then GlTex.env
(`mode `blend
);
655 drawtile
params opaque
;
657 then GlTex.env
(`mode `modulate
);
661 let s = Printf.sprintf
665 let w = measurestr fstate
.fontsize
s in
666 GlDraw.color (0.0, 0.0, 0.0);
667 filledrect (float (x-2))
670 (float (y + fstate
.fontsize
+ 2));
671 GlDraw.color (1.0, 1.0, 1.0);
672 drawstring fstate
.fontsize
x (y + fstate
.fontsize
- 1) s;
682 let lw = wadj + state
.winw
- x in
685 let lh = state
.winh
- y in
689 then GlTex.env
(`mode `blend
);
690 begin match state
.checkerstexid
with
692 Gl.enable `texture_2d
;
693 GlTex.bind_texture ~target
:`texture_2d id
;
697 and y1 = float (y+h
) in
699 let tw = float w /. 16.0
700 and th
= float h
/. 16.0 in
701 let tx0 = float tilex /. 16.0
702 and ty0
= float tiley /. 16.0 in
704 and ty1
= ty0
+. th
in
705 Raw.sets_float state
.vraw ~pos
:0
706 [| x0; y0; x0; y1; x1; y0; x1; y1 |];
707 Raw.sets_float state
.traw ~pos
:0
708 [| tx0; ty0
; tx0; ty1
; tx1; ty0
; tx1; ty1
|];
709 GlArray.vertex `two state
.vraw
;
710 GlArray.tex_coord `two state
.traw
;
711 GlArray.draw_arrays `triangle_strip ~first
:0 ~count
:4;
712 Gl.disable `texture_2d
;
715 GlDraw.color (1.0, 1.0, 1.0);
716 filledrect (float x) (float y) (float (x+w)) (float (y+h
));
719 then GlTex.env
(`mode `modulate
);
720 if w > 128 && h
> fstate
.fontsize
+ 10
722 let c = if conf
.invert
then 1.0 else 0.0 in
723 GlDraw.color (c, c, c);
726 then (col*conf
.tilew
, row*conf
.tileh
)
729 drawstring2 fstate
.fontsize
x y "Loading %d [%d,%d]" l.pageno
c r
;
738 let pagevisible layout n = List.exists
(fun l -> l.pageno
= n) layout;;
740 let tilevisible1 l x y =
742 and ax1
= l.pagex
+ l.pagevw
744 and ay1
= l.pagey + l.pagevh in
748 let bx1 = min
(bx0 + conf
.tilew
) l.pagew
749 and by1
= min
(by0
+ conf
.tileh
) l.pageh
in
751 let rx0 = max
ax0 bx0
752 and ry0
= max ay0 by0
753 and rx1
= min ax1
bx1
754 and ry1
= min ay1 by1
in
756 let nonemptyintersection = rx1
> rx0 && ry1
> ry0
in
760 let tilevisible layout n x y =
761 let rec findpageinlayout m
= function
762 | l :: rest
when l.pageno
= n ->
763 tilevisible1 l x y || (
764 match conf
.columns
with
765 | Csplit
(c, _
) when c > m
-> findpageinlayout (m
+1) rest
770 | _
:: rest
-> findpageinlayout 0 rest
773 findpageinlayout 0 layout;
776 let tileready l x y =
777 tilevisible1 l x y &&
778 gettileopaque l (x/conf
.tilew
) (y/conf
.tileh
) != None
781 let tilepage n p
layout =
782 let rec loop = function
786 let f col row _ _ _ _ _ _
=
787 if state
.currently
= Idle
789 match gettileopaque l col row with
792 let x = col*conf
.tilew
793 and y = row*conf
.tileh
in
795 let w = l.pagew
- x in
799 let h = l.pageh
- y in
804 then getpbo
w h conf
.colorspace
807 wcmd "tile %s %d %d %d %d %s"
808 (~
> p
) x y w h (~
> pbo);
811 l, p
, conf
.colorspace
, conf
.angle
,
812 state
.gen
, col, row, conf
.tilew
, conf
.tileh
821 if nogeomcmds state
.geomcmds
825 let preloadlayout x y sw
sh =
826 let y = if y < sh then 0 else y - sh in
827 let x = min
0 (x + sw
) in
835 if state
.currently
!= Idle
840 begin match getopaque l.pageno
with
842 wcmd "page %d %d" l.pageno
l.pagedimno
;
843 state
.currently
<- Loading
(l, state
.gen
);
845 tilepage l.pageno opaque pages
;
850 if nogeomcmds state
.geomcmds
856 if conf
.preload && state
.currently
= Idle
857 then load (preloadlayout state
.x state
.y state
.winw state
.winh
);
860 let layoutready layout =
861 let rec fold all ls
=
864 let seen = ref false in
865 let allvisible = ref true in
866 let foo col row _ _ _ _ _ _
=
868 allvisible := !allvisible &&
869 begin match gettileopaque l col row with
875 fold (!seen && !allvisible) rest
878 let alltilesvisible = fold true layout in
883 let y = bound
y 0 state
.maxy
in
884 let y, layout, proceed
=
885 match conf
.maxwait
with
886 | Some time
when state
.ghyll
== noghyll
->
887 begin match state
.throttle
with
889 let layout = layout state
.x y state
.winw state
.winh
in
890 let ready = layoutready layout in
894 state
.throttle
<- Some
(layout, y, now
());
896 else G.postRedisplay "gotoy showall (None)";
898 | Some
(_
, _
, started
) ->
899 let dt = now
() -. started
in
902 state
.throttle
<- None
;
903 let layout = layout state
.x y state
.winw state
.winh
in
905 G.postRedisplay "maxwait";
912 let layout = layout state
.x y state
.winw state
.winh
in
913 if not
!wtmode || layoutready layout
914 then G.postRedisplay "gotoy ready";
920 state
.layout <- layout;
921 begin match state
.mode
with
924 | Ltexact
(pageno
, linkno
) ->
925 let rec loop = function
927 state
.mode
<- LinkNav
(Ltgendir
0)
928 | l :: _
when l.pageno
= pageno
->
929 begin match getopaque pageno
with
930 | None
-> state
.mode
<- LinkNav
(Ltnotready
(pageno
, 0))
932 let x0, y0, x1, y1 = getlinkrect opaque linkno
in
933 if not
(x0 >= l.pagex
&& x1 <= l.pagex
+ l.pagevw
934 && y0 >= l.pagey && y1 <= l.pagey + l.pagevh)
935 then state
.mode
<- LinkNav
(Ltgendir
0)
937 | _
:: rest
-> loop rest
940 | Ltnotready _
| Ltgendir _
-> ()
946 begin match state
.mode
with
947 | Birdseye
(conf
, leftx
, pageno
, hooverpageno
, anchor
) ->
948 if not
(pagevisible layout pageno
)
950 match state
.layout with
953 state
.mode
<- Birdseye
(
954 conf
, leftx
, l.pageno
, hooverpageno
, anchor
959 | Ltnotready
(_
, dir
)
962 let rec loop = function
965 match getopaque l.pageno
with
966 | None
-> Ltnotready
(l.pageno
, dir
)
971 then LDfirstvisible
(l.pagex
, l.pagey, dir
)
973 if dir
> 0 then LDfirst
else LDlast
979 | Lnotfound
-> loop rest
981 showlinktype (getlink opaque
n);
982 Ltexact
(l.pageno
, n)
986 state
.mode
<- LinkNav
linknav
994 state
.ghyll
<- noghyll
;
997 let mx, my
= state
.mpos
in
1002 let conttiling pageno opaque
=
1003 tilepage pageno opaque
1005 then preloadlayout state
.x state
.y state
.winw state
.winh
1009 let gotoy_and_clear_text y =
1010 if not conf
.verbose
then state
.text <- E.s;
1014 let getanchory (n, top
, dtop
) =
1015 let y, h = getpageyh
n in
1016 if conf
.presentation
1018 let ips = calcips
h in
1019 y + truncate
(top
*.float h -. dtop
*.float ips) + ips;
1021 y + truncate
(top
*.float h -. dtop
*.float conf
.interpagespace
)
1024 let gotoanchor anchor
=
1025 gotoy (getanchory anchor
);
1029 cbput state
.hists
.nav
(getanchor
());
1033 let anchor = cbgetc state
.hists
.nav dir
in
1037 let gotoghyll1 single
y =
1038 let scroll f n a
b =
1039 (* http://devmaster.net/forums/topic/9796-ease-in-ease-out-algorithm/ *)
1041 let s x = 3.0*.x**2.0 -. 2.0*.x**3.0 in
1043 then s (float f /. float a
)
1046 then 1.0 -. s ((float (f-b) /. float (n-b)))
1052 let ins = float a
*. 0.5
1053 and outs
= float (n-b) *. 0.5 in
1055 ins +. outs
+. float ones
1057 let rec set nab
y sy
=
1058 let (_N
, _A
, _B
), y =
1061 let scl = if y > sy
then 2 else -2 in
1062 let _N, _
, _
= nab
in
1063 (_N,0,_N), y+conf
.scrollstep
*scl
1065 let sum = summa
_N _A _B
in
1066 let dy = float (y - sy
) in
1070 then state
.ghyll
<- noghyll
1073 let s = scroll n _N _A _B
in
1074 let y1 = y1 +. ((s *. dy) /. sum) in
1075 gotoy_and_clear_text (truncate
y1);
1076 state
.ghyll
<- gf (n+1) y1;
1080 | Some
y'
when single
-> set nab
y' state
.y
1081 | Some
y'
-> set (_N/2, 1, 1) y' state
.y
1083 gf 0 (float state
.y)
1086 match conf
.ghyllscroll
with
1087 | Some nab
when not conf
.presentation
->
1088 if state
.ghyll
== noghyll
1089 then set nab
y state
.y
1090 else state
.ghyll
(Some
y)
1092 gotoy_and_clear_text y
1095 let gotoghyll = gotoghyll1 false;;
1097 let gotopage n top
=
1098 let y, h = getpageyh
n in
1099 let y = y + (truncate
(top
*. float h)) in
1103 let gotopage1 n top
=
1104 let y = getpagey
n in
1109 let invalidate s f =
1114 match state
.geomcmds
with
1115 | ps
, [] when emptystr ps
->
1117 state
.geomcmds
<- s, [];
1120 state
.geomcmds
<- ps
, [s, f];
1122 | ps
, (s'
, _
) :: rest
when s'
= s ->
1123 state
.geomcmds
<- ps
, ((s, f) :: rest
);
1126 state
.geomcmds
<- ps
, ((s, f) :: cmds
);
1130 Hashtbl.iter
(fun _ opaque
->
1131 wcmd "freepage %s" (~
> opaque
);
1133 Hashtbl.clear state
.pagemap
;
1137 if not
(Queue.is_empty state
.tilelru
)
1139 Queue.iter
(fun (k
, p
, s) ->
1140 wcmd "freetile %s" (~
> p
);
1141 state
.memused
<- state
.memused
- s;
1142 Hashtbl.remove state
.tilemap k
;
1144 state
.uioh#infochanged Memused
;
1145 Queue.clear state
.tilelru
;
1151 let h = truncate
(float h*.conf
.zoom
) in
1152 let d = conf
.interpagespace
lsl (if conf
.presentation
then 1 else 0) in
1156 let opendoc path password
=
1158 state
.password
<- password
;
1159 state
.gen
<- state
.gen
+ 1;
1160 state
.docinfo
<- [];
1161 state
.outlines
<- [||];
1164 setaalevel conf
.aalevel
;
1166 if emptystr state
.origin
1170 Wsi.settitle
("llpp " ^
(mbtoutf8
(Filename.basename
titlepath)));
1171 wcmd "open %d %d %s\000%s\000" (btod
!wtmode) (btod
!cxack) path password
;
1172 invalidate "reqlayout"
1174 wcmd "reqlayout %d %d %d %s\000"
1175 conf
.angle
(FMTE.to_int conf
.fitmodel
)
1176 (stateh state
.winh
) state
.nameddest
1181 state
.anchor <- getanchor
();
1182 opendoc state
.path state
.password
;
1186 let c = c *. conf
.colorscale
in
1190 let scalecolor2 (r
, g, b) =
1191 (r
*. conf
.colorscale
, g *. conf
.colorscale
, b *. conf
.colorscale
);
1194 let docolumns columns
=
1195 let wadj = wadjsb () in
1198 let a = Array.make state
.pagecount
(-1, -1, -1, (-1, -1, -1, -1)) in
1199 let wadj = wadjsb () in
1200 let rec loop pageno
pdimno pdim
y ph pdims
=
1201 if pageno
= state
.pagecount
1204 let pdimno, ((_
, w, h, xoff
) as pdim
), pdims
=
1206 | ((pageno'
, _
, _
, _
) as pdim
) :: rest
when pageno'
= pageno
->
1207 pdimno+1, pdim
, rest
1211 let x = max
0 (((wadj + state
.winw
- w) / 2) - xoff
) in
1213 (if conf
.presentation
1214 then (if pageno
= 0 then calcips
h else calcips ph
+ calcips
h)
1215 else (if pageno
= 0 then 0 else conf
.interpagespace
)
1218 a.(pageno
) <- (pdimno, x, y, pdim
);
1219 loop (pageno
+1) pdimno pdim
(y + h) h pdims
1221 loop 0 ~
-1 (-1,-1,-1,-1) 0 0 state
.pdims
;
1222 conf
.columns
<- Csingle
a;
1224 | Cmulti
((columns
, coverA
, coverB
), _
) ->
1225 let a = Array.make state
.pagecount
(-1, -1, -1, (-1, -1, -1, -1)) in
1226 let rec loop pageno
pdimno pdim
x y rowh pdims
=
1227 let rec fixrow m
= if m
= pageno
then () else
1228 let (pdimno, x, y, ((_
, _
, h, _
) as pdim
)) = a.(m
) in
1231 let y = y + (rowh
- h) / 2 in
1232 a.(m
) <- (pdimno, x, y, pdim
);
1236 if pageno
= state
.pagecount
1237 then fixrow (((pageno
- 1) / columns
) * columns
)
1239 let pdimno, ((_
, w, h, xoff
) as pdim
), pdims
=
1241 | ((pageno'
, _
, _
, _
) as pdim
) :: rest
when pageno'
= pageno
->
1242 pdimno+1, pdim
, rest
1247 if pageno
= coverA
- 1 || pageno
= state
.pagecount
- coverB
1249 let x = (wadj + state
.winw
- w) / 2 in
1251 if conf
.presentation
then calcips
h else conf
.interpagespace
in
1252 x, y + ips + rowh
, h
1255 if (pageno
- coverA
) mod columns
= 0
1257 let x = max
0 (wadj + state
.winw
- state
.w) / 2 in
1259 if conf
.presentation
1261 let ips = calcips
h in
1262 y + (if pageno
= 0 then 0 else calcips rowh
+ ips)
1264 y + (if pageno
= 0 then 0 else conf
.interpagespace
)
1268 else x, y, max rowh
h
1272 if pageno
> 1 && (pageno
- coverA
) mod columns
= 0
1275 if pageno
= columns
&& conf
.presentation
1277 let ips = calcips rowh
in
1278 for i
= 0 to pred columns
1280 let (pdimno, x, y, pdim
) = a.(i
) in
1281 a.(i
) <- (pdimno, x, y+ips, pdim
)
1287 fixrow (pageno
- columns
);
1292 a.(pageno
) <- (pdimno, x, y, pdim
);
1293 let x = x + w + xoff
*2 + conf
.interpagespace
in
1294 loop (pageno
+1) pdimno pdim
x y rowh' pdims
1296 loop 0 ~
-1 (-1,-1,-1,-1) 0 0 0 state
.pdims
;
1297 conf
.columns
<- Cmulti
((columns
, coverA
, coverB
), a);
1300 let a = Array.make
(state
.pagecount
*c) (-1, -1, -1, (-1, -1, -1, -1)) in
1301 let rec loop pageno
pdimno pdim
y pdims
=
1302 if pageno
= state
.pagecount
1305 let pdimno, ((_
, w, h, _
) as pdim
), pdims
=
1307 | ((pageno'
, _
, _
, _
) as pdim
) :: rest
when pageno'
= pageno
->
1308 pdimno+1, pdim
, rest
1313 let rec loop1 n x y =
1314 if n = c then y else (
1315 a.(pageno
*c + n) <- (pdimno, x, y, pdim
);
1316 loop1 (n+1) (x+cw) (y + h + conf
.interpagespace
)
1319 let y = loop1 0 0 y in
1320 loop (pageno
+1) pdimno pdim
y pdims
1322 loop 0 ~
-1 (-1,-1,-1,-1) 0 state
.pdims
;
1323 conf
.columns
<- Csplit
(c, a);
1327 docolumns conf
.columns
;
1328 state
.maxy
<- calcheight
();
1329 if state
.reprf
== noreprf
1331 match state
.mode
with
1332 | Birdseye
(_
, _
, pageno
, _
, _
) ->
1333 let y, h = getpageyh pageno
in
1334 let top = (state
.winh
- h) / 2 in
1335 gotoy (max
0 (y - top))
1339 let y = getanchory state
.anchor in
1340 let y = min
y (state
.maxy
- state
.winw
- hscrollh ()) in
1345 state
.reprf
<- noreprf
;
1349 let reshape ?
(firsttime
=false) w h =
1350 GlDraw.viewport ~
x:0 ~
y:0 ~
w:w ~
h:h;
1351 if not firsttime
&& nogeomcmds state
.geomcmds
1352 then state
.anchor <- getanchor
();
1355 let w = wadjsb () + (truncate
(float w *. conf
.zoom
)) in
1358 setfontsize fstate
.fontsize
;
1359 GlMat.mode `modelview
;
1360 GlMat.load_identity
();
1362 GlMat.mode `projection
;
1363 GlMat.load_identity
();
1364 GlMat.rotate ~
x:1.0 ~angle
:180.0 ();
1365 GlMat.translate ~
x:~
-.1.0 ~
y:~
-.1.0 ();
1366 GlMat.scale3
(2.0 /. float state
.winw
, 2.0 /. float state
.winh
, 1.0);
1371 else float state
.x /. float state
.w
1373 invalidate "geometry"
1377 then state
.x <- truncate
(relx *. float w);
1379 match conf
.columns
with
1381 | Cmulti
((c, _
, _
), _
) -> (w - (c-1)*conf
.interpagespace
) / c
1382 | Csplit
(c, _
) -> w * c
1384 wcmd "geometry %d %d %d"
1385 w (stateh h) (FMTE.to_int conf
.fitmodel
)
1390 let len = String.length state
.text in
1391 let x0 = xadjsb () in
1394 match state
.mode
with
1395 | Textentry _
| View
| LinkNav _
->
1396 let h, _
, _
= state
.uioh#scrollpw
in
1401 filledrect x (float (state
.winh
- (fstate
.fontsize
+ 4) - hscrollh))
1402 (x+.w) (float (state
.winh
- hscrollh))
1405 let w = float (wadjsb () + state
.winw
- 1) in
1406 if state
.progress
>= 0.0 && state
.progress
< 1.0
1408 GlDraw.color (0.3, 0.3, 0.3);
1409 let w1 = w *. state
.progress
in
1411 GlDraw.color (0.0, 0.0, 0.0);
1412 rect (float x0+.w1) (float x0+.w-.w1)
1415 GlDraw.color (0.0, 0.0, 0.0);
1419 GlDraw.color (1.0, 1.0, 1.0);
1420 drawstring fstate
.fontsize
1421 (if conf
.leftscroll
then x0 + 2 else x0 + if len > 0 then 8 else 2)
1422 (state
.winh
- hscrollh - 5) s;
1425 match state
.mode
with
1426 | Textentry
((prefix
, text, _
, _
, _
, _
), _
) ->
1430 Printf.sprintf
"%s%s_ [%s]" prefix
text state
.text
1432 Printf.sprintf
"%s%s_" prefix
text
1438 | LinkNav _
-> state
.text
1443 if not
(istextentry state
.mode
) && state
.uioh#eformsgs
1445 let s1 = "(press 'e' to review error messasges)" in
1446 if nonemptystr
s then s ^
" " ^
s1 else s1
1456 let len = Queue.length state
.tilelru
in
1458 match state
.throttle
with
1461 then preloadlayout state
.x state
.y state
.winw state
.winh
1463 | Some
(layout, _
, _
) ->
1467 if state
.memused
<= conf
.memlimit
1472 let (k
, p
, s) as lruitem
= Queue.pop state
.tilelru
in
1473 let n, gen
, colorspace
, angle
, pagew
, pageh
, col, row = k
in
1474 let (_
, pw, ph
, _
) = getpagedim
n in
1477 && colorspace
= conf
.colorspace
1478 && angle
= conf
.angle
1482 let x = col*conf
.tilew
1483 and y = row*conf
.tileh
in
1484 tilevisible (Lazy.force_val
layout) n x y
1486 then Queue.push lruitem state
.tilelru
1489 wcmd "freetile %s" (~
> p
);
1490 state
.memused
<- state
.memused
- s;
1491 state
.uioh#infochanged Memused
;
1492 Hashtbl.remove state
.tilemap k
;
1500 let onpagerect pageno
f =
1502 match conf
.columns
with
1503 | Cmulti
(_
, b) -> b
1505 | Csplit
(_
, b) -> b
1507 if pageno
>= 0 && pageno
< Array.length
b
1509 let (_
, _
, _
, (_
, w, h, _
)) = b.(pageno
) in
1513 let gotopagexy1 wtmode pageno
x y =
1514 let _,w1,h1
,leftx
= getpagedim pageno
in
1515 let top = y /. (float h1
) in
1516 let left = x /. (float w1) in
1517 let py, w, h = getpageywh pageno
in
1518 let wh = state
.winh
- hscrollh () in
1519 let x = left *. (float w) in
1520 let x = leftx
+ state
.x + truncate
x in
1521 let wadj = wadjsb () in
1523 if x < 0 || x >= wadj + state
.winw
1527 let pdy = truncate
(top *. float h) in
1528 let y'
= py + pdy in
1529 let dy = y'
- state
.y in
1531 if x != state
.x || not
(dy > 0 && dy < wh)
1533 if conf
.presentation
1535 if abs
(py - y'
) > wh
1542 if state
.x != sx || state
.y != sy
1547 let ww = wadj + state
.winw
in
1549 and qy
= pdy / wh in
1551 and y = py + qy
* wh in
1552 let x = if -x + ww > w1 then -(w1-ww) else x
1553 and y'
= if y + wh > state
.maxy
then state
.maxy
- wh else y in
1555 if conf
.presentation
1557 if abs
(py - y'
) > wh
1567 gotoy_and_clear_text y;
1569 else gotoy_and_clear_text state
.y;
1572 let gotopagexy wtmode pageno
x y =
1573 match state
.mode
with
1574 | Birdseye
_ -> gotopage pageno
0.0
1577 | LinkNav
_ -> gotopagexy1 wtmode pageno
x y
1580 let getpassword () =
1581 let passcmd = getenvwithdef
"LLPP_ASKPASS" conf
.passcmd in
1586 impmsg "error getting password: %s" s;
1587 dolog
"%s" s) passcmd;
1590 let pgoto opaque pageno
x y =
1591 let pdimno = getpdimno pageno
in
1592 let x, y = project opaque pageno
pdimno x y in
1593 gotopagexy false pageno
x y;
1597 (* dolog "%S" cmds; *)
1598 let cl = splitatspace cmds
in
1600 try Scanf.sscanf
s fmt
f
1602 dolog
"error processing '%S': %s" cmds
@@ exntos exn
;
1605 let addoutline outline
=
1606 match state
.currently
with
1607 | Outlining outlines
->
1608 state
.currently
<- Outlining
(outline
:: outlines
)
1609 | Idle
-> state
.currently
<- Outlining
[outline
]
1612 dolog
"invalid outlining state";
1613 logcurrently state
.currently
1617 state
.uioh#infochanged Pdim
;
1620 | "clearrects" :: [] ->
1621 state
.rects
<- state
.rects1
;
1622 G.postRedisplay "clearrects";
1624 | "continue" :: args
:: [] ->
1625 let n = scan args
"%u" (fun n -> n) in
1626 state
.pagecount
<- n;
1627 begin match state
.currently
with
1629 state
.currently
<- Idle
;
1630 state
.outlines
<- Array.of_list
(List.rev
l)
1636 let cur, cmds
= state
.geomcmds
in
1638 then failwith
"umpossible";
1640 begin match List.rev cmds
with
1642 state
.geomcmds
<- E.s, [];
1643 state
.throttle
<- None
;
1647 state
.geomcmds
<- s, List.rev rest
;
1649 if conf
.maxwait
= None
&& not
!wtmode
1650 then G.postRedisplay "continue";
1652 | "msg" :: args
:: [] ->
1655 | "vmsg" :: args
:: [] ->
1657 then showtext ' ' args
1659 | "emsg" :: args
:: [] ->
1660 Buffer.add_string state
.errmsgs args
;
1661 state
.newerrmsgs
<- true;
1662 G.postRedisplay "error message"
1664 | "progress" :: args
:: [] ->
1665 let progress, text =
1668 f, String.sub args pos
(String.length args
- pos
))
1671 state
.progress <- progress;
1672 G.postRedisplay "progress"
1674 | "firstmatch" :: args
:: [] ->
1675 let pageno, c, x0, y0, x1, y1, x2
, y2
, x3
, y3
=
1676 scan args
"%u %d %f %f %f %f %f %f %f %f"
1677 (fun p
c x0 y0 x1 y1 x2 y2 x3 y3
->
1678 (p
, c, x0, y0, x1, y1, x2
, y2
, x3
, y3
))
1680 let xoff = float (xadjsb ()) in
1684 and x3
= x3
+. xoff in
1685 let y = (getpagey
pageno) + truncate
y0 in
1687 then state
.x <- truncate
(xoff -. x0) + state
.winw
/2;
1690 let color = (0.0, 0.0, 1.0 /. float c, 0.5) in
1691 state
.rects1
<- [pageno, color, (x0, y0, x1, y1, x2
, y2
, x3
, y3
)]
1693 | "match" :: args
:: [] ->
1694 let pageno, c, x0, y0, x1, y1, x2
, y2
, x3
, y3
=
1695 scan args
"%u %d %f %f %f %f %f %f %f %f"
1696 (fun p
c x0 y0 x1 y1 x2 y2 x3 y3
->
1697 (p
, c, x0, y0, x1, y1, x2
, y2
, x3
, y3
))
1699 let xoff = float (xadjsb ()) in
1703 and x3
= x3
+. xoff in
1704 let color = (0.0, 0.0, 1.0 /. float c, 0.5) in
1706 (pageno, color, (x0, y0, x1, y1, x2
, y2
, x3
, y3
)) :: state
.rects1
1708 | "page" :: args
:: [] ->
1709 let pageopaques, t
= scan args
"%s %f" (fun p t
-> p
, t
) in
1710 let pageopaque = ~
< pageopaques in
1711 begin match state
.currently
with
1712 | Loading
(l, gen
) ->
1713 vlog "page %d took %f sec" l.pageno t
;
1714 Hashtbl.replace state
.pagemap
(l.pageno, gen
) pageopaque;
1715 begin match state
.throttle
with
1717 let preloadedpages =
1719 then preloadlayout state
.x state
.y state
.winw state
.winh
1724 List.fold_left
(fun s l -> IntSet.add
l.pageno s)
1725 IntSet.empty
preloadedpages
1728 Hashtbl.fold (fun ((pageno, _) as key) opaque
accu ->
1729 if not
(IntSet.mem
pageno set)
1731 wcmd "freepage %s" (~
> opaque
);
1737 List.iter
(Hashtbl.remove state
.pagemap
) evictedpages;
1740 state
.currently
<- Idle
;
1743 tilepage l.pageno pageopaque state
.layout;
1745 load preloadedpages;
1746 let visible = pagevisible state
.layout l.pageno in
1749 match state
.mode
with
1750 | LinkNav
(Ltnotready
(pageno, dir
)) ->
1751 if pageno = l.pageno
1756 then LDfirstvisible
(l.pagex
, l.pagey, dir
)
1758 if dir
> 0 then LDfirst
else LDlast
1761 findlink
pageopaque ld
1766 showlinktype (getlink
pageopaque n);
1767 state
.mode
<- LinkNav
(Ltexact
(l.pageno, n))
1769 | LinkNav
(Ltgendir
_)
1770 | LinkNav
(Ltexact
_)
1776 if visible && layoutready state
.layout
1778 G.postRedisplay "page";
1782 | Some
(layout, _, _) ->
1783 state
.currently
<- Idle
;
1784 tilepage l.pageno pageopaque layout;
1791 dolog
"Inconsistent loading state";
1792 logcurrently state
.currently
;
1796 | "tile" :: args
:: [] ->
1797 let (x, y, opaques
, size
, t
) =
1798 scan args
"%u %u %s %u %f"
1799 (fun x y p size t
-> (x, y, p
, size
, t
))
1801 let opaque = ~
< opaques
in
1802 begin match state
.currently
with
1803 | Tiling
(l, pageopaque, cs
, angle
, gen
, col, row, tilew
, tileh
) ->
1804 vlog "tile %d [%d,%d] took %f sec" l.pageno col row t
;
1807 if tilew
!= conf
.tilew
|| tileh
!= conf
.tileh
1809 wcmd "freetile %s" (~
> opaque);
1810 state
.currently
<- Idle
;
1814 puttileopaque l col row gen cs angle
opaque size t
;
1815 state
.memused
<- state
.memused
+ size
;
1816 state
.uioh#infochanged Memused
;
1818 Queue.push
((l.pageno, gen
, cs
, angle
, l.pagew
, l.pageh
, col, row),
1819 opaque, size
) state
.tilelru
;
1822 match state
.throttle
with
1823 | None
-> state
.layout
1824 | Some
(layout, _, _) -> layout
1827 state
.currently
<- Idle
;
1829 && conf
.colorspace
= cs
1830 && conf
.angle
= angle
1831 && tilevisible layout l.pageno x y
1832 then conttiling l.pageno pageopaque;
1834 begin match state
.throttle
with
1836 preload state
.layout;
1838 && conf
.colorspace
= cs
1839 && conf
.angle
= angle
1840 && tilevisible state
.layout l.pageno x y
1841 && (not
!wtmode || layoutready state
.layout)
1842 then G.postRedisplay "tile nothrottle";
1844 | Some
(layout, y, _) ->
1845 let ready = layoutready layout in
1849 state
.layout <- layout;
1850 state
.throttle
<- None
;
1851 G.postRedisplay "throttle";
1860 dolog
"Inconsistent tiling state";
1861 logcurrently state
.currently
;
1865 | "pdim" :: args
:: [] ->
1866 let (n, w, h, _) as pdim
=
1867 scan args
"%u %u %u %u" (fun n w h x -> n, w, h, x)
1870 match conf
.fitmodel
with
1872 | FitPage
| FitProportional
->
1873 match conf
.columns
with
1874 | Csplit
_ -> (n, w, h, 0)
1875 | Csingle
_ | Cmulti
_ -> pdim
1877 state
.uioh#infochanged Pdim
;
1878 state
.pdims
<- pdim :: state
.pdims
1880 | "o" :: args
:: [] ->
1881 let (l, n, t
, h, pos
) =
1882 scan args
"%u %u %d %u %n"
1883 (fun l n t
h pos
-> l, n, t
, h, pos
)
1885 let s = String.sub args pos
(String.length args
- pos
) in
1886 addoutline (s, l, Oanchor
(n, float t
/. float h, 0.0))
1888 | "ou" :: args
:: [] ->
1889 let (l, len, pos
) = scan args
"%u %u %n" (fun l len pos
-> l, len, pos
) in
1890 let s = String.sub args pos
len in
1891 let pos2 = pos
+ len + 1 in
1892 let uri = String.sub args
pos2 (String.length args
- pos2) in
1893 addoutline (s, l, Ouri
uri)
1895 | "on" :: args
:: [] ->
1896 let (l, pos
) = scan args
"%u %n" (fun l pos
-> l, pos
) in
1897 let s = String.sub args pos
(String.length args
- pos
) in
1898 addoutline (s, l, Onone
)
1900 | "a" :: args
:: [] ->
1902 scan args
"%u %d %d" (fun n l t
-> n, l, t
)
1904 state
.reprf
<- (fun () -> gotopagexy !wtmode n (float l) (float t
))
1906 | "info" :: args
:: [] ->
1907 let pos = nindex args '
\t'
in
1908 if pos >= 0 && String.sub args
0 pos = "Title"
1910 let s = String.sub args
(pos+1) @@ String.length args
- pos - 1 in
1914 state
.docinfo
<- (1, args
) :: state
.docinfo
1916 | "infoend" :: [] ->
1917 state
.uioh#infochanged Docinfo
;
1918 state
.docinfo
<- List.rev state
.docinfo
1922 then Wsi.settitle
"Wrong password";
1923 let password = getpassword () in
1924 if emptystr
password
1925 then error
"document is password protected"
1926 else opendoc state
.path
password
1928 error
"unknown cmd `%S'" cmds
1933 let action = function
1934 | HCprev
-> cbget cb ~
-1
1935 | HCnext
-> cbget cb
1
1936 | HCfirst
-> cbget cb ~
-(cb
.rc)
1937 | HClast
-> cbget cb
(cb
.len - 1 - cb
.rc)
1938 and cancel
() = cb
.rc <- rc
1942 let search pattern forward
=
1943 match conf
.columns
with
1944 | Csplit
_ -> impmsg "searching does not work properly in split columns mode"
1947 if nonemptystr pattern
1950 match state
.layout with
1953 l.pageno, (l.pagey + if forward
then 0 else 0*l.pagevh)
1955 wcmd "search %d %d %d %d,%s\000"
1956 (btod conf
.icase
) pn py (btod forward
) pattern
;
1959 let intentry text key =
1961 if key >= 32 && key < 127
1967 let text = addchar
text c in
1971 state
.text <- Printf.sprintf
"invalid char (%d, `%c')" key c;
1979 let l = String.length
s in
1980 let rec loop pos n = if pos = l then n else
1981 let m = Char.code
s.[pos] - (if pos = 0 && l > 1 then 96 else 97) in
1982 loop (pos+1) (n*26 + m)
1985 let rec loop n = function
1988 match getopaque l.pageno with
1989 | None
-> loop n rest
1991 let m = getlinkcount
opaque in
1994 let under = getlink
opaque n in
1997 else loop (n-m) rest
1999 loop n state
.layout;
2003 let linknentry text key =
2005 if key >= 32 && key < 127
2011 let text = addchar
text c in
2012 linknact (fun under -> state
.text <- undertext ~nopath
:true under) text;
2016 state
.text <- Printf.sprintf
"invalid char (%d, `%c')" key c;
2020 let textentry text key =
2021 if key land 0xff00 = 0xff00
2023 else TEcont
(text ^ toutf8
key)
2026 let reqlayout angle fitmodel
=
2027 match state
.throttle
with
2029 if nogeomcmds state
.geomcmds
2030 then state
.anchor <- getanchor
();
2031 conf
.angle
<- angle
mod 360;
2034 match state
.mode
with
2035 | LinkNav
_ -> state
.mode
<- View
2040 conf
.fitmodel
<- fitmodel
;
2041 invalidate "reqlayout"
2043 wcmd "reqlayout %d %d %d"
2044 conf
.angle
(FMTE.to_int conf
.fitmodel
) (stateh state
.winh
)
2049 let settrim trimmargins trimfuzz
=
2050 if nogeomcmds state
.geomcmds
2051 then state
.anchor <- getanchor
();
2052 conf
.trimmargins
<- trimmargins
;
2053 conf
.trimfuzz
<- trimfuzz
;
2054 let x0, y0, x1, y1 = trimfuzz
in
2055 invalidate "settrim"
2057 wcmd "settrim %d %d %d %d %d" (btod conf
.trimmargins
) x0 y0 x1 y1);
2062 match state
.throttle
with
2064 let zoom = max
0.0001 zoom in
2065 if zoom <> conf
.zoom
2067 state
.prevzoom
<- (conf
.zoom, state
.x);
2069 reshape state
.winw state
.winh
;
2070 state
.text <- Printf.sprintf
"zoom is now %-5.2f" (zoom *. 100.0);
2073 | Some
(layout, y, started
) ->
2075 match conf
.maxwait
with
2079 let dt = now
() -. started
in
2087 let setcolumns mode columns coverA coverB
=
2088 state
.prevcolumns
<- Some
(conf
.columns
, conf
.zoom);
2092 then impmsg "split mode doesn't work in bird's eye"
2094 conf
.columns
<- Csplit
(-columns
, E.a);
2102 conf
.columns
<- Csingle
E.a;
2107 conf
.columns
<- Cmulti
((columns
, coverA
, coverB
), E.a);
2111 reshape state
.winw state
.winh
;
2114 let resetmstate () =
2115 state
.mstate
<- Mnone
;
2116 Wsi.setcursor
Wsi.CURSOR_INHERIT
;
2119 let enterbirdseye () =
2120 let zoom = float conf
.thumbw
/. float state
.winw
in
2121 let birdseyepageno =
2122 let cy = state
.winh
/ 2 in
2126 let rec fold best
= function
2129 let d = cy - (l.pagedispy + l.pagevh/2)
2130 and dbest
= cy - (best
.pagedispy + best
.pagevh/2) in
2131 if abs
d < abs dbest
2138 state
.mode
<- Birdseye
(
2139 { conf
with zoom = conf
.zoom }, state
.x, birdseyepageno, -1, getanchor
()
2143 conf
.presentation
<- false;
2144 conf
.interpagespace
<- 10;
2145 conf
.hlinks
<- false;
2146 conf
.fitmodel
<- FitPage
;
2148 conf
.maxwait
<- None
;
2150 match conf
.beyecolumns
with
2153 Cmulti
((c, 0, 0), E.a)
2154 | None
-> Csingle
E.a
2158 state
.text <- Printf.sprintf
"birds eye mode on (zoom %3.1f%%)"
2163 reshape state
.winw state
.winh
;
2166 let leavebirdseye (c, leftx
, pageno, _, anchor) goback
=
2168 conf
.zoom <- c.zoom;
2169 conf
.presentation
<- c.presentation
;
2170 conf
.interpagespace
<- c.interpagespace
;
2171 conf
.maxwait
<- c.maxwait
;
2172 conf
.hlinks
<- c.hlinks
;
2173 conf
.fitmodel
<- c.fitmodel
;
2174 conf
.beyecolumns
<- (
2175 match conf
.columns
with
2176 | Cmulti
((c, _, _), _) -> Some
c
2178 | Csplit
_ -> failwith
"leaving bird's eye split mode"
2181 match c.columns
with
2182 | Cmulti
(c, _) -> Cmulti
(c, E.a)
2183 | Csingle
_ -> Csingle
E.a
2184 | Csplit
(c, _) -> Csplit
(c, E.a)
2188 state
.text <- Printf.sprintf
"birds eye mode off (zoom %3.1f%%)"
2191 reshape state
.winw state
.winh
;
2192 state
.anchor <- if goback
then anchor else (pageno, 0.0, 1.0);
2196 let togglebirdseye () =
2197 match state
.mode
with
2198 | Birdseye vals
-> leavebirdseye vals
true
2199 | View
-> enterbirdseye ()
2204 let upbirdseye incr
(conf
, leftx
, pageno, hooverpageno
, anchor) =
2205 let pageno = max
0 (pageno - incr
) in
2206 let rec loop = function
2207 | [] -> gotopage1 pageno 0
2208 | l :: _ when l.pageno = pageno ->
2209 if l.pagedispy >= 0 && l.pagey = 0
2210 then G.postRedisplay "upbirdseye"
2211 else gotopage1 pageno 0
2212 | _ :: rest
-> loop rest
2216 state
.mode
<- Birdseye
(conf
, leftx
, pageno, hooverpageno
, anchor)
2219 let downbirdseye incr
(conf
, leftx
, pageno, hooverpageno
, anchor) =
2220 let pageno = min
(state
.pagecount
- 1) (pageno + incr
) in
2221 state
.mode
<- Birdseye
(conf
, leftx
, pageno, hooverpageno
, anchor);
2222 let rec loop = function
2224 let y, h = getpageyh
pageno in
2225 let dy = (y - state
.y) - (state
.winh
- h - conf
.interpagespace
) in
2227 | l :: _ when l.pageno = pageno ->
2228 if l.pagevh != l.pageh
2229 then gotoy (clamp (l.pageh
- l.pagevh + conf
.interpagespace
))
2230 else G.postRedisplay "downbirdseye"
2231 | _ :: rest
-> loop rest
2237 let optentry mode
_ key =
2238 let btos b = if b then "on" else "off" in
2239 if key >= 32 && key < 127
2241 let c = Char.chr
key in
2245 try conf
.scrollstep
<- int_of_string
s with exc
->
2246 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exc
2248 TEswitch
("scroll step: ", E.s, None
, intentry, ondone, true)
2253 conf
.autoscrollstep
<- boundastep state
.winh
(int_of_string
s);
2254 if state
.autoscroll
<> None
2255 then state
.autoscroll
<- Some conf
.autoscrollstep
2257 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exc
2259 TEswitch
("auto scroll step: ", E.s, None
, intentry, ondone, true)
2264 let n, a, b = multicolumns_of_string
s in
2265 setcolumns mode
n a b;
2267 state
.text <- Printf.sprintf
"bad columns `%s': %s" s @@ exntos exc
2269 TEswitch
("columns: ", E.s, None
, textentry, ondone, true)
2274 let zoom = float (int_of_string
s) /. 100.0 in
2277 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exc
2279 TEswitch
("zoom: ", E.s, None
, intentry, ondone, true)
2284 conf
.thumbw
<- bound
(int_of_string
s) 2 4096;
2286 Printf.sprintf
"thumbnail width is set to %d" conf
.thumbw
;
2287 begin match mode
with
2289 leavebirdseye beye
false;
2296 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exc
2298 TEswitch
("thumbnail width: ", E.s, None
, intentry, ondone, true)
2303 Some
(int_of_string
s)
2306 Printf.sprintf
"bad integer `%s': %s" s @@ exntos exc
;
2309 | Some angle
-> reqlayout angle conf
.fitmodel
2312 TEswitch
("rotation: ", E.s, None
, intentry, ondone, true)
2315 conf
.icase
<- not conf
.icase
;
2316 TEdone
("case insensitive search " ^
(btos conf
.icase
))
2319 conf
.preload <- not conf
.preload;
2321 TEdone
("preload " ^
(btos conf
.preload))
2324 conf
.verbose
<- not conf
.verbose
;
2325 TEdone
("verbose " ^
(btos conf
.verbose
))
2328 conf
.debug
<- not conf
.debug
;
2329 TEdone
("debug " ^
(btos conf
.debug
))
2332 conf
.maxhfit
<- not conf
.maxhfit
;
2333 state
.maxy
<- calcheight
();
2334 TEdone
("maxhfit " ^
(btos conf
.maxhfit
))
2337 conf
.crophack
<- not conf
.crophack
;
2338 TEdone
("crophack " ^
btos conf
.crophack
)
2342 match conf
.maxwait
with
2344 conf
.maxwait
<- Some infinity
;
2345 "always wait for page to complete"
2347 conf
.maxwait
<- None
;
2348 "show placeholder if page is not ready"
2353 conf
.underinfo
<- not conf
.underinfo
;
2354 TEdone
("underinfo " ^
btos conf
.underinfo
)
2357 conf
.savebmarks
<- not conf
.savebmarks
;
2358 TEdone
("persistent bookmarks " ^
btos conf
.savebmarks
)
2364 match state
.layout with
2369 conf
.interpagespace
<- int_of_string
s;
2370 docolumns conf
.columns
;
2371 state
.maxy
<- calcheight
();
2372 let y = getpagey
pageno in
2375 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exc
2377 TEswitch
("vertical margin: ", E.s, None
, intentry, ondone, true)
2381 match conf
.fitmodel
with
2382 | FitProportional
-> FitWidth
2383 | FitWidth
| FitPage
-> FitProportional
2385 reqlayout conf
.angle
fm;
2386 TEdone
("proportional display " ^
btos (fm == FitProportional
))
2389 settrim (not conf
.trimmargins
) conf
.trimfuzz
;
2390 TEdone
("trim margins " ^
btos conf
.trimmargins
)
2393 conf
.invert
<- not conf
.invert
;
2394 TEdone
("invert colors " ^
btos conf
.invert
)
2398 cbput state
.hists
.sel
s;
2401 TEswitch
("selection command: ", E.s, Some
(onhist state
.hists
.sel
),
2402 textentry, ondone, true)
2406 then conf
.pax
<- Some
(ref (0.0, 0, 0))
2407 else conf
.pax
<- None
;
2408 TEdone
("PAX " ^
btos (conf
.pax
!= None
))
2411 state
.text <- Printf.sprintf
"bad option %d `%c'" key c;
2417 class type lvsource
= object
2418 method getitemcount
: int
2419 method getitem
: int -> (string * int)
2420 method hasaction
: int -> bool
2428 method getactive
: int
2429 method getfirst
: int
2431 method getminfo
: (int * int) array
2434 class virtual lvsourcebase
= object
2435 val mutable m_active
= 0
2436 val mutable m_first
= 0
2437 val mutable m_pan
= 0
2438 method getactive
= m_active
2439 method getfirst
= m_first
2440 method getpan
= m_pan
2441 method getminfo
: (int * int) array
= E.a
2444 let textentrykeyboard
2445 key _mask
((c, text, opthist
, onkey
, ondone, cancelonempty
), onleave
) =
2448 if key >= 0xffb0 && key <= 0xffb9
2449 then key - 0xffb0 + 48 else key
2452 state
.mode
<- Textentry
(te
, onleave
);
2454 G.postRedisplay "textentrykeyboard enttext";
2456 let histaction cmd
=
2459 | Some
(action, _) ->
2460 state
.mode
<- Textentry
(
2461 (c, action cmd
, opthist
, onkey
, ondone, cancelonempty
), onleave
2463 G.postRedisplay "textentry histaction"
2467 if emptystr
text && cancelonempty
2470 G.postRedisplay "textentrykeyboard after cancel";
2473 let s = withoutlastutf8
text in
2474 enttext (c, s, opthist
, onkey
, ondone, cancelonempty
)
2476 | @enter
| @kpenter
->
2479 G.postRedisplay "textentrykeyboard after confirm"
2481 | @up
| @kpup
-> histaction HCprev
2482 | @down
| @kpdown
-> histaction HCnext
2483 | @home
| @kphome
-> histaction HCfirst
2484 | @jend
| @kpend
-> histaction HClast
2489 begin match opthist
with
2491 | Some
(_, onhistcancel
) -> onhistcancel
()
2495 G.postRedisplay "textentrykeyboard after cancel2"
2498 enttext (c, E.s, opthist
, onkey
, ondone, cancelonempty
)
2501 | @delete
| @kpdelete
-> ()
2504 && key land 0xff00 != 0xff00 (* keyboard *)
2505 && key land 0xfe00 != 0xfe00 (* xkb *)
2506 && key land 0xfd00 != 0xfd00 (* 3270 *)
2508 begin match onkey
text key with
2512 G.postRedisplay "textentrykeyboard after confirm2";
2515 enttext (c, text, opthist
, onkey
, ondone, cancelonempty
);
2519 G.postRedisplay "textentrykeyboard after cancel3"
2522 state
.mode
<- Textentry
(te
, onleave
);
2523 G.postRedisplay "textentrykeyboard switch";
2527 vlog "unhandled key %s" (Wsi.keyname
key)
2530 let firstof first active
=
2531 if first
> active
|| abs
(first
- active
) > fstate
.maxrows
- 1
2532 then max
0 (active
- (fstate
.maxrows
/2))
2536 let calcfirst first active
=
2539 let rows = active
- first
in
2540 if rows > fstate
.maxrows
then active
- fstate
.maxrows
else first
2544 let scrollph y maxy
=
2545 let sh = float (maxy
+ state
.winh
) /. float state
.winh
in
2546 let sh = float state
.winh
/. sh in
2547 let sh = max
sh (float conf
.scrollh
) in
2549 let percent = float y /. float maxy
in
2550 let position = (float state
.winh
-. sh) *. percent in
2553 if position +. sh > float state
.winh
2554 then float state
.winh
-. sh
2560 let coe s = (s :> uioh
);;
2562 class listview ~zebra ~helpmode ~
(source
:lvsource
) ~trusted ~modehash
=
2564 val m_pan
= source#getpan
2565 val m_first
= source#getfirst
2566 val m_active
= source#getactive
2568 val m_prev_uioh
= state
.uioh
2570 method private elemunder
y =
2574 let n = y / (fstate
.fontsize
+1) in
2575 if m_first
+ n < source#getitemcount
2577 if source#hasaction
(m_first
+ n)
2578 then Some
(m_first
+ n)
2585 GlFunc.blend_func ~src
:`src_alpha ~dst
:`one_minus_src_alpha
;
2586 GlDraw.color (0., 0., 0.) ~alpha
:0.85;
2587 filledrect 0. 0. (float state
.winw
) (float state
.winh
);
2588 GlDraw.color (1., 1., 1.);
2589 Gl.enable `texture_2d
;
2590 let fs = fstate
.fontsize
in
2592 let hw = (wadjsb () + xadjsb () + state
.winw
)/3 in
2593 let ww = fstate
.wwidth
in
2594 let tabw = 17.0*.ww in
2595 let itemcount = source#getitemcount
in
2596 let minfo = source#getminfo
in
2599 then float (xadjsb ()), float (state
.winw
- 1)
2600 else 0.0, float (state
.winw
- conf
.scrollbw
- 1)
2602 let xadj = xadjsb () in
2604 if (row - m_first
) > fstate
.maxrows
2607 if row >= 0 && row < itemcount
2609 let (s, level
) = source#getitem
row in
2610 let y = (row - m_first
) * nfs in
2612 (if conf
.leftscroll
then float xadj else 5.0)
2613 +. (float (level
+ m_pan
)) *. ww in
2616 (let c = if row land 1 = 0 then 1.0 else 0.92 in (c,c,c));
2620 Gl.disable `texture_2d
;
2621 let alpha = if source#hasaction
row then 0.9 else 0.3 in
2622 GlDraw.color (1., 1., 1.) ~
alpha;
2623 linerect (x0 +. 1.) (float (y + 1)) (x1) (float (y + fs + 3));
2624 Gl.enable `texture_2d
;
2627 if zebra
&& row land 1 = 1
2631 GlDraw.color (c,c,c);
2632 let drawtabularstring s =
2634 let x'
= truncate
(x0 +. x) in
2635 let pos = nindex
s '
\000'
in
2637 then drawstring1 fs x'
(y+nfs) s
2639 let s1 = String.sub
s 0 pos
2640 and s2
= String.sub
s (pos+1) (String.length
s - pos - 1) in
2645 let s'
= withoutlastutf8
s in
2646 let s = s' ^
"@Uellipsis" in
2647 let w = measurestr
fs s in
2648 if float x'
+. w +. ww < float (hw + x'
)
2653 if float x'
+. ww +. measurestr
fs s1 > float (hw + x'
)
2657 ignore
(drawstring1 fs x'
(y+nfs) s1);
2658 drawstring1 fs (hw + x'
) (y+nfs) s2
2662 let x = if helpmode
&& row > 0 then x +. ww else x in
2663 let tabpos = nindex
s '
\t'
in
2666 let len = String.length
s - tabpos - 1 in
2667 let s1 = String.sub
s 0 tabpos
2668 and s2
= String.sub
s (tabpos + 1) len in
2669 let nx = drawstr x s1 in
2671 let x = x +. (max
tabw sw) in
2674 let len = String.length
s - 2 in
2675 if len > 0 && s.[0] = '
\xc2'
&& s.[1] = '
\xb7'
2677 let s = String.sub
s 2 len in
2678 let x = if not helpmode
then x +. ww else x in
2679 GlDraw.color (1.2, 1.2, 1.2);
2680 let vinc = drawstring1 (fs+fs/4)
2681 (truncate
(x -. ww)) (y+nfs) s in
2682 GlDraw.color (1., 1., 1.);
2683 vinc +. (float fs *. 0.8)
2689 ignore
(drawtabularstring s);
2695 GlDraw.color (1.0, 1.0, 1.0) ~
alpha:0.5;
2696 let xadj = float (xadjsb () + 5) in
2698 if (row - m_first
) > fstate
.maxrows
2701 if row >= 0 && row < itemcount
2703 let (s, level
) = source#getitem
row in
2704 let pos0 = nindex
s '
\000'
in
2705 let y = (row - m_first
) * nfs in
2706 let x = float (level
+ m_pan
) *. ww in
2707 let (first
, last
) = minfo.(row) in
2709 if pos0 > 0 && first
> pos0
2710 then String.sub
s (pos0+1) (first
-pos0-1)
2711 else String.sub
s 0 first
2713 let suffix = String.sub
s first
(last
- first
) in
2714 let w1 = measurestr fstate
.fontsize
prefix in
2715 let w2 = measurestr fstate
.fontsize
suffix in
2716 let x = x +. if conf
.leftscroll
then xadj else 5.0 in
2717 let x = if pos0 > 0 && first
> pos0 then x +. float hw else x in
2719 and y0 = float (y+2) in
2721 and y1 = float (y+fs+3) in
2722 filledrect x0 y0 x1 y1;
2727 Gl.disable `texture_2d
;
2728 if Array.length
minfo > 0 then loop m_first
;
2731 method updownlevel incr
=
2732 let len = source#getitemcount
in
2734 if m_active
>= 0 && m_active
< len
2735 then snd
(source#getitem m_active
)
2739 if i
= len then i
-1 else if i
= -1 then 0 else
2740 let _, l = source#getitem i
in
2741 if l != curlevel then i
else flow (i
+incr
)
2743 let active = flow m_active
in
2744 let first = calcfirst m_first
active in
2745 G.postRedisplay "outline updownlevel";
2746 {< m_active
= active; m_first
= first >}
2748 method private key1
key mask
=
2749 let set1 active first qsearch
=
2750 coe {< m_active
= active; m_first
= first; m_qsearch
= qsearch
>}
2752 let search active pattern incr
=
2753 let active = if active = -1 then m_first
else active in
2756 if n >= 0 && n < source#getitemcount
2758 let s, _ = source#getitem
n in
2759 match Str.search_forward re
s 0 with
2760 | (exception Not_found
) -> loop (n + incr
)
2767 Str.regexp_case_fold pattern
|> dosearch
2769 let itemcount = source#getitemcount
in
2770 let find start incr
=
2772 if i
= -1 || i
= itemcount
2775 if source#hasaction i
2777 else find (i
+ incr
)
2782 let set active first =
2783 let first = bound
first 0 (itemcount - fstate
.maxrows
) in
2785 coe {< m_active
= active; m_first
= first; m_qsearch
= E.s >}
2788 let isvisible first n = n >= first && n - first <= fstate
.maxrows
in
2790 let incr1 = if incr
> 0 then 1 else -1 in
2791 if isvisible m_first m_active
2794 let next = m_active
+ incr
in
2796 if next < 0 || next >= itemcount
2798 else find next incr1
2800 if abs
(m_active
- next) > fstate
.maxrows
2806 let first = m_first
+ incr
in
2807 let first = bound
first 0 (itemcount - fstate
.maxrows
) in
2809 let next = m_active
+ incr
in
2810 let next = bound
next 0 (itemcount - 1) in
2817 if isvisible first next
2824 let first = min
next m_first
in
2826 if abs
(next - first) > fstate
.maxrows
2832 let first = m_first
+ incr
in
2833 let first = bound
first 0 (itemcount - 1) in
2835 let next = m_active
+ incr
in
2836 let next = bound
next 0 (itemcount - 1) in
2837 let next = find next incr1 in
2839 if next = -1 || abs
(m_active
- first) > fstate
.maxrows
2841 let active = if m_active
= -1 then next else m_active
in
2846 if isvisible first active
2852 G.postRedisplay "listview navigate";
2856 | (@r
|@s) when Wsi.withctrl mask
->
2857 let incr = if key = @r
then -1 else 1 in
2859 match search (m_active
+ incr) m_qsearch
incr with
2861 state
.text <- m_qsearch ^
" [not found]";
2864 state
.text <- m_qsearch
;
2865 active, firstof m_first
active
2867 G.postRedisplay "listview ctrl-r/s";
2868 set1 active first m_qsearch
;
2870 | @insert
when Wsi.withctrl mask
->
2871 if m_active
>= 0 && m_active
< source#getitemcount
2873 let s, _ = source#getitem m_active
in
2879 if emptystr m_qsearch
2882 let qsearch = withoutlastutf8 m_qsearch
in
2886 G.postRedisplay "listview empty qsearch";
2887 set1 m_active m_first
E.s;
2891 match search m_active
qsearch ~
-1 with
2893 state
.text <- qsearch ^
" [not found]";
2896 state
.text <- qsearch;
2897 active, firstof m_first
active
2899 G.postRedisplay "listview backspace qsearch";
2900 set1 active first qsearch
2903 | key when (key != 0 && key land 0xff00 != 0xff00) ->
2904 let pattern = m_qsearch ^ toutf8
key in
2906 match search m_active
pattern 1 with
2908 state
.text <- pattern ^
" [not found]";
2911 state
.text <- pattern;
2912 active, firstof m_first
active
2914 G.postRedisplay "listview qsearch add";
2915 set1 active first pattern;
2919 if emptystr m_qsearch
2921 G.postRedisplay "list view escape";
2922 let mx, my
= state
.mpos
in
2926 source#exit ~uioh
:(coe self
)
2927 ~cancel
:true ~
active:m_active ~
first:m_first ~pan
:m_pan
2929 | None
-> m_prev_uioh
2934 G.postRedisplay "list view kill qsearch";
2935 coe {< m_qsearch
= E.s >}
2938 | @enter
| @kpenter
->
2940 let self = {< m_qsearch
= E.s >} in
2942 G.postRedisplay "listview enter";
2943 if m_active
>= 0 && m_active
< source#getitemcount
2945 source#exit ~uioh
:(coe self) ~cancel
:false
2946 ~
active:m_active ~
first:m_first ~pan
:m_pan
;
2949 source#exit ~uioh
:(coe self) ~cancel
:true
2950 ~
active:m_active ~
first:m_first ~pan
:m_pan
;
2953 begin match opt with
2954 | None
-> m_prev_uioh
2958 | @delete
| @kpdelete
->
2961 | @up
| @kpup
-> navigate ~
-1
2962 | @down
| @kpdown
-> navigate 1
2963 | @prior
| @kpprior
-> navigate ~
-(fstate
.maxrows
)
2964 | @next | @kpnext
-> navigate fstate
.maxrows
2966 | @right
| @kpright
->
2968 G.postRedisplay "listview right";
2969 coe {< m_pan
= m_pan
- 1 >}
2971 | @left | @kpleft
->
2973 G.postRedisplay "listview left";
2974 coe {< m_pan
= m_pan
+ 1 >}
2976 | @home
| @kphome
->
2977 let active = find 0 1 in
2978 G.postRedisplay "listview home";
2982 let first = max
0 (itemcount - fstate
.maxrows
) in
2983 let active = find (itemcount - 1) ~
-1 in
2984 G.postRedisplay "listview end";
2987 | key when (key = 0 || key land 0xff00 = 0xff00) ->
2991 dolog
"listview unknown key %#x" key; coe self
2993 method key key mask
=
2994 match state
.mode
with
2995 | Textentry te
-> textentrykeyboard key mask te
; coe self
2998 | LinkNav
_ -> self#key1
key mask
3000 method button button down
x y _ =
3003 | 1 when vscrollhit x ->
3004 G.postRedisplay "listview scroll";
3007 let _, position, sh = self#
scrollph in
3008 if y > truncate
position && y < truncate
(position +. sh)
3010 state
.mstate
<- Mscrolly
;
3014 let s = float (max
0 (y - conf
.scrollh
)) /. float state
.winh
in
3015 let first = truncate
(s *. float source#getitemcount
) in
3016 let first = min source#getitemcount
first in
3017 Some
(coe {< m_first
= first; m_active
= first >})
3019 state
.mstate
<- Mnone
;
3023 begin match self#elemunder
y with
3025 G.postRedisplay "listview click";
3026 source#exit ~uioh
:(coe {< m_active
= n >})
3027 ~cancel
:false ~
active:n ~
first:m_first ~pan
:m_pan
3031 | n when (n == 4 || n == 5) && not down
->
3032 let len = source#getitemcount
in
3034 if n = 5 && m_first
+ fstate
.maxrows
>= len
3038 let first = m_first
+ (if n == 4 then -1 else 1) in
3039 bound
first 0 (len - 1)
3041 G.postRedisplay "listview wheel";
3042 Some
(coe {< m_first
= first >})
3043 | n when (n = 6 || n = 7) && not down
->
3044 let inc = if n = 7 then -1 else 1 in
3045 G.postRedisplay "listview hwheel";
3046 Some
(coe {< m_pan
= m_pan
+ inc >})
3051 | None
-> m_prev_uioh
3054 method multiclick
_ x y = self#button
1 true x y
3057 match state
.mstate
with
3059 let s = float (max
0 (y - conf
.scrollh
)) /. float state
.winh
in
3060 let first = truncate
(s *. float source#getitemcount
) in
3061 let first = min source#getitemcount
first in
3062 G.postRedisplay "listview motion";
3063 coe {< m_first
= first; m_active
= first >}
3071 method pmotion
x y =
3072 if x < state
.winw
- conf
.scrollbw
3075 match self#elemunder
y with
3076 | None
-> Wsi.setcursor
Wsi.CURSOR_INHERIT
; m_active
3077 | Some
n -> Wsi.setcursor
Wsi.CURSOR_INFO
; n
3081 then (G.postRedisplay "listview pmotion"; {< m_active
= n >})
3086 Wsi.setcursor
Wsi.CURSOR_INHERIT
;
3090 method infochanged
_ = ()
3092 method scrollpw
= (0, 0.0, 0.0)
3094 let nfs = fstate
.fontsize
+ 1 in
3095 let y = m_first
* nfs in
3096 let itemcount = source#getitemcount
in
3097 let maxi = max
0 (itemcount - fstate
.maxrows
) in
3098 let maxy = maxi * nfs in
3099 let p, h = scrollph y maxy in
3102 method modehash
= modehash
3103 method eformsgs
= false
3104 method alwaysscrolly
= true
3107 class outlinelistview ~zebra ~source
=
3108 let settext autonarrow
s =
3111 let ss = source#statestr
in
3115 else "{" ^
ss ^
"} [" ^
s ^
"]"
3116 else state
.text <- s
3122 ~source
:(source
:> lvsource
)
3124 ~modehash
:(findkeyhash conf
"outline")
3127 val m_autonarrow
= false
3129 method! key key mask
=
3131 if emptystr state
.text
3133 else fstate
.maxrows - 2
3135 let calcfirst first active =
3138 let rows = active - first in
3139 if rows > maxrows then active - maxrows else first
3143 let active = m_active
+ incr in
3144 let active = bound
active 0 (source#getitemcount
- 1) in
3145 let first = calcfirst m_first
active in
3146 G.postRedisplay "outline navigate";
3147 coe {< m_active
= active; m_first
= first >}
3149 let navscroll first =
3151 let dist = m_active
- first in
3157 else first + maxrows
3160 G.postRedisplay "outline navscroll";
3161 coe {< m_first
= first; m_active
= active >}
3163 let ctrl = Wsi.withctrl mask
in
3168 then (source#denarrow
; E.s)
3170 let pattern = source#renarrow
in
3171 if nonemptystr m_qsearch
3172 then (source#narrow m_qsearch
; m_qsearch
)
3176 settext (not m_autonarrow
) text;
3177 G.postRedisplay "toggle auto narrowing";
3178 coe {< m_first
= 0; m_active
= 0; m_autonarrow
= not m_autonarrow
>}
3180 | @slash
when emptystr m_qsearch
&& not m_autonarrow
->
3182 G.postRedisplay "toggle auto narrowing";
3183 coe {< m_first
= 0; m_active
= 0; m_autonarrow
= true >}
3186 source#narrow m_qsearch
;
3188 then source#add_narrow_pattern m_qsearch
;
3189 G.postRedisplay "outline ctrl-n";
3190 coe {< m_first
= 0; m_active
= 0 >}
3193 let active = source#calcactive
(getanchor
()) in
3194 let first = firstof m_first
active in
3195 G.postRedisplay "outline ctrl-s";
3196 coe {< m_first
= first; m_active
= active >}
3199 G.postRedisplay "outline ctrl-u";
3200 if m_autonarrow
&& nonemptystr m_qsearch
3202 ignore
(source#renarrow
);
3203 settext m_autonarrow
E.s;
3204 coe {< m_first
= 0; m_active
= 0; m_qsearch
= E.s >}
3207 source#del_narrow_pattern
;
3208 let pattern = source#renarrow
in
3210 if emptystr
pattern then E.s else "Narrowed to " ^
pattern
3212 settext m_autonarrow
text;
3213 coe {< m_first
= 0; m_active
= 0; m_qsearch
= E.s >}
3217 let first = max
0 (m_active
- (fstate
.maxrows / 2)) in
3218 G.postRedisplay "outline ctrl-l";
3219 coe {< m_first
= first >}
3221 | @tab
when m_autonarrow
->
3222 if nonemptystr m_qsearch
3224 G.postRedisplay "outline list view tab";
3225 source#add_narrow_pattern m_qsearch
;
3227 coe {< m_qsearch
= E.s >}
3231 | @escape
when m_autonarrow
->
3232 if nonemptystr m_qsearch
3233 then source#add_narrow_pattern m_qsearch
;
3236 | @enter
| @kpenter
when m_autonarrow
->
3237 if nonemptystr m_qsearch
3238 then source#add_narrow_pattern m_qsearch
;
3241 | key when m_autonarrow
&& (key != 0 && key land 0xff00 != 0xff00) ->
3242 let pattern = m_qsearch ^ toutf8
key in
3243 G.postRedisplay "outlinelistview autonarrow add";
3244 source#narrow
pattern;
3245 settext true pattern;
3246 coe {< m_first
= 0; m_active
= 0; m_qsearch
= pattern >}
3248 | key when m_autonarrow
&& key = @backspace
->
3249 if emptystr m_qsearch
3252 let pattern = withoutlastutf8 m_qsearch
in
3253 G.postRedisplay "outlinelistview autonarrow backspace";
3254 ignore
(source#renarrow
);
3255 source#narrow
pattern;
3256 settext true pattern;
3257 coe {< m_first
= 0; m_active
= 0; m_qsearch
= pattern >}
3259 | @up
| @kpup
when ctrl ->
3260 navscroll (max
0 (m_first
- 1))
3262 | @down
| @kpdown
when ctrl ->
3263 navscroll (min
(source#getitemcount
- 1) (m_first
+ 1))
3265 | @up
| @kpup
-> navigate ~
-1
3266 | @down
| @kpdown
-> navigate 1
3267 | @prior
| @kpprior
-> navigate ~
-(fstate
.maxrows)
3268 | @next | @kpnext
-> navigate fstate
.maxrows
3270 | @right
| @kpright
->
3274 G.postRedisplay "outline ctrl right";
3275 {< m_pan
= m_pan
+ 1 >}
3277 else self#updownlevel
1
3281 | @left | @kpleft
->
3285 G.postRedisplay "outline ctrl left";
3286 {< m_pan
= m_pan
- 1 >}
3288 else self#updownlevel ~
-1
3292 | @home
| @kphome
->
3293 G.postRedisplay "outline home";
3294 coe {< m_first
= 0; m_active
= 0 >}
3297 let active = source#getitemcount
- 1 in
3298 let first = max
0 (active - fstate
.maxrows) in
3299 G.postRedisplay "outline end";
3300 coe {< m_active
= active; m_first
= first >}
3302 | _ -> super#
key key mask
3305 let genhistoutlines () =
3307 |> List.sort
(fun (_, c1
, _, _, _, _) (_, c2
, _, _, _, _) ->
3308 compare c2
.lastvisit c1
.lastvisit
)
3310 (fun ((path
, c, _, _, _, origin
) as hist
) ->
3311 let path = if nonemptystr origin
then origin
else path in
3312 let base = mbtoutf8
@@ Filename.basename
path in
3313 (base ^
"\000" ^
c.title
, 1, Ohistory hist
)
3318 let gotohist (path, c, bookmarks
, x, anchor, origin
) =
3319 Config.save
leavebirdseye;
3320 state
.anchor <- anchor;
3321 state
.bookmarks
<- bookmarks
;
3322 state
.origin
<- origin
;
3325 let x0, y0, x1, y1 = conf
.trimfuzz
in
3326 wcmd "trimset %d %d %d %d %d" (btod conf
.trimmargins
) x0 y0 x1 y1;
3327 reshape ~firsttime
:true state
.winw state
.winh
;
3328 opendoc path origin
;
3332 let makecheckers () =
3333 (* Based on lablGL-1.04/LablGlut/examples/lablGL/checker.ml which had
3335 converted by Issac Trotts. July 25, 2002 *)
3336 let image = GlPix.create `ubyte ~format
:`luminance ~width
:2 ~height
:2 in
3337 Raw.sets_string
(GlPix.to_raw
image) ~
pos:0 "\255\200\200\255";
3338 let id = GlTex.gen_texture
() in
3339 GlTex.bind_texture ~target
:`texture_2d
id;
3340 GlPix.store
(`unpack_alignment
1);
3341 GlTex.image2d
image;
3342 List.iter
(GlTex.parameter ~target
:`texture_2d
)
3343 [ `mag_filter `nearest
; `min_filter `nearest
];
3347 let setcheckers enabled
=
3348 match state
.checkerstexid
with
3350 if enabled
then state
.checkerstexid
<- Some
(makecheckers ())
3352 | Some checkerstexid
->
3355 GlTex.delete_texture checkerstexid
;
3356 state
.checkerstexid
<- None
;
3360 let describe_location () =
3361 let fn = page_of_y state
.y in
3362 let ln = page_of_y
(state
.y + state
.winh
- hscrollh () - 1) in
3363 let maxy = state
.maxy - (if conf
.maxhfit
then state
.winh
else 0) in
3367 else (100. *. (float state
.y /. float maxy))
3371 Printf.sprintf
"page %d of %d [%.2f%%]"
3372 (fn+1) state
.pagecount
percent
3375 "pages %d-%d of %d [%.2f%%]"
3376 (fn+1) (ln+1) state
.pagecount
percent
3379 let setpresentationmode v
=
3380 let n = page_of_y state
.y in
3381 state
.anchor <- (n, 0.0, 1.0);
3382 conf
.presentation
<- v
;
3383 if conf
.fitmodel
= FitPage
3384 then reqlayout conf
.angle conf
.fitmodel
;
3389 let btos b = if b then "@Uradical" else E.s in
3390 let showextended = ref false in
3391 let leave mode
_ = state
.mode
<- mode
in
3394 val mutable m_l
= []
3395 val mutable m_a
= E.a
3396 val mutable m_prev_uioh
= nouioh
3397 val mutable m_prev_mode
= View
3399 inherit lvsourcebase
3401 method reset prev_mode prev_uioh
=
3402 m_a
<- Array.of_list
(List.rev m_l
);
3404 m_prev_mode
<- prev_mode
;
3405 m_prev_uioh
<- prev_uioh
;
3407 method int name get
set =
3409 (name
, `
int get
, 1, Action
(
3412 try set (int_of_string
s)
3414 state
.text <- Printf.sprintf
"bad integer `%s': %s"
3418 let te = name ^
": ", E.s, None
, intentry, ondone, true in
3419 state
.mode
<- Textentry
(te, leave m_prev_mode
);
3423 method int_with_suffix name get
set =
3425 (name
, `intws get
, 1, Action
(
3428 try set (int_of_string_with_suffix
s)
3430 state
.text <- Printf.sprintf
"bad integer `%s': %s"
3435 name ^
": ", E.s, None
, intentry_with_suffix, ondone, true
3437 state
.mode
<- Textentry
(te, leave m_prev_mode
);
3441 method bool ?
(offset
=1) ?
(btos=btos) name get
set =
3443 (name
, `
bool (btos, get
), offset
, Action
(
3450 method color name get
set =
3452 (name
, `
color get
, 1, Action
(
3454 let invalid = (nan
, nan
, nan
) in
3457 try color_of_string
s
3459 state
.text <- Printf.sprintf
"bad color `%s': %s"
3466 let te = name ^
": ", E.s, None
, textentry, ondone, true in
3467 state
.text <- color_to_string
(get
());
3468 state
.mode
<- Textentry
(te, leave m_prev_mode
);
3472 method string name get
set =
3474 (name
, `
string get
, 1, Action
(
3476 let ondone s = set s in
3477 let te = name ^
": ", E.s, None
, textentry, ondone, true in
3478 state
.mode
<- Textentry
(te, leave m_prev_mode
);
3482 method colorspace name get
set =
3484 (name
, `
string get
, 1, Action
(
3488 inherit lvsourcebase
3491 m_active
<- CSTE.to_int conf
.colorspace
;
3494 method getitemcount
=
3495 Array.length
CSTE.names
3498 method exit ~uioh ~cancel ~
active ~
first ~pan
=
3499 ignore
(uioh
, first, pan
);
3500 if not cancel
then set active;
3502 method hasaction
_ = true
3506 let modehash = findkeyhash conf
"info" in
3507 coe (new listview ~zebra
:false ~helpmode
:false
3508 ~
source ~trusted
:true ~
modehash)
3511 method paxmark name get
set =
3513 (name
, `
string get
, 1, Action
(
3517 inherit lvsourcebase
3520 m_active
<- MTE.to_int conf
.paxmark
;
3523 method getitemcount
= Array.length
MTE.names
3524 method getitem
n = (MTE.names
.(n), 0)
3525 method exit ~uioh ~cancel ~
active ~
first ~pan
=
3526 ignore
(uioh
, first, pan
);
3527 if not cancel
then set active;
3529 method hasaction
_ = true
3533 let modehash = findkeyhash conf
"info" in
3534 coe (new listview ~zebra
:false ~helpmode
:false
3535 ~
source ~trusted
:true ~
modehash)
3538 method fitmodel name get
set =
3540 (name
, `
string get
, 1, Action
(
3544 inherit lvsourcebase
3547 m_active
<- FMTE.to_int conf
.fitmodel
;
3550 method getitemcount
= Array.length
FMTE.names
3551 method getitem
n = (FMTE.names
.(n), 0)
3552 method exit ~uioh ~cancel ~
active ~
first ~pan
=
3553 ignore
(uioh
, first, pan
);
3554 if not cancel
then set active;
3556 method hasaction
_ = true
3560 let modehash = findkeyhash conf
"info" in
3561 coe (new listview ~zebra
:false ~helpmode
:false
3562 ~
source ~trusted
:true ~
modehash)
3565 method caption
s offset
=
3566 m_l
<- (s, `empty
, offset
, Noaction
) :: m_l
3568 method caption2
s f offset
=
3569 m_l
<- (s, `
string f, offset
, Noaction
) :: m_l
3571 method getitemcount
= Array.length m_a
3574 let tostr = function
3575 | `
int f -> string_of_int
(f ())
3576 | `intws
f -> string_with_suffix_of_int
(f ())
3578 | `
color f -> color_to_string
(f ())
3579 | `
bool (btos, f) -> btos (f ())
3582 let name, t
, offset
, _ = m_a
.(n) in
3583 ((let s = tostr t
in
3585 then Printf.sprintf
"%s\t%s" name s
3589 method exit ~uioh ~cancel ~
active ~
first ~pan
=
3594 match m_a
.(active) with
3595 | _, _, _, Action
f -> f uioh
3596 | _, _, _, Noaction
-> uioh
3607 method hasaction
n =
3609 | _, _, _, Action
_ -> true
3610 | _, _, _, Noaction
-> false
3612 initializer m_active
<- 1
3615 let rec fillsrc prevmode prevuioh
=
3616 let sep () = src#caption
E.s 0 in
3617 let colorp name get
set =
3619 (fun () -> color_to_string
(get
()))
3622 let c = color_of_string
v in
3625 state
.text <- Printf.sprintf
"bad color `%s': %s" v @@ exntos exn
3628 let oldmode = state
.mode
in
3629 let birdseye = isbirdseye state
.mode
in
3631 src#caption
(if birdseye then "Setup (Bird's eye)" else "Setup") 0;
3633 src#
bool "presentation mode"
3634 (fun () -> conf
.presentation
)
3635 (fun v -> setpresentationmode v);
3637 src#
bool "ignore case in searches"
3638 (fun () -> conf
.icase
)
3639 (fun v -> conf
.icase
<- v);
3642 (fun () -> conf
.preload)
3643 (fun v -> conf
.preload <- v);
3645 src#
bool "highlight links"
3646 (fun () -> conf
.hlinks
)
3647 (fun v -> conf
.hlinks
<- v);
3649 src#
bool "under info"
3650 (fun () -> conf
.underinfo
)
3651 (fun v -> conf
.underinfo
<- v);
3653 src#
bool "persistent bookmarks"
3654 (fun () -> conf
.savebmarks
)
3655 (fun v -> conf
.savebmarks
<- v);
3657 src#fitmodel
"fit model"
3658 (fun () -> FMTE.to_string conf
.fitmodel
)
3659 (fun v -> reqlayout conf
.angle
(FMTE.of_int
v));
3661 src#
bool "trim margins"
3662 (fun () -> conf
.trimmargins
)
3663 (fun v -> settrim v conf
.trimfuzz
; fillsrc prevmode prevuioh
);
3665 src#
bool "persistent location"
3666 (fun () -> conf
.jumpback
)
3667 (fun v -> conf
.jumpback
<- v);
3670 src#
int "inter-page space"
3671 (fun () -> conf
.interpagespace
)
3673 conf
.interpagespace
<- n;
3674 docolumns conf
.columns
;
3676 match state
.layout with
3681 state
.maxy <- calcheight
();
3682 let y = getpagey
pageno in
3687 (fun () -> conf
.pagebias
)
3688 (fun v -> conf
.pagebias
<- v);
3690 src#
int "scroll step"
3691 (fun () -> conf
.scrollstep
)
3692 (fun n -> conf
.scrollstep
<- n);
3694 src#
int "horizontal scroll step"
3695 (fun () -> conf
.hscrollstep
)
3696 (fun v -> conf
.hscrollstep
<- v);
3698 src#
int "auto scroll step"
3700 match state
.autoscroll
with
3702 | _ -> conf
.autoscrollstep
)
3704 let n = boundastep state
.winh
n in
3705 if state
.autoscroll
<> None
3706 then state
.autoscroll
<- Some
n;
3707 conf
.autoscrollstep
<- n);
3710 (fun () -> truncate
(conf
.zoom *. 100.))
3711 (fun v -> setzoom ((float v) /. 100.));
3714 (fun () -> conf
.angle
)
3715 (fun v -> reqlayout v conf
.fitmodel
);
3717 src#
int "scroll bar width"
3718 (fun () -> conf
.scrollbw
)
3721 reshape state
.winw state
.winh
;
3724 src#
int "scroll handle height"
3725 (fun () -> conf
.scrollh
)
3726 (fun v -> conf
.scrollh
<- v;);
3728 src#
int "thumbnail width"
3729 (fun () -> conf
.thumbw
)
3731 conf
.thumbw
<- min
4096 v;
3734 leavebirdseye beye
false;
3741 let mode = state
.mode in
3742 src#
string "columns"
3744 match conf
.columns
with
3746 | Cmulti
(multi
, _) -> multicolumns_to_string multi
3747 | Csplit
(count
, _) -> "-" ^ string_of_int count
3750 let n, a, b = multicolumns_of_string
v in
3751 setcolumns mode n a b);
3754 src#caption
"Pixmap cache" 0;
3755 src#int_with_suffix
"size (advisory)"
3756 (fun () -> conf
.memlimit
)
3757 (fun v -> conf
.memlimit
<- v);
3760 (fun () -> Printf.sprintf
"%s bytes, %d tiles"
3761 (string_with_suffix_of_int state
.memused
)
3762 (Hashtbl.length state
.tilemap
)) 1;
3765 src#caption
"Layout" 0;
3766 src#caption2
"Dimension"
3768 Printf.sprintf
"%dx%d (virtual %dx%d)"
3769 state
.winw state
.winh
3774 src#caption2
"Position" (fun () ->
3775 Printf.sprintf
"%dx%d" state
.x state
.y
3778 src#caption2
"Position" (fun () -> describe_location ()) 1
3782 src#
bool ~offset
:0 ~
btos:(fun v -> if v then "(on)" else "(off)")
3783 "Save these parameters as global defaults at exit"
3784 (fun () -> conf
.bedefault
)
3785 (fun v -> conf
.bedefault
<- v)
3789 let btos b = if b then "@Ulguillemet" else "@Urguillemet" in
3790 src#
bool ~offset
:0 ~
btos "Extended parameters"
3791 (fun () -> !showextended)
3792 (fun v -> showextended := v; fillsrc prevmode prevuioh
);
3796 (fun () -> conf
.checkers
)
3797 (fun v -> conf
.checkers
<- v; setcheckers v);
3798 src#
bool "update cursor"
3799 (fun () -> conf
.updatecurs
)
3800 (fun v -> conf
.updatecurs
<- v);
3801 src#
bool "scroll-bar on the left"
3802 (fun () -> conf
.leftscroll
)
3803 (fun v -> conf
.leftscroll
<- v);
3805 (fun () -> conf
.verbose
)
3806 (fun v -> conf
.verbose
<- v);
3807 src#
bool "invert colors"
3808 (fun () -> conf
.invert
)
3809 (fun v -> conf
.invert
<- v);
3811 (fun () -> conf
.maxhfit
)
3812 (fun v -> conf
.maxhfit
<- v);
3814 (fun () -> conf
.pax
!= None
)
3817 then conf
.pax
<- Some
(ref (now
(), 0, 0))
3818 else conf
.pax
<- None
);
3819 src#
string "uri launcher"
3820 (fun () -> conf
.urilauncher
)
3821 (fun v -> conf
.urilauncher
<- v);
3822 src#
string "path launcher"
3823 (fun () -> conf
.pathlauncher
)
3824 (fun v -> conf
.pathlauncher
<- v);
3825 src#
string "tile size"
3826 (fun () -> Printf.sprintf
"%dx%d" conf
.tilew conf
.tileh
)
3829 let w, h = Scanf.sscanf
v "%dx%d" (fun w h -> w, h) in
3830 conf
.tilew
<- max
64 w;
3831 conf
.tileh
<- max
64 h;
3834 state
.text <- Printf.sprintf
"bad tile size `%s': %s"
3837 src#
int "texture count"
3838 (fun () -> conf
.texcount
)
3841 then conf
.texcount
<- v
3842 else impmsg "failed to set texture count please retry later"
3844 src#
int "slice height"
3845 (fun () -> conf
.sliceheight
)
3847 conf
.sliceheight
<- v;
3848 wcmd "sliceh %d" conf
.sliceheight
;
3850 src#
int "anti-aliasing level"
3851 (fun () -> conf
.aalevel
)
3853 conf
.aalevel
<- bound
v 0 8;
3854 state
.anchor <- getanchor
();
3855 opendoc state
.path state
.password;
3857 src#
string "page scroll scaling factor"
3858 (fun () -> string_of_float conf
.pgscale)
3861 let s = float_of_string
v in
3864 state
.text <- Printf.sprintf
3865 "bad page scroll scaling factor `%s': %s" v @@ exntos exn
3868 src#
int "ui font size"
3869 (fun () -> fstate
.fontsize
)
3870 (fun v -> setfontsize (bound
v 5 100));
3871 src#
int "hint font size"
3872 (fun () -> conf
.hfsize
)
3873 (fun v -> conf
.hfsize
<- bound
v 5 100);
3874 colorp "background color"
3875 (fun () -> conf
.bgcolor
)
3876 (fun v -> conf
.bgcolor
<- v);
3877 src#
bool "crop hack"
3878 (fun () -> conf
.crophack
)
3879 (fun v -> conf
.crophack
<- v);
3880 src#
string "trim fuzz"
3881 (fun () -> irect_to_string conf
.trimfuzz
)
3884 conf
.trimfuzz
<- irect_of_string
v;
3886 then settrim true conf
.trimfuzz
;
3888 state
.text <- Printf.sprintf
"bad irect `%s': %s" v @@ exntos exn
3890 src#
string "throttle"
3892 match conf
.maxwait
with
3893 | None
-> "show place holder if page is not ready"
3896 then "wait for page to fully render"
3898 "wait " ^ string_of_float
time
3899 ^
" seconds before showing placeholder"
3903 let f = float_of_string
v in
3905 then conf
.maxwait
<- None
3906 else conf
.maxwait
<- Some
f
3908 state
.text <- Printf.sprintf
"bad time `%s': %s" v @@ exntos exn
3910 src#
string "ghyll scroll"
3912 match conf
.ghyllscroll
with
3914 | Some nab
-> ghyllscroll_to_string nab
3917 try conf
.ghyllscroll
<- ghyllscroll_of_string
v
3920 state
.text <- Printf.sprintf
"bad ghyll `%s': %s" v msg
3922 state
.text <- Printf.sprintf
"bad ghyll `%s': %s" v @@ exntos exn
3924 src#
string "selection command"
3925 (fun () -> conf
.selcmd
)
3926 (fun v -> conf
.selcmd
<- v);
3927 src#
string "synctex command"
3928 (fun () -> conf
.stcmd
)
3929 (fun v -> conf
.stcmd
<- v);
3930 src#
string "pax command"
3931 (fun () -> conf
.paxcmd
)
3932 (fun v -> conf
.paxcmd
<- v);
3933 src#
string "ask password command"
3934 (fun () -> conf
.passcmd)
3935 (fun v -> conf
.passcmd <- v);
3936 src#
string "save path command"
3937 (fun () -> conf
.savecmd
)
3938 (fun v -> conf
.savecmd
<- v);
3939 src#colorspace
"color space"
3940 (fun () -> CSTE.to_string conf
.colorspace
)
3942 conf
.colorspace
<- CSTE.of_int
v;
3946 src#paxmark
"pax mark method"
3947 (fun () -> MTE.to_string conf
.paxmark
)
3948 (fun v -> conf
.paxmark
<- MTE.of_int
v);
3952 (fun () -> conf
.usepbo
)
3953 (fun v -> conf
.usepbo
<- v);
3954 src#
bool "mouse wheel scrolls pages"
3955 (fun () -> conf
.wheelbypage
)
3956 (fun v -> conf
.wheelbypage
<- v);
3957 src#
bool "open remote links in a new instance"
3958 (fun () -> conf
.riani
)
3959 (fun v -> conf
.riani
<- v);
3960 src#
bool "edit annotations inline"
3961 (fun () -> conf
.annotinline
)
3962 (fun v -> conf
.annotinline
<- v);
3966 src#caption
"Document" 0;
3967 List.iter
(fun (_, s) -> src#caption
s 1) state
.docinfo
;
3968 src#caption2
"Pages"
3969 (fun () -> string_of_int state
.pagecount
) 1;
3970 src#caption2
"Dimensions"
3971 (fun () -> string_of_int
(List.length state
.pdims
)) 1;
3975 src#caption
"Trimmed margins" 0;
3976 src#caption2
"Dimensions"
3977 (fun () -> string_of_int
(List.length state
.pdims
)) 1;
3981 src#caption
"OpenGL" 0;
3982 src#caption
(Printf.sprintf
"Vendor\t%s" (GlMisc.get_string `vendor
)) 1;
3983 src#caption
(Printf.sprintf
"Renderer\t%s" (GlMisc.get_string `renderer
)) 1;
3986 src#caption
"Location" 0;
3987 if nonemptystr state
.origin
3988 then src#caption
("Orign\t" ^ mbtoutf8 state
.origin
) 1;
3989 src#caption
("Path\t" ^ mbtoutf8 state
.path) 1;
3991 src#reset prevmode prevuioh
;
3996 let prevmode = state
.mode
3997 and prevuioh
= state
.uioh in
3998 fillsrc prevmode prevuioh
;
3999 let source = (src :> lvsource
) in
4000 let modehash = findkeyhash conf
"info" in
4001 state
.uioh <- coe (object (self)
4002 inherit listview ~zebra
:false ~helpmode
:false
4003 ~
source ~trusted
:true ~
modehash as super
4004 val mutable m_prevmemused
= 0
4005 method! infochanged
= function
4007 if m_prevmemused
!= state
.memused
4009 m_prevmemused
<- state
.memused
;
4010 G.postRedisplay "memusedchanged";
4012 | Pdim
-> G.postRedisplay "pdimchanged"
4013 | Docinfo
-> fillsrc prevmode prevuioh
4015 method! key key mask
=
4016 if not
(Wsi.withctrl mask
)
4019 | @left | @kpleft
-> coe (self#updownlevel ~
-1)
4020 | @right
| @kpright
-> coe (self#updownlevel
1)
4021 | _ -> super#
key key mask
4022 else super#
key key mask
4024 G.postRedisplay "info";
4030 inherit lvsourcebase
4031 method getitemcount
= Array.length state
.help
4033 let s, l, _ = state
.help
.(n) in
4036 method exit ~
uioh ~cancel ~
active ~
first ~pan
=
4040 match state
.help
.(active) with
4041 | _, _, Action
f -> Some
(f uioh)
4042 | _, _, Noaction
-> Some
uioh
4051 method hasaction
n =
4052 match state
.help
.(n) with
4053 | _, _, Action
_ -> true
4054 | _, _, Noaction
-> false
4060 let modehash = findkeyhash conf
"help" in
4062 state
.uioh <- coe (new listview
4063 ~zebra
:false ~helpmode
:true
4064 ~
source ~trusted
:true ~
modehash);
4065 G.postRedisplay "help";
4071 inherit lvsourcebase
4072 val mutable m_items
= E.a
4074 method getitemcount
= 1 + Array.length m_items
4079 else m_items
.(n-1), 0
4081 method exit ~
uioh ~cancel ~
active ~
first ~pan
=
4086 then Buffer.clear state
.errmsgs
;
4093 method hasaction
n =
4097 state
.newerrmsgs
<- false;
4098 let l = Str.split newlinere
(Buffer.contents state
.errmsgs
) in
4099 m_items
<- Array.of_list
l
4108 let source = (msgsource :> lvsource
) in
4109 let modehash = findkeyhash conf
"listview" in
4110 state
.uioh <- coe (object
4111 inherit listview ~zebra
:false ~helpmode
:false
4112 ~
source ~trusted
:false ~
modehash as super
4115 then msgsource#reset
;
4118 G.postRedisplay "msgs";
4122 let editor = getenvwithdef
"EDITOR" E.s in
4126 let tmppath = Filename.temp_file
"llpp" "note" in
4129 let oc = open_out
tmppath in
4133 let execstr = editor ^
" " ^
tmppath in
4135 match spawn
execstr [] with
4136 | (exception exn
) ->
4137 impmsg "spawn(%S) failed: %s" execstr @@ exntos exn
;
4140 match Unix.waitpid
[] pid with
4141 | (exception exn
) ->
4142 impmsg "waitpid(%d) failed: %s" pid @@ exntos exn
;
4146 | Unix.WEXITED
0 -> filecontents
tmppath
4148 impmsg "editor process(%s) exited abnormally: %d" execstr n;
4150 | Unix.WSIGNALED
n ->
4151 impmsg "editor process(%s) was killed by signal %d" execstr n;
4153 | Unix.WSTOPPED
n ->
4154 impmsg "editor(%s) process was stopped by signal %d" execstr n;
4157 match Unix.unlink
tmppath with
4158 | (exception exn
) ->
4159 impmsg "failed to ulink %S: %s" tmppath @@ exntos exn
;
4164 let enterannotmode opaque slinkindex
=
4167 inherit lvsourcebase
4168 val mutable m_text
= E.s
4169 val mutable m_items
= E.a
4171 method getitemcount
= Array.length m_items
4174 let label, _func
= m_items
.(n) in
4177 method exit ~
uioh ~cancel ~
active ~
first ~pan
=
4178 ignore
(uioh, first, pan
);
4181 let _label, func
= m_items
.(active) in
4186 method hasaction
n = nonemptystr
@@ fst m_items
.(n)
4189 let rec split accu b i
=
4191 if p = String.length
s
4192 then (String.sub
s b (p-b), unit) :: accu
4194 if (i
> 70 && s.[p] = ' '
) || s.[p] = '
\r'
|| s.[p] = '
\n'
4196 let ss = if i
= 0 then E.s else String.sub
s b i
in
4197 split ((ss, unit)::accu) (p+1) 0
4202 wcmd "freepage %s" (~
> opaque);
4204 Hashtbl.fold (fun key opaque'
accu ->
4205 if opaque'
= opaque'
4206 then key :: accu else accu) state
.pagemap
[]
4208 List.iter
(Hashtbl.remove state
.pagemap
) keys;
4213 delannot
opaque slinkindex
;
4216 let edit inline
() =
4221 modannot
opaque slinkindex
s;
4227 let mode = state
.mode in
4230 ("annotation: ", m_text
, None
, textentry, update, true),
4231 fun _ -> state
.mode <- mode);
4235 let s = getusertext m_text
in
4240 ( "[Copy]", fun () -> selstring m_text
)
4241 :: ("[Delete]", dele)
4242 :: ("[Edit]", edit conf
.annotinline
)
4244 :: split [] 0 0 |> List.rev
|> Array.of_list
4251 let s = getannotcontents
opaque slinkindex
in
4254 let source = (msgsource :> lvsource
) in
4255 let modehash = findkeyhash conf
"listview" in
4256 state
.uioh <- coe (object
4257 inherit listview ~zebra
:false ~helpmode
:false
4258 ~
source ~trusted
:false ~
modehash
4260 G.postRedisplay "enterannotmode";
4263 let gotounder under =
4264 let getpath filename
=
4266 if nonemptystr filename
4268 if Filename.is_relative filename
4270 let dir = Filename.dirname state
.path in
4272 if Filename.is_implicit
dir
4273 then Filename.concat
(Sys.getcwd
()) dir
4276 Filename.concat
dir filename
4280 if Sys.file_exists
path
4285 | Ulinkgoto
(pageno, top) ->
4289 gotopage1 pageno top;
4292 | Ulinkuri
s -> gotouri
s
4294 | Uremote
(filename
, pageno) ->
4295 let path = getpath filename
in
4300 let command = Printf.sprintf
"%s -page %d %S" !selfexec pageno path in
4301 match spawn
command [] with
4303 | (exception exn
) ->
4304 dolog
"failed to execute `%s': %s" command @@ exntos exn
4306 let anchor = getanchor
() in
4307 let ranchor = state
.path, state
.password, anchor, state
.origin
in
4308 state
.origin
<- E.s;
4309 state
.anchor <- (pageno, 0.0, 0.0);
4310 state
.ranchors
<- ranchor :: state
.ranchors
;
4313 else impmsg "cannot find %s" filename
4315 | Uremotedest
(filename
, destname
) ->
4316 let path = getpath filename
in
4321 let command = !selfexec ^
" " ^
path ^
" -dest " ^ destname
in
4322 match spawn
command [] with
4323 | (exception exn
) ->
4324 dolog
"failed to execute `%s': %s" command @@ exntos exn
4327 let anchor = getanchor
() in
4328 let ranchor = state
.path, state
.password, anchor, state
.origin
in
4329 state
.origin
<- E.s;
4330 state
.nameddest
<- destname
;
4331 state
.ranchors
<- ranchor :: state
.ranchors
;
4334 else impmsg "cannot find %s" filename
4336 | Uunexpected
_ | Ulaunch
_ | Unamed
_ | Utext
_ | Unone
-> ()
4337 | Uannotation
(opaque, slinkindex
) -> enterannotmode opaque slinkindex
4340 let gotooutline (_, _, kind
) =
4344 let (pageno, y, _) = anchor in
4346 (if conf
.presentation
then (pageno, y, 1.0) else anchor)
4350 | Ouri
uri -> gotounder (Ulinkuri
uri)
4351 | Olaunch cmd
-> gotounder (Ulaunch cmd
)
4352 | Oremote remote
-> gotounder (Uremote remote
)
4353 | Ohistory hist
-> gotohist hist
4354 | Oremotedest remotedest
-> gotounder (Uremotedest remotedest
)
4357 class outlinesoucebase fetchoutlines
= object (self)
4358 inherit lvsourcebase
4359 val mutable m_items
= E.a
4360 val mutable m_minfo
= E.a
4361 val mutable m_orig_items
= E.a
4362 val mutable m_orig_minfo
= E.a
4363 val mutable m_narrow_patterns
= []
4364 val mutable m_gen
= -1
4366 method getitemcount
= Array.length m_items
4369 let s, n, _ = m_items
.(n) in
4372 method exit ~
(uioh:uioh) ~cancel ~
active ~
(first:int) ~pan
:
4374 ignore
(uioh, first);
4376 if m_narrow_patterns
= []
4377 then m_orig_items
, m_orig_minfo
4378 else m_items
, m_minfo
4385 gotooutline m_items
.(active);
4393 method hasaction
(_:int) = true
4396 if Array.length m_items
!= Array.length m_orig_items
4399 match m_narrow_patterns
with
4401 | many
-> String.concat
"@Uellipsis" (List.rev many
)
4403 "Narrowed to " ^
s ^
" (ctrl-u to restore)"
4407 match m_narrow_patterns
with
4410 | head
:: _ -> "@Uellipsis" ^ head
4412 method narrow
pattern =
4413 match Str.regexp_case_fold
pattern with
4414 | (exception _) -> ()
4416 let rec loop accu minfo n =
4419 m_items
<- Array.of_list
accu;
4420 m_minfo
<- Array.of_list
minfo;
4423 let (s, _, _) as o = m_items
.(n) in
4425 match Str.search_forward re
s 0 with
4426 | (exception Not_found
) -> accu, minfo
4427 | first -> o :: accu, (first, Str.match_end
()) :: minfo
4429 loop accu minfo (n-1)
4431 loop [] [] (Array.length m_items
- 1)
4433 method! getminfo
= m_minfo
4436 m_orig_items
<- fetchoutlines
();
4437 m_minfo
<- m_orig_minfo
;
4438 m_items
<- m_orig_items
4440 method add_narrow_pattern
pattern =
4441 m_narrow_patterns
<- pattern :: m_narrow_patterns
4443 method del_narrow_pattern
=
4444 match m_narrow_patterns
with
4445 | _ :: rest
-> m_narrow_patterns
<- rest
4450 match m_narrow_patterns
with
4451 | pattern :: [] -> self#narrow
pattern; pattern
4453 List.fold_left
(fun accu pattern ->
4454 self#narrow
pattern;
4455 pattern ^
"@Uellipsis" ^
accu) E.s list
4457 method calcactive
(_:anchor) = 0
4459 method reset
anchor items =
4460 if state
.gen
!= m_gen
4462 m_orig_items
<- items;
4464 m_narrow_patterns
<- [];
4466 m_orig_minfo
<- E.a;
4470 if items != m_orig_items
4472 m_orig_items
<- items;
4473 if m_narrow_patterns
== []
4474 then m_items
<- items;
4477 let active = self#calcactive
anchor in
4479 m_first
<- firstof m_first
active
4483 let outlinesource fetchoutlines
=
4485 inherit outlinesoucebase fetchoutlines
4486 method! calcactive
anchor =
4487 let rely = getanchory anchor in
4488 let rec loop n best bestd
=
4489 if n = Array.length m_items
4492 let _, _, kind
= m_items
.(n) in
4495 let orely = getanchory anchor in
4496 let d = abs
(orely - rely) in
4499 else loop (n+1) best bestd
4500 | Onone
| Oremote
_ | Olaunch
_
4501 | Oremotedest
_ | Ouri
_ | Ohistory
_ ->
4502 loop (n+1) best bestd
4508 let enteroutlinemode, enterbookmarkmode
, enterhistmode
=
4509 let mkselector sourcetype
=
4510 let fetchoutlines () =
4511 match sourcetype
with
4512 | `bookmarks
-> Array.of_list state
.bookmarks
4513 | `outlines
-> state
.outlines
4514 | `history
-> genhistoutlines ()
4517 if sourcetype
= `history
4518 then new outlinesoucebase
fetchoutlines
4519 else outlinesource fetchoutlines
4522 let outlines = fetchoutlines () in
4523 if Array.length
outlines = 0
4525 showtext ' ' errmsg
;
4529 Wsi.setcursor
Wsi.CURSOR_INHERIT
;
4530 let anchor = getanchor
() in
4531 source#reset
anchor outlines;
4532 state
.text <- source#greetmsg
;
4534 coe (new outlinelistview ~zebra
:(sourcetype
=`history
) ~
source);
4535 G.postRedisplay "enter selector";
4538 let mkenter sourcetype errmsg
=
4539 let enter = mkselector sourcetype
in
4540 fun () -> enter errmsg
4542 (**)mkenter `
outlines "document has no outline"
4543 , mkenter `bookmarks
"document has no bookmarks (yet)"
4544 , mkenter `history
"history is empty"
4547 let quickbookmark ?title
() =
4548 match state
.layout with
4554 let tm = Unix.localtime
(now
()) in
4556 "Quick (page %d) (bookmarked at %02d/%02d/%d %02d:%02d)"
4560 (tm.Unix.tm_year
+ 1900)
4563 | Some
title -> title
4565 state
.bookmarks
<- (title, 0, Oanchor
(getanchor1
l)) :: state
.bookmarks
4568 let setautoscrollspeed step goingdown
=
4569 let incr = max
1 ((abs step
) / 2) in
4570 let incr = if goingdown
then incr else -incr in
4571 let astep = boundastep state
.winh
(step
+ incr) in
4572 state
.autoscroll
<- Some
astep;
4576 match conf
.columns
with
4578 | Csingle
_ | Cmulti
_ -> state
.x != 0 || conf
.zoom > 1.0
4581 let panbound x = bound
x (-state
.w) (wadjsb () + state
.winw
);;
4583 let existsinrow pageno (columns
, coverA
, coverB
) p =
4584 let last = ((pageno - coverA
) mod columns
) + columns
in
4585 let rec any = function
4588 if l.pageno = coverA
- 1 || l.pageno = state
.pagecount
- coverB
4592 then (if l.pageno = last then false else any rest
)
4600 match state
.layout with
4602 let pageno = page_of_y state
.y in
4603 gotoghyll (getpagey
(pageno+1))
4605 match conf
.columns
with
4607 if conf
.presentation
&& rest
== [] && l.pageh
> l.pagey + l.pagevh
4609 let y = clamp (pgscale state
.winh
) in
4612 let pageno = min
(l.pageno+1) (state
.pagecount
-1) in
4613 gotoghyll (getpagey
pageno)
4614 | Cmulti
((c, _, _) as cl, _) ->
4615 if conf
.presentation
4616 && (existsinrow l.pageno cl
4617 (fun l -> l.pageh
> l.pagey + l.pagevh))
4619 let y = clamp (pgscale state
.winh
) in
4622 let pageno = min
(l.pageno+c) (state
.pagecount
-1) in
4623 gotoghyll (getpagey
pageno)
4625 if l.pageno < state
.pagecount
- 1 || l.pagecol
< n - 1
4627 let pagey, pageh
= getpageyh
l.pageno in
4628 let pagey = pagey + pageh
* l.pagecol
in
4629 let ips = if l.pagecol
= 0 then 0 else conf
.interpagespace
in
4630 gotoghyll (pagey + pageh
+ ips)
4634 match state
.layout with
4636 let pageno = page_of_y state
.y in
4637 gotoghyll (getpagey
(pageno-1))
4639 match conf
.columns
with
4641 if conf
.presentation
&& l.pagey != 0
4643 gotoghyll (clamp (pgscale ~
-(state
.winh
)))
4645 let pageno = max
0 (l.pageno-1) in
4646 gotoghyll (getpagey
pageno)
4647 | Cmulti
((c, _, coverB
) as cl, _) ->
4648 if conf
.presentation
&&
4649 (existsinrow l.pageno cl (fun l -> l.pagey != 0))
4651 gotoghyll (clamp (pgscale ~
-(state
.winh
)))
4654 if l.pageno = state
.pagecount
- coverB
4658 let pageno = max
0 (l.pageno-decr) in
4659 gotoghyll (getpagey
pageno)
4667 let pageno = max
0 (l.pageno-1) in
4668 let pagey, pageh
= getpageyh
pageno in
4671 let pagey, pageh
= getpageyh
l.pageno in
4672 pagey + pageh
* (l.pagecol
-1) - conf
.interpagespace
4678 if emptystr conf
.savecmd
4679 then error
"don't know where to save modified document"
4681 let savecmd = Str.global_replace percentsre state
.path conf
.savecmd in
4684 (fun s -> error
"failed to obtain path to the saved copy: %s" s)
4689 let tmp = path ^
".tmp" in
4691 Unix.rename
tmp path;
4694 let viewkeyboard key mask
=
4696 let mode = state
.mode in
4697 state
.mode <- Textentry
(te, fun _ -> state
.mode <- mode);
4700 G.postRedisplay "view:enttext"
4702 let ctrl = Wsi.withctrl mask
in
4704 if key >= 0xffb0 && key < 0xffb9 then key - 0xffb0 + 48 else key
4710 if hasunsavedchanges
()
4714 if conf
.angle
mod 360 = 0 && not
(isbirdseye state
.mode)
4716 state
.mode <- LinkNav
(Ltgendir
0);
4719 else impmsg "keyboard link navigation does not work under rotation"
4722 begin match state
.mstate
with
4725 G.postRedisplay "kill rect";
4728 | Mscrolly
| Mscrollx
4731 begin match state
.mode with
4734 G.postRedisplay "esc leave linknav"
4738 match state
.ranchors
with
4740 | (path, password, anchor, origin
) :: rest
->
4741 state
.ranchors
<- rest
;
4742 state
.anchor <- anchor;
4743 state
.origin
<- origin
;
4744 state
.nameddest
<- E.s;
4745 opendoc path password
4750 gotoghyll (getnav ~
-1)
4761 Hashtbl.iter
(fun _ opaque ->
4763 Hashtbl.clear state
.prects
) state
.pagemap
;
4764 G.postRedisplay "dehighlight";
4766 | @slash
| @question
->
4767 let ondone isforw
s =
4768 cbput state
.hists
.pat
s;
4769 state
.searchpattern
<- s;
4772 let s = String.make
1 (Char.chr
key) in
4773 enttext (s, E.s, Some
(onhist state
.hists
.pat
),
4774 textentry, ondone (key = @slash
), true)
4776 | @plus
| @kpplus
| @equals
when ctrl ->
4777 let incr = if conf
.zoom +. 0.01 > 0.1 then 0.1 else 0.01 in
4778 setzoom (conf
.zoom +. incr)
4780 | @plus
| @kpplus
->
4783 try int_of_string
s with exc
->
4784 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exc
;
4790 state
.text <- "page bias is now " ^ string_of_int
n;
4793 enttext ("page bias: ", E.s, None
, intentry, ondone, true)
4795 | @minus
| @kpminus
when ctrl ->
4796 let decr = if conf
.zoom -. 0.1 < 0.1 then 0.01 else 0.1 in
4797 setzoom (max
0.01 (conf
.zoom -. decr))
4799 | @minus
| @kpminus
->
4800 let ondone msg
= state
.text <- msg
in
4802 "option [acfhilpstvxACFPRSZTISM]: ", E.s, None
,
4803 optentry state
.mode, ondone, true
4814 | (@1 | @2) when ctrl && conf
.fitmodel
!= FitPage
-> (* ctrl-1/2 *)
4816 match conf
.columns
with
4817 | Csingle
_ | Cmulti
_ -> 1
4818 | Csplit
(n, _) -> n
4820 let h = state
.winh
-
4821 conf
.interpagespace
lsl (if conf
.presentation
then 1 else 0)
4823 let zoom = zoomforh state
.winw
h (vscrollw ()) cols in
4824 if zoom > 0.0 && (key = @2 || zoom < 1.0)
4829 match conf
.fitmodel
with
4830 | FitWidth
-> FitProportional
4831 | FitProportional
-> FitPage
4832 | FitPage
-> FitWidth
4834 state
.text <- "fit model: " ^
FMTE.to_string
fm;
4835 reqlayout conf
.angle
fm
4837 | @4 when ctrl -> (* ctrl-4 *)
4838 let zoom = getmaxw
() /. float state
.winw
in
4839 if zoom > 0.0 then setzoom zoom
4847 | (48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57)
4848 when not
ctrl -> (* 0..9 *)
4851 try int_of_string
s with exc
->
4852 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exc
;
4858 cbput state
.hists
.pag
(string_of_int
n);
4859 gotopage1 (n + conf
.pagebias
- 1) 0;
4862 let pageentry text key =
4863 match Char.unsafe_chr
key with
4864 | '
g'
-> TEdone
text
4865 | _ -> intentry text key
4867 let text = String.make
1 (Char.chr
key) in
4868 enttext (":", text, Some
(onhist state
.hists
.pag
),
4869 pageentry, ondone, true)
4872 conf
.scrollb
<- if conf
.scrollb
= 0 then (scrollbvv
lor scrollbhv
) else 0;
4873 reshape state
.winw state
.winh
;
4876 state
.bzoom
<- not state
.bzoom
;
4878 showtext ' '
("block zoom " ^
if state
.bzoom
then "on" else "off")
4881 conf
.hlinks
<- not conf
.hlinks
;
4882 state
.text <- "highlightlinks " ^
if conf
.hlinks
then "on" else "off";
4883 G.postRedisplay "toggle highlightlinks";
4886 if conf
.angle
mod 360 = 0
4888 state
.glinks
<- true;
4889 let mode = state
.mode in
4892 (":", E.s, None
, linknentry, linknact gotounder, false),
4894 state
.glinks
<- false;
4898 G.postRedisplay "view:linkent(F)"
4900 else impmsg "hint mode does not work under rotation"
4903 state
.glinks
<- true;
4904 let mode = state
.mode in
4905 state
.mode <- Textentry
(
4907 ":", E.s, None
, linknentry, linknact (fun under ->
4908 selstring (undertext under);
4912 state
.glinks
<- false;
4916 G.postRedisplay "view:linkent"
4919 begin match state
.autoscroll
with
4921 conf
.autoscrollstep
<- step
;
4922 state
.autoscroll
<- None
4924 if conf
.autoscrollstep
= 0
4925 then state
.autoscroll
<- Some
1
4926 else state
.autoscroll
<- Some conf
.autoscrollstep
4930 launchpath () (* XXX where do error messages go? *)
4933 setpresentationmode (not conf
.presentation
);
4934 showtext ' '
("presentation mode " ^
4935 if conf
.presentation
then "on" else "off");
4938 if List.mem
Wsi.Fullscreen state
.winstate
4939 then Wsi.reshape conf
.cwinw conf
.cwinh
4940 else Wsi.fullscreen
()
4943 search state
.searchpattern
false
4946 search state
.searchpattern
true
4949 begin match state
.layout with
4952 gotoghyll (getpagey
l.pageno)
4958 | @delete
| @kpdelete
-> (* delete *)
4962 showtext ' '
(describe_location ());
4965 begin match state
.layout with
4968 Wsi.reshape (l.pagew
+ vscrollw ()) l.pageh
;
4973 enterbookmarkmode
()
4981 | @e when Buffer.length state
.errmsgs
> 0 ->
4986 match state
.layout with
4991 (s, 0, Oanchor
(getanchor1
l)) :: state
.bookmarks
4994 enttext ("bookmark: ", E.s, None
, textentry, ondone, true)
4998 showtext ' '
"Quick bookmark added";
5001 begin match state
.layout with
5003 let rect = getpdimrect
l.pagedimno
in
5007 (truncate
(1.8 *. (rect.(1) -. rect.(0))),
5008 truncate
(1.2 *. (rect.(3) -. rect.(0))))
5010 (truncate
(rect.(1) -. rect.(0)),
5011 truncate
(rect.(3) -. rect.(0)))
5013 let w = truncate
((float w)*.conf
.zoom)
5014 and h = truncate
((float h)*.conf
.zoom) in
5017 state
.anchor <- getanchor
();
5018 Wsi.reshape (w + vscrollw ()) (h + conf
.interpagespace
)
5020 G.postRedisplay "z";
5025 | @x -> state
.roam
()
5028 reqlayout (conf
.angle
+
5029 (if key = @Gt
then 30 else -30)) conf
.fitmodel
5033 bound
(conf
.colorscale
+. (if key = 93 then 0.1 else -0.1)) 0.0 1.0
5035 G.postRedisplay "brightness";
5037 | @c when state
.mode = View
->
5042 let m = (wadjsb () + state
.winw
- state
.w) / 2 in
5044 gotoy_and_clear_text state
.y
5048 match state
.prevcolumns
with
5049 | None
-> (1, 0, 0), 1.0
5050 | Some
(columns
, z
) ->
5053 | Csplit
(c, _) -> -c, 0, 0
5054 | Cmulti
((c, a, b), _) -> c, a, b
5055 | Csingle
_ -> 1, 0, 0
5059 setcolumns View
c a b;
5062 | @down
| @up
when ctrl && Wsi.withshift mask
->
5063 let zoom, x = state
.prevzoom
in
5067 | @k
| @up
| @kpup
->
5068 begin match state
.autoscroll
with
5070 begin match state
.mode with
5071 | Birdseye beye
-> upbirdseye 1 beye
5076 then gotoy_and_clear_text (clamp ~
-(state
.winh
/2))
5078 if not
(Wsi.withshift mask
) && conf
.presentation
5080 else gotoghyll1 true (clamp (-conf
.scrollstep
))
5084 setautoscrollspeed n false
5087 | @j
| @down
| @kpdown
->
5088 begin match state
.autoscroll
with
5090 begin match state
.mode with
5091 | Birdseye beye
-> downbirdseye 1 beye
5096 then gotoy_and_clear_text (clamp (state
.winh
/2))
5098 if not
(Wsi.withshift mask
) && conf
.presentation
5100 else gotoghyll1 true (clamp (conf
.scrollstep
))
5104 setautoscrollspeed n true
5107 | @left | @right
| @kpleft
| @kpright
when not
(Wsi.withalt mask
) ->
5113 else conf
.hscrollstep
5115 let dx = if key = @left || key = @kpleft
then dx else -dx in
5116 state
.x <- panbound (state
.x + dx);
5117 gotoy_and_clear_text state
.y
5120 G.postRedisplay "left/right"
5123 | @prior
| @kpprior
->
5127 match state
.layout with
5129 | l :: _ -> state
.y - l.pagey
5131 clamp (pgscale (-state
.winh
))
5135 | @next | @kpnext
->
5139 match List.rev state
.layout with
5141 | l :: _ -> getpagey
l.pageno
5143 clamp (pgscale state
.winh
)
5147 | @g | @home
| @kphome
->
5150 | @G
| @jend
| @kpend
->
5152 gotoghyll (clamp state
.maxy)
5154 | @right
| @kpright
when Wsi.withalt mask
->
5155 gotoghyll (getnav 1)
5156 | @left | @kpleft
when Wsi.withalt mask
->
5157 gotoghyll (getnav ~
-1)
5162 | @v when conf
.debug
->
5165 match getopaque l.pageno with
5168 let x0, y0, x1, y1 = pagebbox
opaque in
5169 let a,b = float x0, float y0 in
5170 let c,d = float x1, float y0 in
5171 let e,f = float x1, float y1 in
5172 let h,j
= float x0, float y1 in
5173 let rect = (a,b,c,d,e,f,h,j
) in
5175 let color = (0.0, 0.0, 1.0 /. (l.pageno mod 3 |> float), 0.5) in
5176 state
.rects
<- (l.pageno, color, rect) :: state
.rects
;
5178 G.postRedisplay "v";
5181 let mode = state
.mode in
5182 let cmd = ref E.s in
5183 let onleave = function
5184 | Cancel
-> state
.mode <- mode
5187 match getopaque l.pageno with
5188 | Some
opaque -> pipesel opaque !cmd
5189 | None
-> ()) state
.layout;
5193 cbput state
.hists
.sel
s;
5197 "| ", !cmd, Some
(onhist state
.hists
.sel
), textentry, ondone, true
5199 G.postRedisplay "|";
5200 state
.mode <- Textentry
(te, onleave);
5203 vlog "huh? %s" (Wsi.keyname
key)
5206 let linknavkeyboard key mask
linknav =
5207 let getpage pageno =
5208 let rec loop = function
5210 | l :: _ when l.pageno = pageno -> Some
l
5211 | _ :: rest
-> loop rest
5212 in loop state
.layout
5214 let doexact (pageno, n) =
5215 match getopaque pageno, getpage pageno with
5216 | Some
opaque, Some
l ->
5217 if key = @enter || key = @kpenter
5219 let under = getlink
opaque n in
5220 G.postRedisplay "link gotounder";
5227 Some
(findlink
opaque LDfirst
), -1
5230 Some
(findlink
opaque LDlast
), 1
5233 Some
(findlink
opaque (LDleft
n)), -1
5236 Some
(findlink
opaque (LDright
n)), 1
5239 Some
(findlink
opaque (LDup
n)), -1
5242 Some
(findlink
opaque (LDdown
n)), 1
5247 begin match findpwl
l.pageno dir with
5251 state
.mode <- LinkNav
(Ltgendir
dir);
5252 let y, h = getpageyh
pageno in
5255 then y + h - state
.winh
5260 begin match getopaque pageno, getpage pageno with
5261 | Some
opaque, Some
_ ->
5263 let ld = if dir > 0 then LDfirst
else LDlast
in
5266 begin match link with
5268 showlinktype (getlink
opaque m);
5269 state
.mode <- LinkNav
(Ltexact
(pageno, m));
5270 G.postRedisplay "linknav jpage";
5271 | Lnotfound
-> notfound dir
5277 begin match opt with
5278 | Some Lnotfound
-> pwl l dir;
5279 | Some
(Lfound
m) ->
5283 let _, y0, _, y1 = getlinkrect
opaque m in
5285 then gotopage1 l.pageno y0
5287 let d = fstate
.fontsize
+ 1 in
5288 if y1 - l.pagey > l.pagevh - d
5289 then gotopage1 l.pageno (y1 - state
.winh
- hscrollh () + d)
5290 else G.postRedisplay "linknav";
5292 showlinktype (getlink
opaque m);
5293 state
.mode <- LinkNav
(Ltexact
(l.pageno, m));
5296 | None
-> viewkeyboard key mask
5298 | _ -> viewkeyboard key mask
5303 G.postRedisplay "leave linknav"
5307 | Ltgendir
_ | Ltnotready
_ -> viewkeyboard key mask
5308 | Ltexact exact
-> doexact exact
5311 let keyboard key mask
=
5312 if (key = @g && Wsi.withctrl mask
) && not
(istextentry state
.mode)
5313 then wcmd "interrupt"
5314 else state
.uioh <- state
.uioh#
key key mask
5317 let birdseyekeyboard key mask
5318 ((oconf
, leftx
, pageno, hooverpageno
, anchor) as beye
) =
5320 match conf
.columns
with
5322 | Cmulti
((c, _, _), _) -> c
5323 | Csplit
_ -> failwith
"bird's eye split mode"
5325 let pgh layout = List.fold_left
5326 (fun m l -> max
l.pageh
m) state
.winh
layout in
5328 | @l when Wsi.withctrl mask
->
5329 let y, h = getpageyh
pageno in
5330 let top = (state
.winh
- h) / 2 in
5331 gotoy (max
0 (y - top))
5332 | @enter | @kpenter
-> leavebirdseye beye
false
5333 | @escape
-> leavebirdseye beye
true
5334 | @up
-> upbirdseye incr beye
5335 | @down
-> downbirdseye incr beye
5336 | @left -> upbirdseye 1 beye
5337 | @right
-> downbirdseye 1 beye
5340 begin match state
.layout with
5344 state
.mode <- Birdseye
(
5345 oconf
, leftx
, l.pageno, hooverpageno
, anchor
5347 gotopage1 l.pageno 0;
5350 let layout = layout state
.x (state
.y-state
.winh
)
5352 (pgh state
.layout) in
5354 | [] -> gotoy (clamp (-state
.winh
))
5356 state
.mode <- Birdseye
(
5357 oconf
, leftx
, l.pageno, hooverpageno
, anchor
5359 gotopage1 l.pageno 0
5362 | [] -> gotoy (clamp (-state
.winh
))
5366 begin match List.rev state
.layout with
5368 let layout = layout state
.x
5369 (state
.y + (pgh state
.layout))
5370 state
.winw state
.winh
in
5371 begin match layout with
5373 let incr = l.pageh
- l.pagevh in
5378 oconf
, leftx
, state
.pagecount
- 1, hooverpageno
, anchor
5380 G.postRedisplay "birdseye pagedown";
5382 else gotoy (clamp (incr + conf
.interpagespace
*2));
5386 Birdseye
(oconf
, leftx
, l.pageno, hooverpageno
, anchor);
5387 gotopage1 l.pageno 0;
5390 | [] -> gotoy (clamp state
.winh
)
5394 state
.mode <- Birdseye
(oconf
, leftx
, 0, hooverpageno
, anchor);
5398 let pageno = state
.pagecount
- 1 in
5399 state
.mode <- Birdseye
(oconf
, leftx
, pageno, hooverpageno
, anchor);
5400 if not
(pagevisible state
.layout pageno)
5403 match List.rev state
.pdims
with
5405 | (_, _, h, _) :: _ -> h
5407 gotoy (max
0 (getpagey
pageno - (state
.winh
- h - conf
.interpagespace
)))
5408 else G.postRedisplay "birdseye end";
5410 | _ -> viewkeyboard key mask
5415 match state
.mode with
5416 | Textentry
_ -> scalecolor 0.4
5418 | View
-> scalecolor 1.0
5419 | Birdseye
(_, _, pageno, hooverpageno
, _) ->
5420 if l.pageno = hooverpageno
5423 if l.pageno = pageno
5425 let c = scalecolor 1.0 in
5427 GlDraw.line_width
3.0;
5428 let dispx = xadjsb () + l.pagedispx in
5430 (float (dispx-1)) (float (l.pagedispy-1))
5431 (float (dispx+l.pagevw+1))
5432 (float (l.pagedispy+l.pagevh+1))
5434 GlDraw.line_width
1.0;
5443 let postdrawpage l linkindexbase
=
5444 match getopaque l.pageno with
5446 if tileready l l.pagex
l.pagey
5448 let x = l.pagedispx - l.pagex
+ xadjsb ()
5449 and y = l.pagedispy - l.pagey in
5451 match conf
.columns
with
5452 | Csingle
_ | Cmulti
_ ->
5453 (if conf
.hlinks
then 1 else 0)
5455 && not
(isbirdseye state
.mode) then 2 else 0)
5459 match state
.mode with
5460 | Textentry
((_, s, _, _, _, _), _) when state
.glinks
-> s
5466 Hashtbl.find_all state
.prects
l.pageno |>
5467 List.iter
(fun vals
-> drawprect
opaque x y vals
);
5468 postprocess
opaque hlmask x y (linkindexbase
, s, conf
.hfsize
);
5473 let scrollindicator () =
5474 let sbw, ph
, sh = state
.uioh#
scrollph in
5475 let sbh, pw, sw = state
.uioh#scrollpw
in
5480 else ((state
.winw
- sbw), state
.winw
, 0)
5483 GlDraw.color (0.64, 0.64, 0.64);
5484 filledrect (float x0) 0. (float x1) (float state
.winh
);
5486 (float hx0
) (float (state
.winh
- sbh))
5487 (float (hx0
+ wadjsb () + state
.winw
)) (float state
.winh
)
5489 GlDraw.color (0.0, 0.0, 0.0);
5491 filledrect (float x0) ph
(float x1) (ph
+. sh);
5492 let pw = pw +. float hx0
in
5493 filledrect pw (float (state
.winh
- sbh)) (pw +. sw) (float state
.winh
);
5497 match state
.mstate
with
5498 | Mnone
| Mscrolly
| Mscrollx
| Mpan
_ | Mzoom
_ | Mzoomrect
_ ->
5501 | Msel
((x0, y0), (x1, y1)) ->
5502 let identify opaque l px py = Some
(opaque, l.pageno, px, py) in
5503 let o0,n0
,px0
,py0
= onppundermouse identify x0 y0 (~
< E.s, -1, 0, 0) in
5504 let _o1,n1
,px1
,py1
= onppundermouse identify x1 y1 (~
< E.s, -1, 0, 0) in
5505 if n0
!= -1 && n0
= n1
then seltext
o0 (px0
, py0
, px1
, py1
);
5508 let showrects = function [] -> () | rects
->
5510 GlDraw.color (0.0, 0.0, 1.0) ~
alpha:0.5;
5511 GlFunc.blend_func ~
src:`src_alpha ~dst
:`one_minus_src_alpha
;
5513 (fun (pageno, c, (x0, y0, x1, y1, x2
, y2
, x3
, y3
)) ->
5515 if l.pageno = pageno
5517 let dx = float (l.pagedispx - l.pagex
) in
5518 let dy = float (l.pagedispy - l.pagey) in
5519 let r, g, b, alpha = c in
5520 GlDraw.color (r, g, b) ~
alpha;
5521 Raw.sets_float state
.vraw ~
pos:0
5526 GlArray.vertex `two state
.vraw
;
5527 GlArray.draw_arrays `triangle_strip ~
first:0 ~count
:4;
5536 GlClear.color (scalecolor2 conf
.bgcolor
);
5537 GlClear.clear
[`
color];
5538 List.iter
drawpage state
.layout;
5540 match state
.mode with
5541 | LinkNav
(Ltexact
(pageno, linkno
)) ->
5542 begin match getopaque pageno with
5544 let dx = xadjsb () in
5545 let x0, y0, x1, y1 = getlinkrect
opaque linkno
in
5546 let x0 = x0 + dx and x1 = x1 + dx in
5547 let color = (0.0, 0.0, 0.5, 0.5) in
5554 | None
-> state
.rects
5556 | LinkNav
(Ltgendir
_) | LinkNav
(Ltnotready
_)
5559 | View
-> state
.rects
5562 let rec postloop linkindexbase
= function
5564 let linkindexbase = linkindexbase + postdrawpage l linkindexbase in
5565 postloop linkindexbase rest
5569 postloop 0 state
.layout;
5571 begin match state
.mstate
with
5572 | Mzoomrect
((x0, y0), (x1, y1)) ->
5574 GlDraw.color (0.3, 0.3, 0.3) ~
alpha:0.5;
5575 GlFunc.blend_func ~
src:`src_alpha ~dst
:`one_minus_src_alpha
;
5576 filledrect (float x0) (float y0) (float x1) (float y1);
5580 | Mscrolly
| Mscrollx
5589 let zoomrect x y x1 y1 =
5592 and y0 = min
y y1 in
5593 gotoy (state
.y + y0);
5594 state
.anchor <- getanchor
();
5595 let zoom = (float state
.w) /. float (x1 - x0) in
5598 let adjw = wadjsb () + state
.winw
in
5600 then (adjw - state
.w) / 2
5603 match conf
.fitmodel
with
5604 | FitWidth
| FitProportional
-> simple ()
5606 match conf
.columns
with
5608 onppundermouse (fun _ l _ _ -> Some
l.pagedispx) x0 y0 x0
5609 | Cmulti
_ | Csingle
_ -> simple ()
5611 state
.x <- (state
.x + margin) - x0;
5616 let annot inline
x y =
5617 match unproject x y with
5618 | Some
(opaque, n, ux
, uy
) ->
5620 addannot
opaque ux uy
text;
5621 wcmd "freepage %s" (~
> opaque);
5622 Hashtbl.remove state
.pagemap
(n, state
.gen
);
5628 let ondone s = add s in
5629 let mode = state
.mode in
5630 state
.mode <- Textentry
(
5631 ("annotation: ", E.s, None
, textentry, ondone, true),
5632 fun _ -> state
.mode <- mode);
5635 G.postRedisplay "annot"
5637 add @@ getusertext E.s
5642 let g opaque l px py =
5643 match rectofblock
opaque px py with
5645 let x0 = a.(0) -. 20. in
5646 let x1 = a.(1) +. 20. in
5647 let y0 = a.(2) -. 20. in
5648 let zoom = (float state
.w) /. (x1 -. x0) in
5649 let pagey = getpagey
l.pageno in
5650 gotoy_and_clear_text (pagey + truncate
y0);
5651 state
.anchor <- getanchor
();
5652 let margin = (state
.w - l.pagew
)/2 in
5653 state
.x <- -truncate
x0 - margin;
5658 match conf
.columns
with
5660 impmsg "block zooming does not work properly in split columns mode"
5661 | Cmulti
_ | Csingle
_ -> onppundermouse g x y ()
5665 let winw = wadjsb () + state
.winw - 1 in
5666 let s = float x /. float winw in
5667 let destx = truncate
(float (state
.w + winw) *. s) in
5668 state
.x <- winw - destx;
5669 gotoy_and_clear_text state
.y;
5670 state
.mstate
<- Mscrollx
;
5674 let s = float y /. float state
.winh
in
5675 let desty = truncate
(float (state
.maxy - state
.winh
) *. s) in
5676 gotoy_and_clear_text desty;
5677 state
.mstate
<- Mscrolly
;
5680 let viewmulticlick clicks
x y mask
=
5681 let g opaque l px py =
5689 if markunder
opaque px py mark
5693 match getopaque l.pageno with
5695 | Some
opaque -> pipesel opaque cmd
5697 state
.roam
<- (fun () -> dopipe conf
.paxcmd
);
5698 if not
(Wsi.withctrl mask
) then dopipe conf
.selcmd
;
5703 G.postRedisplay "viewmulticlick";
5704 onppundermouse g x y (fun () -> impmsg "nothing to select") ();
5708 match conf
.columns
with
5710 | Csingle
_ | Cmulti
_ -> conf
.angle
mod 360 = 0
5713 let viewmouse button down
x y mask
=
5715 | n when (n == 4 || n == 5) && not down
->
5716 if Wsi.withctrl mask
5718 match state
.mstate
with
5719 | Mzoom
(oldn
, i
) ->
5727 if conf
.zoom +. 0.01 > 0.1 then 0.1 else 0.01
5729 if conf
.zoom -. 0.1 < 0.1 then -0.01 else -0.1
5731 let zoom = conf
.zoom -. incr in
5733 state
.mstate
<- Mzoom
(n, 0);
5735 state
.mstate
<- Mzoom
(n, i
+1);
5737 else state
.mstate
<- Mzoom
(n, 0)
5741 | Mscrolly
| Mscrollx
5743 | Mnone
-> state
.mstate
<- Mzoom
(n, 0)
5746 match state
.autoscroll
with
5747 | Some step
-> setautoscrollspeed step
(n=4)
5749 if conf
.wheelbypage
|| conf
.presentation
5758 then -conf
.scrollstep
5759 else conf
.scrollstep
5761 let incr = incr * 2 in
5762 let y = clamp incr in
5763 gotoy_and_clear_text y
5766 | n when (n = 6 || n = 7) && not down
&& canpan () ->
5768 panbound (state
.x + (if n = 7 then -2 else 2) * conf
.hscrollstep
);
5769 gotoy_and_clear_text state
.y
5771 | 1 when Wsi.withshift mask
->
5772 state
.mstate
<- Mnone
;
5775 match unproject x y with
5777 | Some
(_, pageno, ux
, uy
) ->
5778 let cmd = Printf.sprintf
5780 conf
.stcmd state
.path pageno ux uy
5782 match spawn
cmd [] with
5783 | (exception exn
) ->
5784 impmsg "execution of synctex command(%S) failed: %S"
5785 conf
.stcmd
@@ exntos exn
5789 | 1 when Wsi.withctrl mask
->
5792 Wsi.setcursor
Wsi.CURSOR_FLEUR
;
5793 state
.mstate
<- Mpan
(x, y)
5796 state
.mstate
<- Mnone
5801 if Wsi.withshift mask
5803 annot conf
.annotinline
x y;
5804 G.postRedisplay "addannot"
5808 Wsi.setcursor
Wsi.CURSOR_CYCLE
;
5809 state
.mstate
<- Mzoomrect
(p, p)
5812 match state
.mstate
with
5813 | Mzoomrect
((x0, y0), _) ->
5814 if abs
(x-x0) > 10 && abs
(y - y0) > 10
5815 then zoomrect x0 y0 x y
5818 G.postRedisplay "kill accidental zoom rect";
5822 | Mscrolly
| Mscrollx
5828 | 1 when vscrollhit x ->
5831 let _, position, sh = state
.uioh#
scrollph in
5832 if y > truncate
position && y < truncate
(position +. sh)
5833 then state
.mstate
<- Mscrolly
5836 state
.mstate
<- Mnone
5838 | 1 when y > state
.winh
- hscrollh () ->
5841 let _, position, sw = state
.uioh#scrollpw
in
5842 if x > truncate
position && x < truncate
(position +. sw)
5843 then state
.mstate
<- Mscrollx
5846 state
.mstate
<- Mnone
5848 | 1 when state
.bzoom
-> if not down
then zoomblock x y
5851 let dest = if down
then getunder x y else Unone
in
5852 begin match dest with
5855 | Uremote
_ | Uremotedest
_
5856 | Uunexpected
_ | Ulaunch
_ | Unamed
_ ->
5859 | Unone
when down
->
5860 Wsi.setcursor
Wsi.CURSOR_FLEUR
;
5861 state
.mstate
<- Mpan
(x, y);
5863 | Uannotation
(opaque, slinkindex
) -> enterannotmode opaque slinkindex
5865 | Unone
| Utext
_ ->
5870 state
.mstate
<- Msel
((x, y), (x, y));
5871 G.postRedisplay "mouse select";
5875 match state
.mstate
with
5878 | Mzoom
_ | Mscrollx
| Mscrolly
->
5879 state
.mstate
<- Mnone
5881 | Mzoomrect
((x0, y0), _) ->
5885 Wsi.setcursor
Wsi.CURSOR_INHERIT
;
5886 state
.mstate
<- Mnone
5888 | Msel
((x0, y0), (x1, y1)) ->
5889 let rec loop = function
5893 let a0 = l.pagedispy in
5894 let a1 = a0 + l.pagevh in
5895 let b0 = l.pagedispx in
5896 let b1 = b0 + l.pagevw in
5897 ((y0 >= a0 && y0 <= a1) || (y1 >= a0 && y1 <= a1))
5898 && ((x0 >= b0 && x0 <= b1) || (x1 >= b0 && x1 <= b1))
5902 match getopaque l.pageno with
5905 match Unix.pipe
() with
5906 | (exception exn
) ->
5907 impmsg "cannot create sel pipe: %s" @@
5911 Ne.clo fd
(fun msg
->
5912 dolog
"%s close failed: %s" what msg
)
5915 try spawn
cmd [r, 0; w, -1]
5917 dolog
"cannot execute %S: %s"
5924 G.postRedisplay "copysel";
5926 else clo "Msel pipe/w" w;
5927 clo "Msel pipe/r" r;
5929 dosel conf
.selcmd
();
5930 state
.roam
<- dosel conf
.paxcmd
;
5942 let birdseyemouse button down
x y mask
5943 (conf
, leftx
, _, hooverpageno
, anchor) =
5946 let rec loop = function
5949 if y > l.pagedispy && y < l.pagedispy + l.pagevh
5950 && x > l.pagedispx && x < l.pagedispx + l.pagevw
5952 leavebirdseye (conf
, leftx
, l.pageno, hooverpageno
, anchor) false;
5958 | _ -> viewmouse button down
x y mask
5964 method key key mask
=
5965 begin match state
.mode with
5966 | Textentry
textentry -> textentrykeyboard key mask
textentry
5967 | Birdseye
birdseye -> birdseyekeyboard key mask
birdseye
5968 | View
-> viewkeyboard key mask
5969 | LinkNav
linknav -> linknavkeyboard key mask
linknav
5973 method button button bstate
x y mask
=
5974 begin match state
.mode with
5976 | View
-> viewmouse button bstate
x y mask
5977 | Birdseye beye
-> birdseyemouse button bstate
x y mask beye
5982 method multiclick clicks
x y mask
=
5983 begin match state
.mode with
5985 | View
-> viewmulticlick clicks
x y mask
5992 begin match state
.mode with
5994 | View
| Birdseye
_ | LinkNav
_ ->
5995 match state
.mstate
with
5996 | Mzoom
_ | Mnone
-> ()
6001 state
.mstate
<- Mpan
(x, y);
6003 then state
.x <- panbound (state
.x + dx);
6005 gotoy_and_clear_text y
6008 state
.mstate
<- Msel
(a, (x, y));
6009 G.postRedisplay "motion select";
6012 let y = min state
.winh
(max
0 y) in
6016 let x = min state
.winw (max
0 x) in
6019 | Mzoomrect
(p0
, _) ->
6020 state
.mstate
<- Mzoomrect
(p0
, (x, y));
6021 G.postRedisplay "motion zoomrect";
6025 method pmotion
x y =
6026 begin match state
.mode with
6027 | Birdseye
(conf
, leftx
, pageno, hooverpageno
, anchor) ->
6028 let rec loop = function
6030 if hooverpageno
!= -1
6032 state
.mode <- Birdseye
(conf
, leftx
, pageno, -1, anchor);
6033 G.postRedisplay "pmotion birdseye no hoover";
6036 if y > l.pagedispy && y < l.pagedispy + l.pagevh
6037 && x > l.pagedispx && x < l.pagedispx + l.pagevw
6039 state
.mode <- Birdseye
(conf
, leftx
, pageno, l.pageno, anchor);
6040 G.postRedisplay "pmotion birdseye hoover";
6050 match state
.mstate
with
6051 | Mpan
_ | Msel
_ | Mzoom
_ | Mscrolly
| Mscrollx
| Mzoomrect
_ -> ()
6059 let past, _, _ = !r in
6061 let delta = now -. past in
6064 else r := (now, x, y)
6068 method infochanged
_ = ()
6071 let maxy = state
.maxy - (if conf
.maxhfit
then state
.winh
else 0) in
6074 then 0.0, float state
.winh
6075 else scrollph state
.y maxy
6080 let winw = wadjsb () + state
.winw in
6081 let fwinw = float winw in
6083 let sw = fwinw /. float state
.w in
6084 let sw = fwinw *. sw in
6085 max
sw (float conf
.scrollh
)
6088 let maxx = state
.w + winw in
6089 let x = winw - state
.x in
6090 let percent = float x /. float maxx in
6091 (fwinw -. sw) *. percent
6093 hscrollh (), position, sw
6097 match state
.mode with
6098 | LinkNav
_ -> "links"
6099 | Textentry
_ -> "textentry"
6100 | Birdseye
_ -> "birdseye"
6103 findkeyhash conf
modename
6105 method eformsgs
= true
6106 method alwaysscrolly
= false
6109 let adderrmsg src msg
=
6110 Buffer.add_string state
.errmsgs msg
;
6111 state
.newerrmsgs
<- true;
6115 let adderrfmt src fmt
=
6116 Format.ksprintf
(fun s -> adderrmsg src s) fmt
;
6119 let addrect pageno r g b a x0 y0 x1 y1 =
6120 Hashtbl.add state
.prects
pageno [|r; g; b; a; x0; y0; x1; y1|];
6124 let cl = splitatspace cmds
in
6126 try Scanf.sscanf
s fmt
f
6128 adderrfmt "remote exec"
6129 "error processing '%S': %s\n" cmds
@@ exntos exn
6131 let rectx s pageno (r, g, b, a) x0 y0 x1 y1 =
6132 vlog "%s page %d color (%f %f %f %f) x0,y0,x1,y1 = %f %f %f %f"
6133 s pageno r g b a x0 y0 x1 y1;
6137 let _,w1,h1
,_ = getpagedim
pageno in
6138 let sw = float w1 /. float w
6139 and sh = float h1
/. float h in
6143 and y1s
= y1 *. sh in
6144 let rect = (x0s,y0s
,x1s
,y0s
,x1s
,y1s
,x0s,y1s
) in
6145 let color = (r, g, b, a) in
6146 if conf
.verbose
then debugrect rect;
6147 state
.rects <- (pageno, color, rect) :: state
.rects;
6152 | "reload" :: [] -> reload ()
6153 | "goto" :: args
:: [] ->
6154 scan args
"%u %f %f"
6156 let cmd, _ = state
.geomcmds
in
6158 then gotopagexy !wtmode pageno x y
6161 gotopagexy !wtmode pageno x y;
6164 state
.reprf
<- f state
.reprf
6166 | "goto1" :: args
:: [] -> scan args
"%u %f" gotopage
6167 | "gotor" :: args
:: [] ->
6169 (fun filename
pageno -> gotounder (Uremote
(filename
, pageno)))
6170 | "gotord" :: args
:: [] ->
6172 (fun filename
dest -> gotounder (Uremotedest
(filename
, dest)))
6173 | "rect" :: args
:: [] ->
6174 scan args
"%u %u %f %f %f %f"
6175 (fun pageno c x0 y0 x1 y1 ->
6176 let color = (0.0, 0.0, 1.0 /. float c, 0.5) in
6177 rectx "rect" pageno color x0 y0 x1 y1;
6179 | "prect" :: args
:: [] ->
6180 scan args
"%u %f %f %f %f %f %f %f %f"
6181 (fun pageno r g b alpha x0 y0 x1 y1 ->
6182 addrect pageno r g b alpha x0 y0 x1 y1;
6183 G.postRedisplay "prect"
6185 | "pgoto" :: args
:: [] ->
6186 scan args
"%u %f %f"
6189 match getopaque pageno with
6190 | Some
opaque -> opaque
6193 pgoto optopaque pageno x y;
6194 let rec fixx = function
6197 if l.pageno = pageno
6199 state
.x <- state
.x - l.pagedispx;
6206 match conf
.columns
with
6207 | Csingle
_ | Csplit
_ -> 1
6208 | Cmulti
((n, _, _), _) -> n
6210 layout 0 state
.y (state
.winw * mult) state
.winh
6214 | "activatewin" :: [] -> Wsi.activatewin
()
6215 | "quit" :: [] -> raise Quit
6216 | "clearrects" :: [] ->
6217 Hashtbl.clear state
.prects
;
6218 G.postRedisplay "clearrects"
6220 adderrfmt "remote command"
6221 "error processing remote command: %S\n" cmds
;
6225 let scratch = Bytes.create
80 in
6226 let buf = Buffer.create
80 in
6228 match tempfailureretry
(Unix.read fd
scratch 0) 80 with
6229 | (exception Unix.Unix_error
(Unix.EAGAIN
, _, _)) -> None
6232 if Buffer.length
buf > 0
6234 let s = Buffer.contents
buf in
6242 match Bytes.index_from
scratch ppos '
\n'
with
6243 | pos -> if pos >= n then -1 else pos
6244 | (exception Not_found
) -> -1
6248 Buffer.add_subbytes
buf scratch ppos
(nlpos-ppos
);
6249 let s = Buffer.contents
buf in
6255 Buffer.add_subbytes
buf scratch ppos
(n-ppos
);
6261 let remoteopen path =
6262 try Some
(Unix.openfile
path [Unix.O_NONBLOCK
; Unix.O_RDONLY
] 0o0)
6264 adderrfmt "remoteopen" "error opening %S: %s" path @@ exntos exn
;
6269 let gcconfig = ref E.s in
6270 let trimcachepath = ref E.s in
6271 let rcmdpath = ref E.s in
6272 let pageno = ref None
in
6273 let rootwid = ref 0 in
6274 let openlast = ref false in
6275 let nofc = ref false in
6276 let doreap = ref false in
6277 selfexec := Sys.executable_name
;
6280 [("-p", Arg.String
(fun s -> state
.password <- s),
6281 "<password> Set password");
6285 Config.fontpath
:= s;
6286 selfexec := !selfexec ^
" -f " ^
Filename.quote
s;
6288 "<path> Set path to the user interface font");
6292 selfexec := !selfexec ^
" -c " ^
Filename.quote
s;
6293 Config.confpath
:= s),
6294 "<path> Set path to the configuration file");
6296 ("-last", Arg.Set
openlast, " Open last document");
6298 ("-page", Arg.Int
(fun pageno1
-> pageno := Some
(pageno1
-1)),
6299 "<page-number> Jump to page");
6301 ("-tcf", Arg.String
(fun s -> trimcachepath := s),
6302 "<path> Set path to the trim cache file");
6304 ("-dest", Arg.String
(fun s -> state
.nameddest
<- s),
6305 "<named-destination> Set named destination");
6307 ("-wtmode", Arg.Set
wtmode, " Operate in wt mode");
6308 ("-cxack", Arg.Set
cxack, " Cut corners");
6310 ("-remote", Arg.String
(fun s -> rcmdpath := s),
6311 "<path> Set path to the remote commands source");
6313 ("-origin", Arg.String
(fun s -> state
.origin
<- s),
6314 "<original-path> Set original path");
6316 ("-gc", Arg.Set_string
gcconfig,
6317 "<script-path> Collect garbage with the help of a script");
6319 ("-nofc", Arg.Set
nofc, " Do not use fontconfig");
6321 ("-v", Arg.Unit
(fun () ->
6323 "%s\nconfiguration path: %s\n"
6327 exit
0), " Print version and exit");
6329 ("-embed", Arg.Set_int
rootwid,
6330 "<window-id> Embed into window")
6333 (fun s -> state
.path <- s)
6334 ("Usage: " ^
Sys.argv
.(0) ^
" [options] some.pdf\nOptions:")
6337 then selfexec := !selfexec ^
" -wtmode";
6339 let histmode = emptystr state
.path && not
!openlast in
6341 if not
(Config.load !openlast)
6342 then dolog
"failed to load configuration";
6343 begin match !pageno with
6344 | Some
pageno -> state
.anchor <- (pageno, 0.0, 0.0)
6348 if nonemptystr
!gcconfig
6351 match Unix.socketpair
Unix.PF_UNIX
Unix.SOCK_STREAM
0 with
6352 | (exception exn
) -> error
"socketpair for gc failed: %s" @@ exntos exn
6355 match spawn
!gcconfig [(c, 0); (c, 1); (s, -1)] with
6356 | (exception exn
) -> error
"failed to execute gc script: %s" @@ exntos exn
6358 Ne.clo c @@ (fun s -> error
"failed to close gc fd %s" s);
6363 let wsfd, winw, winh
= Wsi.init
(object (self)
6364 val mutable m_clicks
= 0
6365 val mutable m_click_x
= 0
6366 val mutable m_click_y
= 0
6367 val mutable m_lastclicktime
= infinity
6369 method private cleanup =
6370 state
.roam
<- noroam
;
6371 Hashtbl.iter
(fun _ opaque -> clearmark
opaque) state
.pagemap
6372 method expose
= G.postRedisplay "expose"
6376 | Wsi.Unobscured
-> "unobscured"
6377 | Wsi.PartiallyObscured
-> "partiallyobscured"
6378 | Wsi.FullyObscured
-> "fullyobscured"
6380 vlog "visibility change %s" name
6381 method display = display ()
6382 method map mapped
= vlog "mapped %b" mapped
6383 method reshape w h =
6386 method mouse
b d x y m =
6387 if d && canselect ()
6389 (* http://blogs.msdn.com/b/oldnewthing/archive/2004/10/18/243925.aspx *)
6395 if abs
x - m_click_x
> 10
6396 || abs
y - m_click_y
> 10
6397 || abs_float
(t -. m_lastclicktime
) > 0.3
6399 m_clicks
<- m_clicks
+ 1;
6400 m_lastclicktime
<- t;
6404 G.postRedisplay "cleanup";
6405 state
.uioh <- state
.uioh#button
b d x y m;
6407 else state
.uioh <- state
.uioh#multiclick m_clicks
x y m
6412 m_lastclicktime
<- infinity
;
6413 state
.uioh <- state
.uioh#button
b d x y m
6417 state
.uioh <- state
.uioh#button
b d x y m
6420 state
.mpos
<- (x, y);
6421 state
.uioh <- state
.uioh#motion
x y
6422 method pmotion
x y =
6423 state
.mpos
<- (x, y);
6424 state
.uioh <- state
.uioh#pmotion
x y
6426 let mascm = m land (
6427 Wsi.altmask
+ Wsi.shiftmask
+ Wsi.ctrlmask
+ Wsi.metamask
6430 let x = state
.x and y = state
.y in
6432 if x != state
.x || y != state
.y then self#
cleanup
6434 match state
.keystate
with
6436 let km = k
, mascm in
6439 let modehash = state
.uioh#
modehash in
6440 try Hashtbl.find modehash km
6442 try Hashtbl.find (findkeyhash conf
"global") km
6443 with Not_found
-> KMinsrt
(k
, m)
6445 | KMinsrt
(k
, m) -> keyboard k
m
6446 | KMinsrl
l -> List.iter
(fun (k
, m) -> keyboard k
m) l
6447 | KMmulti
(l, r) -> state
.keystate
<- KSinto
(l, r)
6449 | KSinto
((k'
, m'
) :: [], insrt
) when k'
=k
&& m'
land mascm = m'
->
6450 List.iter
(fun (k
, m) -> keyboard k
m) insrt
;
6451 state
.keystate
<- KSnone
6452 | KSinto
((k'
, m'
) :: keys, insrt
) when k'
=k
&& m'
land mascm = m'
->
6453 state
.keystate
<- KSinto
(keys, insrt
)
6454 | KSinto
_ -> state
.keystate
<- KSnone
6457 state
.mpos
<- (x, y);
6458 state
.uioh <- state
.uioh#pmotion
x y
6459 method leave = state
.mpos
<- (-1, -1)
6460 method winstate wsl
= state
.winstate
<- wsl
6461 method quit
= raise Quit
6462 end) !rootwid conf
.cwinw conf
.cwinh platform
in
6467 List.exists
GlMisc.check_extension
6468 [ "GL_ARB_texture_rectangle"
6469 ; "GL_EXT_texture_recangle"
6470 ; "GL_NV_texture_rectangle" ]
6472 then (dolog
"OpenGL does not suppport rectangular textures"; exit
1);
6475 let r = GlMisc.get_string `renderer
in
6476 let p = "Mesa DRI Intel(" in
6477 let l = String.length
p in
6478 String.length
r > l && String.sub
r 0 l = p
6481 defconf
.sliceheight
<- 1024;
6482 defconf
.texcount
<- 32;
6483 defconf
.usepbo
<- true;
6487 match Unix.socketpair
Unix.PF_UNIX
Unix.SOCK_STREAM
0 with
6488 | (exception exn
) ->
6489 dolog
"socketpair failed: %s" @@ exntos exn
;
6497 setcheckers conf
.checkers
;
6500 conf
.angle
, conf
.fitmodel
, (conf
.trimmargins
, conf
.trimfuzz
),
6501 conf
.texcount
, conf
.sliceheight
, conf
.mustoresize
, conf
.colorspace
,
6502 !Config.fontpath
, !trimcachepath,
6503 GlMisc.check_extension
"GL_ARB_pixel_buffer_object",
6506 List.iter
GlArray.enable
[`texture_coord
; `vertex
];
6508 reshape ~firsttime
:true winw winh
;
6512 Wsi.settitle
"llpp (history)";
6516 state
.text <- "Opening " ^
(mbtoutf8 state
.path);
6517 opendoc state
.path state
.password;
6521 Wsi.setcursor
Wsi.CURSOR_INHERIT
;
6522 Sys.set_signal
Sys.sighup
(Sys.Signal_handle
(fun _ -> reload ()));
6525 match Unix.waitpid
[Unix.WNOHANG
] ~
-1 with
6526 | (exception (Unix.Unix_error
(Unix.ECHILD
, _, _))) -> ()
6527 | (exception exn
) -> dolog
"Unix.waitpid: %s" @@ exntos exn
6529 | _pid
, _status
-> reap ()
6531 Sys.set_signal
Sys.sigchld
(Sys.Signal_handle
(fun _ -> doreap := true));
6535 if nonemptystr
!rcmdpath
6536 then remoteopen !rcmdpath
6541 let rec loop deadline
=
6547 let r = [state
.ss; state
.wsfd] in
6551 | Some fd
-> fd
:: r
6555 state
.redisplay
<- false;
6562 if deadline
= infinity
6564 else max
0.0 (deadline
-. now)
6569 try Unix.select
r [] [] timeout
6570 with Unix.Unix_error
(Unix.EINTR
, _, _) -> [], [], []
6576 if state
.ghyll
== noghyll
6578 match state
.autoscroll
with
6579 | Some step
when step
!= 0 ->
6580 let y = state
.y + step
in
6584 else if y >= state
.maxy then 0 else y
6586 if state
.mode = View
6587 then gotoy_and_clear_text y
6591 else deadline
+. 0.01
6596 let rec checkfds = function
6598 | fd
:: rest
when fd
= state
.ss ->
6599 let cmd = readcmd state
.ss in
6603 | fd
:: rest
when fd
= state
.wsfd ->
6607 | fd
:: rest
when Some fd
= !optrfd ->
6608 begin match remote fd
with
6609 | None
-> optrfd := remoteopen !rcmdpath;
6610 | opt -> optrfd := opt
6615 dolog
"select returned unknown descriptor";
6621 if deadline
= infinity
6625 match state
.autoscroll
with
6626 | Some step
when step
!= 0 -> deadline1
6627 | _ -> if state
.ghyll
== noghyll
then infinity
else deadline1
6635 Config.save leavebirdseye;
6636 if hasunsavedchanges
()