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
833 if state
.currently
!= Idle
838 begin match getopaque l.pageno
with
840 wcmd "page %d %d" l.pageno
l.pagedimno
;
841 state
.currently
<- Loading
(l, state
.gen
);
843 tilepage l.pageno opaque pages
;
848 if nogeomcmds state
.geomcmds
854 if conf
.preload && state
.currently
= Idle
855 then load (preloadlayout state
.x state
.y state
.winw state
.winh
);
858 let layoutready layout =
859 let rec fold all ls
=
862 let seen = ref false in
863 let allvisible = ref true in
864 let foo col row _ _ _ _ _ _
=
866 allvisible := !allvisible &&
867 begin match gettileopaque l col row with
873 fold (!seen && !allvisible) rest
876 let alltilesvisible = fold true layout in
881 let y = bound
y 0 state
.maxy
in
882 let y, layout, proceed
=
883 match conf
.maxwait
with
884 | Some time
when state
.ghyll
== noghyll
->
885 begin match state
.throttle
with
887 let layout = layout state
.x y state
.winw state
.winh
in
888 let ready = layoutready layout in
892 state
.throttle
<- Some
(layout, y, now
());
894 else G.postRedisplay "gotoy showall (None)";
896 | Some
(_
, _
, started
) ->
897 let dt = now
() -. started
in
900 state
.throttle
<- None
;
901 let layout = layout state
.x y state
.winw state
.winh
in
903 G.postRedisplay "maxwait";
910 let layout = layout state
.x y state
.winw state
.winh
in
911 if not
!wtmode || layoutready layout
912 then G.postRedisplay "gotoy ready";
918 state
.layout <- layout;
919 begin match state
.mode
with
922 | Ltexact
(pageno
, linkno
) ->
923 let rec loop = function
925 state
.mode
<- LinkNav
(Ltgendir
0)
926 | l :: _
when l.pageno
= pageno
->
927 begin match getopaque pageno
with
928 | None
-> state
.mode
<- LinkNav
(Ltnotready
(pageno
, 0))
930 let x0, y0, x1, y1 = getlinkrect opaque linkno
in
931 if not
(x0 >= l.pagex
&& x1 <= l.pagex
+ l.pagevw
932 && y0 >= l.pagey && y1 <= l.pagey + l.pagevh)
933 then state
.mode
<- LinkNav
(Ltgendir
0)
935 | _
:: rest
-> loop rest
938 | Ltnotready _
| Ltgendir _
-> ()
944 begin match state
.mode
with
945 | Birdseye
(conf
, leftx
, pageno
, hooverpageno
, anchor
) ->
946 if not
(pagevisible layout pageno
)
948 match state
.layout with
951 state
.mode
<- Birdseye
(
952 conf
, leftx
, l.pageno
, hooverpageno
, anchor
957 | Ltnotready
(_
, dir
)
960 let rec loop = function
963 match getopaque l.pageno
with
964 | None
-> Ltnotready
(l.pageno
, dir
)
969 then LDfirstvisible
(l.pagex
, l.pagey, dir
)
971 if dir
> 0 then LDfirst
else LDlast
977 | Lnotfound
-> loop rest
979 showlinktype (getlink opaque
n);
980 Ltexact
(l.pageno
, n)
984 state
.mode
<- LinkNav
linknav
992 state
.ghyll
<- noghyll
;
995 let mx, my
= state
.mpos
in
1000 let conttiling pageno opaque
=
1001 tilepage pageno opaque
1003 then preloadlayout state
.x state
.y state
.winw state
.winh
1007 let gotoy_and_clear_text y =
1008 if not conf
.verbose
then state
.text <- E.s;
1012 let getanchory (n, top
, dtop
) =
1013 let y, h = getpageyh
n in
1014 if conf
.presentation
1016 let ips = calcips
h in
1017 y + truncate
(top
*.float h -. dtop
*.float ips) + ips;
1019 y + truncate
(top
*.float h -. dtop
*.float conf
.interpagespace
)
1022 let gotoanchor anchor
=
1023 gotoy (getanchory anchor
);
1027 cbput state
.hists
.nav
(getanchor
());
1031 let anchor = cbgetc state
.hists
.nav dir
in
1035 let gotoghyll1 single
y =
1036 let scroll f n a
b =
1037 (* http://devmaster.net/forums/topic/9796-ease-in-ease-out-algorithm/ *)
1039 let s x = 3.0*.x**2.0 -. 2.0*.x**3.0 in
1041 then s (float f /. float a
)
1044 then 1.0 -. s ((float (f-b) /. float (n-b)))
1050 let ins = float a
*. 0.5
1051 and outs
= float (n-b) *. 0.5 in
1053 ins +. outs
+. float ones
1055 let rec set nab
y sy
=
1056 let (_N
, _A
, _B
), y =
1059 let scl = if y > sy
then 2 else -2 in
1060 let _N, _
, _
= nab
in
1061 (_N,0,_N), y+conf
.scrollstep
*scl
1063 let sum = summa
_N _A _B
in
1064 let dy = float (y - sy
) in
1068 then state
.ghyll
<- noghyll
1071 let s = scroll n _N _A _B
in
1072 let y1 = y1 +. ((s *. dy) /. sum) in
1073 gotoy_and_clear_text (truncate
y1);
1074 state
.ghyll
<- gf (n+1) y1;
1078 | Some
y'
when single
-> set nab
y' state
.y
1079 | Some
y'
-> set (_N/2, 1, 1) y' state
.y
1081 gf 0 (float state
.y)
1084 match conf
.ghyllscroll
with
1085 | Some nab
when not conf
.presentation
->
1086 if state
.ghyll
== noghyll
1087 then set nab
y state
.y
1088 else state
.ghyll
(Some
y)
1090 gotoy_and_clear_text y
1093 let gotoghyll = gotoghyll1 false;;
1095 let gotopage n top
=
1096 let y, h = getpageyh
n in
1097 let y = y + (truncate
(top
*. float h)) in
1101 let gotopage1 n top
=
1102 let y = getpagey
n in
1107 let invalidate s f =
1112 match state
.geomcmds
with
1113 | ps
, [] when emptystr ps
->
1115 state
.geomcmds
<- s, [];
1118 state
.geomcmds
<- ps
, [s, f];
1120 | ps
, (s'
, _
) :: rest
when s'
= s ->
1121 state
.geomcmds
<- ps
, ((s, f) :: rest
);
1124 state
.geomcmds
<- ps
, ((s, f) :: cmds
);
1128 Hashtbl.iter
(fun _ opaque
->
1129 wcmd "freepage %s" (~
> opaque
);
1131 Hashtbl.clear state
.pagemap
;
1135 if not
(Queue.is_empty state
.tilelru
)
1137 Queue.iter
(fun (k
, p
, s) ->
1138 wcmd "freetile %s" (~
> p
);
1139 state
.memused
<- state
.memused
- s;
1140 Hashtbl.remove state
.tilemap k
;
1142 state
.uioh#infochanged Memused
;
1143 Queue.clear state
.tilelru
;
1149 let h = truncate
(float h*.conf
.zoom
) in
1150 let d = conf
.interpagespace
lsl (if conf
.presentation
then 1 else 0) in
1154 let opendoc path password
=
1156 state
.password
<- password
;
1157 state
.gen
<- state
.gen
+ 1;
1158 state
.docinfo
<- [];
1159 state
.outlines
<- [||];
1162 setaalevel conf
.aalevel
;
1164 if emptystr state
.origin
1168 Wsi.settitle
("llpp " ^
(mbtoutf8
(Filename.basename
titlepath)));
1169 wcmd "open %d %d %s\000%s\000" (btod
!wtmode) (btod
!cxack) path password
;
1170 invalidate "reqlayout"
1172 wcmd "reqlayout %d %d %d %s\000"
1173 conf
.angle
(FMTE.to_int conf
.fitmodel
)
1174 (stateh state
.winh
) state
.nameddest
1179 state
.anchor <- getanchor
();
1180 opendoc state
.path state
.password
;
1184 let c = c *. conf
.colorscale
in
1188 let scalecolor2 (r
, g, b) =
1189 (r
*. conf
.colorscale
, g *. conf
.colorscale
, b *. conf
.colorscale
);
1192 let docolumns columns
=
1193 let wadj = wadjsb () in
1196 let a = Array.make state
.pagecount
(-1, -1, -1, (-1, -1, -1, -1)) in
1197 let wadj = wadjsb () in
1198 let rec loop pageno
pdimno pdim
y ph pdims
=
1199 if pageno
= state
.pagecount
1202 let pdimno, ((_
, w, h, xoff
) as pdim
), pdims
=
1204 | ((pageno'
, _
, _
, _
) as pdim
) :: rest
when pageno'
= pageno
->
1205 pdimno+1, pdim
, rest
1209 let x = max
0 (((wadj + state
.winw
- w) / 2) - xoff
) in
1211 (if conf
.presentation
1212 then (if pageno
= 0 then calcips
h else calcips ph
+ calcips
h)
1213 else (if pageno
= 0 then 0 else conf
.interpagespace
)
1216 a.(pageno
) <- (pdimno, x, y, pdim
);
1217 loop (pageno
+1) pdimno pdim
(y + h) h pdims
1219 loop 0 ~
-1 (-1,-1,-1,-1) 0 0 state
.pdims
;
1220 conf
.columns
<- Csingle
a;
1222 | Cmulti
((columns
, coverA
, coverB
), _
) ->
1223 let a = Array.make state
.pagecount
(-1, -1, -1, (-1, -1, -1, -1)) in
1224 let rec loop pageno
pdimno pdim
x y rowh pdims
=
1225 let rec fixrow m
= if m
= pageno
then () else
1226 let (pdimno, x, y, ((_
, _
, h, _
) as pdim
)) = a.(m
) in
1229 let y = y + (rowh
- h) / 2 in
1230 a.(m
) <- (pdimno, x, y, pdim
);
1234 if pageno
= state
.pagecount
1235 then fixrow (((pageno
- 1) / columns
) * columns
)
1237 let pdimno, ((_
, w, h, xoff
) as pdim
), pdims
=
1239 | ((pageno'
, _
, _
, _
) as pdim
) :: rest
when pageno'
= pageno
->
1240 pdimno+1, pdim
, rest
1245 if pageno
= coverA
- 1 || pageno
= state
.pagecount
- coverB
1247 let x = (wadj + state
.winw
- w) / 2 in
1249 if conf
.presentation
then calcips
h else conf
.interpagespace
in
1250 x, y + ips + rowh
, h
1253 if (pageno
- coverA
) mod columns
= 0
1255 let x = max
0 (wadj + state
.winw
- state
.w) / 2 in
1257 if conf
.presentation
1259 let ips = calcips
h in
1260 y + (if pageno
= 0 then 0 else calcips rowh
+ ips)
1262 y + (if pageno
= 0 then 0 else conf
.interpagespace
)
1266 else x, y, max rowh
h
1270 if pageno
> 1 && (pageno
- coverA
) mod columns
= 0
1273 if pageno
= columns
&& conf
.presentation
1275 let ips = calcips rowh
in
1276 for i
= 0 to pred columns
1278 let (pdimno, x, y, pdim
) = a.(i
) in
1279 a.(i
) <- (pdimno, x, y+ips, pdim
)
1285 fixrow (pageno
- columns
);
1290 a.(pageno
) <- (pdimno, x, y, pdim
);
1291 let x = x + w + xoff
*2 + conf
.interpagespace
in
1292 loop (pageno
+1) pdimno pdim
x y rowh' pdims
1294 loop 0 ~
-1 (-1,-1,-1,-1) 0 0 0 state
.pdims
;
1295 conf
.columns
<- Cmulti
((columns
, coverA
, coverB
), a);
1298 let a = Array.make
(state
.pagecount
*c) (-1, -1, -1, (-1, -1, -1, -1)) in
1299 let rec loop pageno
pdimno pdim
y pdims
=
1300 if pageno
= state
.pagecount
1303 let pdimno, ((_
, w, h, _
) as pdim
), pdims
=
1305 | ((pageno'
, _
, _
, _
) as pdim
) :: rest
when pageno'
= pageno
->
1306 pdimno+1, pdim
, rest
1311 let rec loop1 n x y =
1312 if n = c then y else (
1313 a.(pageno
*c + n) <- (pdimno, x, y, pdim
);
1314 loop1 (n+1) (x+cw) (y + h + conf
.interpagespace
)
1317 let y = loop1 0 0 y in
1318 loop (pageno
+1) pdimno pdim
y pdims
1320 loop 0 ~
-1 (-1,-1,-1,-1) 0 state
.pdims
;
1321 conf
.columns
<- Csplit
(c, a);
1325 docolumns conf
.columns
;
1326 state
.maxy
<- calcheight
();
1327 if state
.reprf
== noreprf
1329 match state
.mode
with
1330 | Birdseye
(_
, _
, pageno
, _
, _
) ->
1331 let y, h = getpageyh pageno
in
1332 let top = (state
.winh
- h) / 2 in
1333 gotoy (max
0 (y - top))
1337 let y = getanchory state
.anchor in
1338 let y = min
y (state
.maxy
- state
.winw
- hscrollh ()) in
1343 state
.reprf
<- noreprf
;
1347 let reshape ?
(firsttime
=false) w h =
1348 GlDraw.viewport ~
x:0 ~
y:0 ~
w:w ~
h:h;
1349 if not firsttime
&& nogeomcmds state
.geomcmds
1350 then state
.anchor <- getanchor
();
1353 let w = wadjsb () + (truncate
(float w *. conf
.zoom
)) in
1356 setfontsize fstate
.fontsize
;
1357 GlMat.mode `modelview
;
1358 GlMat.load_identity
();
1360 GlMat.mode `projection
;
1361 GlMat.load_identity
();
1362 GlMat.rotate ~
x:1.0 ~angle
:180.0 ();
1363 GlMat.translate ~
x:~
-.1.0 ~
y:~
-.1.0 ();
1364 GlMat.scale3
(2.0 /. float state
.winw
, 2.0 /. float state
.winh
, 1.0);
1369 else float state
.x /. float state
.w
1371 invalidate "geometry"
1375 then state
.x <- truncate
(relx *. float w);
1377 match conf
.columns
with
1379 | Cmulti
((c, _
, _
), _
) -> (w - (c-1)*conf
.interpagespace
) / c
1380 | Csplit
(c, _
) -> w * c
1382 wcmd "geometry %d %d %d"
1383 w (stateh h) (FMTE.to_int conf
.fitmodel
)
1388 let len = String.length state
.text in
1389 let x0 = xadjsb () in
1392 match state
.mode
with
1393 | Textentry _
| View
| LinkNav _
->
1394 let h, _
, _
= state
.uioh#scrollpw
in
1399 filledrect x (float (state
.winh
- (fstate
.fontsize
+ 4) - hscrollh))
1400 (x+.w) (float (state
.winh
- hscrollh))
1403 let w = float (wadjsb () + state
.winw
- 1) in
1404 if state
.progress
>= 0.0 && state
.progress
< 1.0
1406 GlDraw.color (0.3, 0.3, 0.3);
1407 let w1 = w *. state
.progress
in
1409 GlDraw.color (0.0, 0.0, 0.0);
1410 rect (float x0+.w1) (float x0+.w-.w1)
1413 GlDraw.color (0.0, 0.0, 0.0);
1417 GlDraw.color (1.0, 1.0, 1.0);
1418 drawstring fstate
.fontsize
1419 (if conf
.leftscroll
then x0 + 2 else x0 + if len > 0 then 8 else 2)
1420 (state
.winh
- hscrollh - 5) s;
1423 match state
.mode
with
1424 | Textentry
((prefix
, text, _
, _
, _
, _
), _
) ->
1428 Printf.sprintf
"%s%s_ [%s]" prefix
text state
.text
1430 Printf.sprintf
"%s%s_" prefix
text
1436 | LinkNav _
-> state
.text
1441 if not
(istextentry state
.mode
) && state
.uioh#eformsgs
1443 let s1 = "(press 'e' to review error messasges)" in
1444 if nonemptystr
s then s ^
" " ^
s1 else s1
1454 let len = Queue.length state
.tilelru
in
1456 match state
.throttle
with
1459 then preloadlayout state
.x state
.y state
.winw state
.winh
1461 | Some
(layout, _
, _
) ->
1465 if state
.memused
<= conf
.memlimit
1470 let (k
, p
, s) as lruitem
= Queue.pop state
.tilelru
in
1471 let n, gen
, colorspace
, angle
, pagew
, pageh
, col, row = k
in
1472 let (_
, pw, ph
, _
) = getpagedim
n in
1475 && colorspace
= conf
.colorspace
1476 && angle
= conf
.angle
1480 let x = col*conf
.tilew
1481 and y = row*conf
.tileh
in
1482 tilevisible (Lazy.force_val
layout) n x y
1484 then Queue.push lruitem state
.tilelru
1487 wcmd "freetile %s" (~
> p
);
1488 state
.memused
<- state
.memused
- s;
1489 state
.uioh#infochanged Memused
;
1490 Hashtbl.remove state
.tilemap k
;
1498 let onpagerect pageno
f =
1500 match conf
.columns
with
1501 | Cmulti
(_
, b) -> b
1503 | Csplit
(_
, b) -> b
1505 if pageno
>= 0 && pageno
< Array.length
b
1507 let (_
, _
, _
, (_
, w, h, _
)) = b.(pageno
) in
1511 let gotopagexy1 wtmode pageno
x y =
1512 let _,w1,h1
,leftx
= getpagedim pageno
in
1513 let top = y /. (float h1
) in
1514 let left = x /. (float w1) in
1515 let py, w, h = getpageywh pageno
in
1516 let wh = state
.winh
- hscrollh () in
1517 let x = left *. (float w) in
1518 let x = leftx
+ state
.x + truncate
x in
1519 let wadj = wadjsb () in
1521 if x < 0 || x >= wadj + state
.winw
1525 let pdy = truncate
(top *. float h) in
1526 let y'
= py + pdy in
1527 let dy = y'
- state
.y in
1529 if x != state
.x || not
(dy > 0 && dy < wh)
1531 if conf
.presentation
1533 if abs
(py - y'
) > wh
1540 if state
.x != sx || state
.y != sy
1545 let ww = wadj + state
.winw
in
1547 and qy
= pdy / wh in
1549 and y = py + qy
* wh in
1550 let x = if -x + ww > w1 then -(w1-ww) else x
1551 and y'
= if y + wh > state
.maxy
then state
.maxy
- wh else y in
1553 if conf
.presentation
1555 if abs
(py - y'
) > wh
1565 gotoy_and_clear_text y;
1567 else gotoy_and_clear_text state
.y;
1570 let gotopagexy wtmode pageno
x y =
1571 match state
.mode
with
1572 | Birdseye
_ -> gotopage pageno
0.0
1575 | LinkNav
_ -> gotopagexy1 wtmode pageno
x y
1578 let getpassword () =
1579 let passcmd = getenvwithdef
"LLPP_ASKPASS" conf
.passcmd in
1584 impmsg "error getting password: %s" s;
1585 dolog
"%s" s) passcmd;
1588 let pgoto opaque pageno
x y =
1589 let pdimno = getpdimno pageno
in
1590 let x, y = project opaque pageno
pdimno x y in
1591 gotopagexy false pageno
x y;
1595 (* dolog "%S" cmds; *)
1596 let cl = splitatspace cmds
in
1598 try Scanf.sscanf
s fmt
f
1600 dolog
"error processing '%S': %s" cmds
@@ exntos exn
;
1603 let addoutline outline
=
1604 match state
.currently
with
1605 | Outlining outlines
->
1606 state
.currently
<- Outlining
(outline
:: outlines
)
1607 | Idle
-> state
.currently
<- Outlining
[outline
]
1610 dolog
"invalid outlining state";
1611 logcurrently state
.currently
1615 state
.uioh#infochanged Pdim
;
1618 | "clearrects" :: [] ->
1619 state
.rects
<- state
.rects1
;
1620 G.postRedisplay "clearrects";
1622 | "continue" :: args
:: [] ->
1623 let n = scan args
"%u" (fun n -> n) in
1624 state
.pagecount
<- n;
1625 begin match state
.currently
with
1627 state
.currently
<- Idle
;
1628 state
.outlines
<- Array.of_list
(List.rev
l)
1634 let cur, cmds
= state
.geomcmds
in
1636 then failwith
"umpossible";
1638 begin match List.rev cmds
with
1640 state
.geomcmds
<- E.s, [];
1641 state
.throttle
<- None
;
1645 state
.geomcmds
<- s, List.rev rest
;
1647 if conf
.maxwait
= None
&& not
!wtmode
1648 then G.postRedisplay "continue";
1650 | "msg" :: args
:: [] ->
1653 | "vmsg" :: args
:: [] ->
1655 then showtext ' ' args
1657 | "emsg" :: args
:: [] ->
1658 Buffer.add_string state
.errmsgs args
;
1659 state
.newerrmsgs
<- true;
1660 G.postRedisplay "error message"
1662 | "progress" :: args
:: [] ->
1663 let progress, text =
1666 f, String.sub args pos
(String.length args
- pos
))
1669 state
.progress <- progress;
1670 G.postRedisplay "progress"
1672 | "firstmatch" :: args
:: [] ->
1673 let pageno, c, x0, y0, x1, y1, x2
, y2
, x3
, y3
=
1674 scan args
"%u %d %f %f %f %f %f %f %f %f"
1675 (fun p
c x0 y0 x1 y1 x2 y2 x3 y3
->
1676 (p
, c, x0, y0, x1, y1, x2
, y2
, x3
, y3
))
1678 let xoff = float (xadjsb ()) in
1682 and x3
= x3
+. xoff in
1683 let y = (getpagey
pageno) + truncate
y0 in
1685 then state
.x <- truncate
(xoff -. x0) + state
.winw
/2;
1688 let color = (0.0, 0.0, 1.0 /. float c, 0.5) in
1689 state
.rects1
<- [pageno, color, (x0, y0, x1, y1, x2
, y2
, x3
, y3
)]
1691 | "match" :: args
:: [] ->
1692 let pageno, c, x0, y0, x1, y1, x2
, y2
, x3
, y3
=
1693 scan args
"%u %d %f %f %f %f %f %f %f %f"
1694 (fun p
c x0 y0 x1 y1 x2 y2 x3 y3
->
1695 (p
, c, x0, y0, x1, y1, x2
, y2
, x3
, y3
))
1697 let xoff = float (xadjsb ()) in
1701 and x3
= x3
+. xoff in
1702 let color = (0.0, 0.0, 1.0 /. float c, 0.5) in
1704 (pageno, color, (x0, y0, x1, y1, x2
, y2
, x3
, y3
)) :: state
.rects1
1706 | "page" :: args
:: [] ->
1707 let pageopaques, t
= scan args
"%s %f" (fun p t
-> p
, t
) in
1708 let pageopaque = ~
< pageopaques in
1709 begin match state
.currently
with
1710 | Loading
(l, gen
) ->
1711 vlog "page %d took %f sec" l.pageno t
;
1712 Hashtbl.replace state
.pagemap
(l.pageno, gen
) pageopaque;
1713 begin match state
.throttle
with
1715 let preloadedpages =
1717 then preloadlayout state
.x state
.y state
.winw state
.winh
1722 List.fold_left
(fun s l -> IntSet.add
l.pageno s)
1723 IntSet.empty
preloadedpages
1726 Hashtbl.fold (fun ((pageno, _) as key) opaque
accu ->
1727 if not
(IntSet.mem
pageno set)
1729 wcmd "freepage %s" (~
> opaque
);
1735 List.iter
(Hashtbl.remove state
.pagemap
) evictedpages;
1738 state
.currently
<- Idle
;
1741 tilepage l.pageno pageopaque state
.layout;
1743 load preloadedpages;
1744 let visible = pagevisible state
.layout l.pageno in
1747 match state
.mode
with
1748 | LinkNav
(Ltnotready
(pageno, dir
)) ->
1749 if pageno = l.pageno
1754 then LDfirstvisible
(l.pagex
, l.pagey, dir
)
1756 if dir
> 0 then LDfirst
else LDlast
1759 findlink
pageopaque ld
1764 showlinktype (getlink
pageopaque n);
1765 state
.mode
<- LinkNav
(Ltexact
(l.pageno, n))
1767 | LinkNav
(Ltgendir
_)
1768 | LinkNav
(Ltexact
_)
1774 if visible && layoutready state
.layout
1776 G.postRedisplay "page";
1780 | Some
(layout, _, _) ->
1781 state
.currently
<- Idle
;
1782 tilepage l.pageno pageopaque layout;
1789 dolog
"Inconsistent loading state";
1790 logcurrently state
.currently
;
1794 | "tile" :: args
:: [] ->
1795 let (x, y, opaques
, size
, t
) =
1796 scan args
"%u %u %s %u %f"
1797 (fun x y p size t
-> (x, y, p
, size
, t
))
1799 let opaque = ~
< opaques
in
1800 begin match state
.currently
with
1801 | Tiling
(l, pageopaque, cs
, angle
, gen
, col, row, tilew
, tileh
) ->
1802 vlog "tile %d [%d,%d] took %f sec" l.pageno col row t
;
1805 if tilew
!= conf
.tilew
|| tileh
!= conf
.tileh
1807 wcmd "freetile %s" (~
> opaque);
1808 state
.currently
<- Idle
;
1812 puttileopaque l col row gen cs angle
opaque size t
;
1813 state
.memused
<- state
.memused
+ size
;
1814 state
.uioh#infochanged Memused
;
1816 Queue.push
((l.pageno, gen
, cs
, angle
, l.pagew
, l.pageh
, col, row),
1817 opaque, size
) state
.tilelru
;
1820 match state
.throttle
with
1821 | None
-> state
.layout
1822 | Some
(layout, _, _) -> layout
1825 state
.currently
<- Idle
;
1827 && conf
.colorspace
= cs
1828 && conf
.angle
= angle
1829 && tilevisible layout l.pageno x y
1830 then conttiling l.pageno pageopaque;
1832 begin match state
.throttle
with
1834 preload state
.layout;
1836 && conf
.colorspace
= cs
1837 && conf
.angle
= angle
1838 && tilevisible state
.layout l.pageno x y
1839 && (not
!wtmode || layoutready state
.layout)
1840 then G.postRedisplay "tile nothrottle";
1842 | Some
(layout, y, _) ->
1843 let ready = layoutready layout in
1847 state
.layout <- layout;
1848 state
.throttle
<- None
;
1849 G.postRedisplay "throttle";
1858 dolog
"Inconsistent tiling state";
1859 logcurrently state
.currently
;
1863 | "pdim" :: args
:: [] ->
1864 let (n, w, h, _) as pdim
=
1865 scan args
"%u %u %u %u" (fun n w h x -> n, w, h, x)
1868 match conf
.fitmodel
with
1870 | FitPage
| FitProportional
->
1871 match conf
.columns
with
1872 | Csplit
_ -> (n, w, h, 0)
1873 | Csingle
_ | Cmulti
_ -> pdim
1875 state
.uioh#infochanged Pdim
;
1876 state
.pdims
<- pdim :: state
.pdims
1878 | "o" :: args
:: [] ->
1879 let (l, n, t
, h, pos
) =
1880 scan args
"%u %u %d %u %n"
1881 (fun l n t
h pos
-> l, n, t
, h, pos
)
1883 let s = String.sub args pos
(String.length args
- pos
) in
1884 addoutline (s, l, Oanchor
(n, float t
/. float h, 0.0))
1886 | "ou" :: args
:: [] ->
1887 let (l, len, pos
) = scan args
"%u %u %n" (fun l len pos
-> l, len, pos
) in
1888 let s = String.sub args pos
len in
1889 let pos2 = pos
+ len + 1 in
1890 let uri = String.sub args
pos2 (String.length args
- pos2) in
1891 addoutline (s, l, Ouri
uri)
1893 | "on" :: args
:: [] ->
1894 let (l, pos
) = scan args
"%u %n" (fun l pos
-> l, pos
) in
1895 let s = String.sub args pos
(String.length args
- pos
) in
1896 addoutline (s, l, Onone
)
1898 | "a" :: args
:: [] ->
1900 scan args
"%u %d %d" (fun n l t
-> n, l, t
)
1902 state
.reprf
<- (fun () -> gotopagexy !wtmode n (float l) (float t
))
1904 | "info" :: args
:: [] ->
1905 let pos = nindex args '
\t'
in
1906 if pos >= 0 && String.sub args
0 pos = "Title"
1908 let s = String.sub args
(pos+1) @@ String.length args
- pos - 1 in
1912 state
.docinfo
<- (1, args
) :: state
.docinfo
1914 | "infoend" :: [] ->
1915 state
.uioh#infochanged Docinfo
;
1916 state
.docinfo
<- List.rev state
.docinfo
1920 then Wsi.settitle
"Wrong password";
1921 let password = getpassword () in
1922 if emptystr
password
1923 then error
"document is password protected"
1924 else opendoc state
.path
password
1926 error
"unknown cmd `%S'" cmds
1931 let action = function
1932 | HCprev
-> cbget cb ~
-1
1933 | HCnext
-> cbget cb
1
1934 | HCfirst
-> cbget cb ~
-(cb
.rc)
1935 | HClast
-> cbget cb
(cb
.len - 1 - cb
.rc)
1936 and cancel
() = cb
.rc <- rc
1940 let search pattern forward
=
1941 match conf
.columns
with
1942 | Csplit
_ -> impmsg "searching does not work properly in split columns mode"
1945 if nonemptystr pattern
1948 match state
.layout with
1951 l.pageno, (l.pagey + if forward
then 0 else 0*l.pagevh)
1953 wcmd "search %d %d %d %d,%s\000"
1954 (btod conf
.icase
) pn py (btod forward
) pattern
;
1957 let intentry text key =
1959 if key >= 32 && key < 127
1965 let text = addchar
text c in
1969 state
.text <- Printf.sprintf
"invalid char (%d, `%c')" key c;
1977 let l = String.length
s in
1978 let rec loop pos n = if pos = l then n else
1979 let m = Char.code
s.[pos] - (if pos = 0 && l > 1 then 96 else 97) in
1980 loop (pos+1) (n*26 + m)
1983 let rec loop n = function
1986 match getopaque l.pageno with
1987 | None
-> loop n rest
1989 let m = getlinkcount
opaque in
1992 let under = getlink
opaque n in
1995 else loop (n-m) rest
1997 loop n state
.layout;
2001 let linknentry text key =
2003 if key >= 32 && key < 127
2009 let text = addchar
text c in
2010 linknact (fun under -> state
.text <- undertext ~nopath
:true under) text;
2014 state
.text <- Printf.sprintf
"invalid char (%d, `%c')" key c;
2018 let textentry text key =
2019 if key land 0xff00 = 0xff00
2021 else TEcont
(text ^ toutf8
key)
2024 let reqlayout angle fitmodel
=
2025 match state
.throttle
with
2027 if nogeomcmds state
.geomcmds
2028 then state
.anchor <- getanchor
();
2029 conf
.angle
<- angle
mod 360;
2032 match state
.mode
with
2033 | LinkNav
_ -> state
.mode
<- View
2038 conf
.fitmodel
<- fitmodel
;
2039 invalidate "reqlayout"
2041 wcmd "reqlayout %d %d %d"
2042 conf
.angle
(FMTE.to_int conf
.fitmodel
) (stateh state
.winh
)
2047 let settrim trimmargins trimfuzz
=
2048 if nogeomcmds state
.geomcmds
2049 then state
.anchor <- getanchor
();
2050 conf
.trimmargins
<- trimmargins
;
2051 conf
.trimfuzz
<- trimfuzz
;
2052 let x0, y0, x1, y1 = trimfuzz
in
2053 invalidate "settrim"
2055 wcmd "settrim %d %d %d %d %d" (btod conf
.trimmargins
) x0 y0 x1 y1);
2060 match state
.throttle
with
2062 let zoom = max
0.0001 zoom in
2063 if zoom <> conf
.zoom
2065 state
.prevzoom
<- (conf
.zoom, state
.x);
2067 reshape state
.winw state
.winh
;
2068 state
.text <- Printf.sprintf
"zoom is now %-5.2f" (zoom *. 100.0);
2071 | Some
(layout, y, started
) ->
2073 match conf
.maxwait
with
2077 let dt = now
() -. started
in
2085 let setcolumns mode columns coverA coverB
=
2086 state
.prevcolumns
<- Some
(conf
.columns
, conf
.zoom);
2090 then impmsg "split mode doesn't work in bird's eye"
2092 conf
.columns
<- Csplit
(-columns
, E.a);
2100 conf
.columns
<- Csingle
E.a;
2105 conf
.columns
<- Cmulti
((columns
, coverA
, coverB
), E.a);
2109 reshape state
.winw state
.winh
;
2112 let resetmstate () =
2113 state
.mstate
<- Mnone
;
2114 Wsi.setcursor
Wsi.CURSOR_INHERIT
;
2117 let enterbirdseye () =
2118 let zoom = float conf
.thumbw
/. float state
.winw
in
2119 let birdseyepageno =
2120 let cy = state
.winh
/ 2 in
2124 let rec fold best
= function
2127 let d = cy - (l.pagedispy + l.pagevh/2)
2128 and dbest
= cy - (best
.pagedispy + best
.pagevh/2) in
2129 if abs
d < abs dbest
2136 state
.mode
<- Birdseye
(
2137 { conf
with zoom = conf
.zoom }, state
.x, birdseyepageno, -1, getanchor
()
2141 conf
.presentation
<- false;
2142 conf
.interpagespace
<- 10;
2143 conf
.hlinks
<- false;
2144 conf
.fitmodel
<- FitPage
;
2146 conf
.maxwait
<- None
;
2148 match conf
.beyecolumns
with
2151 Cmulti
((c, 0, 0), E.a)
2152 | None
-> Csingle
E.a
2156 state
.text <- Printf.sprintf
"birds eye mode on (zoom %3.1f%%)"
2161 reshape state
.winw state
.winh
;
2164 let leavebirdseye (c, leftx
, pageno, _, anchor) goback
=
2166 conf
.zoom <- c.zoom;
2167 conf
.presentation
<- c.presentation
;
2168 conf
.interpagespace
<- c.interpagespace
;
2169 conf
.maxwait
<- c.maxwait
;
2170 conf
.hlinks
<- c.hlinks
;
2171 conf
.fitmodel
<- c.fitmodel
;
2172 conf
.beyecolumns
<- (
2173 match conf
.columns
with
2174 | Cmulti
((c, _, _), _) -> Some
c
2176 | Csplit
_ -> failwith
"leaving bird's eye split mode"
2179 match c.columns
with
2180 | Cmulti
(c, _) -> Cmulti
(c, E.a)
2181 | Csingle
_ -> Csingle
E.a
2182 | Csplit
(c, _) -> Csplit
(c, E.a)
2186 state
.text <- Printf.sprintf
"birds eye mode off (zoom %3.1f%%)"
2189 reshape state
.winw state
.winh
;
2190 state
.anchor <- if goback
then anchor else (pageno, 0.0, 1.0);
2194 let togglebirdseye () =
2195 match state
.mode
with
2196 | Birdseye vals
-> leavebirdseye vals
true
2197 | View
-> enterbirdseye ()
2202 let upbirdseye incr
(conf
, leftx
, pageno, hooverpageno
, anchor) =
2203 let pageno = max
0 (pageno - incr
) in
2204 let rec loop = function
2205 | [] -> gotopage1 pageno 0
2206 | l :: _ when l.pageno = pageno ->
2207 if l.pagedispy >= 0 && l.pagey = 0
2208 then G.postRedisplay "upbirdseye"
2209 else gotopage1 pageno 0
2210 | _ :: rest
-> loop rest
2214 state
.mode
<- Birdseye
(conf
, leftx
, pageno, hooverpageno
, anchor)
2217 let downbirdseye incr
(conf
, leftx
, pageno, hooverpageno
, anchor) =
2218 let pageno = min
(state
.pagecount
- 1) (pageno + incr
) in
2219 state
.mode
<- Birdseye
(conf
, leftx
, pageno, hooverpageno
, anchor);
2220 let rec loop = function
2222 let y, h = getpageyh
pageno in
2223 let dy = (y - state
.y) - (state
.winh
- h - conf
.interpagespace
) in
2225 | l :: _ when l.pageno = pageno ->
2226 if l.pagevh != l.pageh
2227 then gotoy (clamp (l.pageh
- l.pagevh + conf
.interpagespace
))
2228 else G.postRedisplay "downbirdseye"
2229 | _ :: rest
-> loop rest
2235 let optentry mode
_ key =
2236 let btos b = if b then "on" else "off" in
2237 if key >= 32 && key < 127
2239 let c = Char.chr
key in
2243 try conf
.scrollstep
<- int_of_string
s with exc
->
2244 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exc
2246 TEswitch
("scroll step: ", E.s, None
, intentry, ondone, true)
2251 conf
.autoscrollstep
<- boundastep state
.winh
(int_of_string
s);
2252 if state
.autoscroll
<> None
2253 then state
.autoscroll
<- Some conf
.autoscrollstep
2255 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exc
2257 TEswitch
("auto scroll step: ", E.s, None
, intentry, ondone, true)
2262 let n, a, b = multicolumns_of_string
s in
2263 setcolumns mode
n a b;
2265 state
.text <- Printf.sprintf
"bad columns `%s': %s" s @@ exntos exc
2267 TEswitch
("columns: ", E.s, None
, textentry, ondone, true)
2272 let zoom = float (int_of_string
s) /. 100.0 in
2275 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exc
2277 TEswitch
("zoom: ", E.s, None
, intentry, ondone, true)
2282 conf
.thumbw
<- bound
(int_of_string
s) 2 4096;
2284 Printf.sprintf
"thumbnail width is set to %d" conf
.thumbw
;
2285 begin match mode
with
2287 leavebirdseye beye
false;
2294 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exc
2296 TEswitch
("thumbnail width: ", E.s, None
, intentry, ondone, true)
2301 Some
(int_of_string
s)
2304 Printf.sprintf
"bad integer `%s': %s" s @@ exntos exc
;
2307 | Some angle
-> reqlayout angle conf
.fitmodel
2310 TEswitch
("rotation: ", E.s, None
, intentry, ondone, true)
2313 conf
.icase
<- not conf
.icase
;
2314 TEdone
("case insensitive search " ^
(btos conf
.icase
))
2317 conf
.preload <- not conf
.preload;
2319 TEdone
("preload " ^
(btos conf
.preload))
2322 conf
.verbose
<- not conf
.verbose
;
2323 TEdone
("verbose " ^
(btos conf
.verbose
))
2326 conf
.debug
<- not conf
.debug
;
2327 TEdone
("debug " ^
(btos conf
.debug
))
2330 conf
.maxhfit
<- not conf
.maxhfit
;
2331 state
.maxy
<- calcheight
();
2332 TEdone
("maxhfit " ^
(btos conf
.maxhfit
))
2335 conf
.crophack
<- not conf
.crophack
;
2336 TEdone
("crophack " ^
btos conf
.crophack
)
2340 match conf
.maxwait
with
2342 conf
.maxwait
<- Some infinity
;
2343 "always wait for page to complete"
2345 conf
.maxwait
<- None
;
2346 "show placeholder if page is not ready"
2351 conf
.underinfo
<- not conf
.underinfo
;
2352 TEdone
("underinfo " ^
btos conf
.underinfo
)
2355 conf
.savebmarks
<- not conf
.savebmarks
;
2356 TEdone
("persistent bookmarks " ^
btos conf
.savebmarks
)
2362 match state
.layout with
2367 conf
.interpagespace
<- int_of_string
s;
2368 docolumns conf
.columns
;
2369 state
.maxy
<- calcheight
();
2370 let y = getpagey
pageno in
2373 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exc
2375 TEswitch
("vertical margin: ", E.s, None
, intentry, ondone, true)
2379 match conf
.fitmodel
with
2380 | FitProportional
-> FitWidth
2381 | FitWidth
| FitPage
-> FitProportional
2383 reqlayout conf
.angle
fm;
2384 TEdone
("proportional display " ^
btos (fm == FitProportional
))
2387 settrim (not conf
.trimmargins
) conf
.trimfuzz
;
2388 TEdone
("trim margins " ^
btos conf
.trimmargins
)
2391 conf
.invert
<- not conf
.invert
;
2392 TEdone
("invert colors " ^
btos conf
.invert
)
2396 cbput state
.hists
.sel
s;
2399 TEswitch
("selection command: ", E.s, Some
(onhist state
.hists
.sel
),
2400 textentry, ondone, true)
2404 then conf
.pax
<- Some
(ref (0.0, 0, 0))
2405 else conf
.pax
<- None
;
2406 TEdone
("PAX " ^
btos (conf
.pax
!= None
))
2409 state
.text <- Printf.sprintf
"bad option %d `%c'" key c;
2415 class type lvsource
= object
2416 method getitemcount
: int
2417 method getitem
: int -> (string * int)
2418 method hasaction
: int -> bool
2426 method getactive
: int
2427 method getfirst
: int
2429 method getminfo
: (int * int) array
2432 class virtual lvsourcebase
= object
2433 val mutable m_active
= 0
2434 val mutable m_first
= 0
2435 val mutable m_pan
= 0
2436 method getactive
= m_active
2437 method getfirst
= m_first
2438 method getpan
= m_pan
2439 method getminfo
: (int * int) array
= E.a
2442 let textentrykeyboard
2443 key _mask
((c, text, opthist
, onkey
, ondone, cancelonempty
), onleave
) =
2446 if key >= 0xffb0 && key <= 0xffb9
2447 then key - 0xffb0 + 48 else key
2450 state
.mode
<- Textentry
(te
, onleave
);
2452 G.postRedisplay "textentrykeyboard enttext";
2454 let histaction cmd
=
2457 | Some
(action, _) ->
2458 state
.mode
<- Textentry
(
2459 (c, action cmd
, opthist
, onkey
, ondone, cancelonempty
), onleave
2461 G.postRedisplay "textentry histaction"
2465 if emptystr
text && cancelonempty
2468 G.postRedisplay "textentrykeyboard after cancel";
2471 let s = withoutlastutf8
text in
2472 enttext (c, s, opthist
, onkey
, ondone, cancelonempty
)
2474 | @enter
| @kpenter
->
2477 G.postRedisplay "textentrykeyboard after confirm"
2479 | @up
| @kpup
-> histaction HCprev
2480 | @down
| @kpdown
-> histaction HCnext
2481 | @home
| @kphome
-> histaction HCfirst
2482 | @jend
| @kpend
-> histaction HClast
2487 begin match opthist
with
2489 | Some
(_, onhistcancel
) -> onhistcancel
()
2493 G.postRedisplay "textentrykeyboard after cancel2"
2496 enttext (c, E.s, opthist
, onkey
, ondone, cancelonempty
)
2499 | @delete
| @kpdelete
-> ()
2502 && key land 0xff00 != 0xff00 (* keyboard *)
2503 && key land 0xfe00 != 0xfe00 (* xkb *)
2504 && key land 0xfd00 != 0xfd00 (* 3270 *)
2506 begin match onkey
text key with
2510 G.postRedisplay "textentrykeyboard after confirm2";
2513 enttext (c, text, opthist
, onkey
, ondone, cancelonempty
);
2517 G.postRedisplay "textentrykeyboard after cancel3"
2520 state
.mode
<- Textentry
(te
, onleave
);
2521 G.postRedisplay "textentrykeyboard switch";
2525 vlog "unhandled key %s" (Wsi.keyname
key)
2528 let firstof first active
=
2529 if first
> active
|| abs
(first
- active
) > fstate
.maxrows
- 1
2530 then max
0 (active
- (fstate
.maxrows
/2))
2534 let calcfirst first active
=
2537 let rows = active
- first
in
2538 if rows > fstate
.maxrows
then active
- fstate
.maxrows
else first
2542 let scrollph y maxy
=
2543 let sh = float (maxy
+ state
.winh
) /. float state
.winh
in
2544 let sh = float state
.winh
/. sh in
2545 let sh = max
sh (float conf
.scrollh
) in
2547 let percent = float y /. float maxy
in
2548 let position = (float state
.winh
-. sh) *. percent in
2551 if position +. sh > float state
.winh
2552 then float state
.winh
-. sh
2558 let coe s = (s :> uioh
);;
2560 class listview ~zebra ~helpmode ~
(source
:lvsource
) ~trusted ~modehash
=
2562 val m_pan
= source#getpan
2563 val m_first
= source#getfirst
2564 val m_active
= source#getactive
2566 val m_prev_uioh
= state
.uioh
2568 method private elemunder
y =
2572 let n = y / (fstate
.fontsize
+1) in
2573 if m_first
+ n < source#getitemcount
2575 if source#hasaction
(m_first
+ n)
2576 then Some
(m_first
+ n)
2583 GlFunc.blend_func ~src
:`src_alpha ~dst
:`one_minus_src_alpha
;
2584 GlDraw.color (0., 0., 0.) ~alpha
:0.85;
2585 filledrect 0. 0. (float state
.winw
) (float state
.winh
);
2586 GlDraw.color (1., 1., 1.);
2587 Gl.enable `texture_2d
;
2588 let fs = fstate
.fontsize
in
2590 let hw = (wadjsb () + xadjsb () + state
.winw
)/3 in
2591 let ww = fstate
.wwidth
in
2592 let tabw = 17.0*.ww in
2593 let itemcount = source#getitemcount
in
2594 let minfo = source#getminfo
in
2597 then float (xadjsb ()), float (state
.winw
- 1)
2598 else 0.0, float (state
.winw
- conf
.scrollbw
- 1)
2600 let xadj = xadjsb () in
2602 if (row - m_first
) > fstate
.maxrows
2605 if row >= 0 && row < itemcount
2607 let (s, level
) = source#getitem
row in
2608 let y = (row - m_first
) * nfs in
2610 (if conf
.leftscroll
then float xadj else 5.0)
2611 +. (float (level
+ m_pan
)) *. ww in
2614 (let c = if row land 1 = 0 then 1.0 else 0.92 in (c,c,c));
2618 Gl.disable `texture_2d
;
2619 let alpha = if source#hasaction
row then 0.9 else 0.3 in
2620 GlDraw.color (1., 1., 1.) ~
alpha;
2621 linerect (x0 +. 1.) (float (y + 1)) (x1) (float (y + fs + 3));
2622 Gl.enable `texture_2d
;
2625 if zebra
&& row land 1 = 1
2629 GlDraw.color (c,c,c);
2630 let drawtabularstring s =
2632 let x'
= truncate
(x0 +. x) in
2633 let pos = nindex
s '
\000'
in
2635 then drawstring1 fs x'
(y+nfs) s
2637 let s1 = String.sub
s 0 pos
2638 and s2
= String.sub
s (pos+1) (String.length
s - pos - 1) in
2643 let s'
= withoutlastutf8
s in
2644 let s = s' ^
"@Uellipsis" in
2645 let w = measurestr
fs s in
2646 if float x'
+. w +. ww < float (hw + x'
)
2651 if float x'
+. ww +. measurestr
fs s1 > float (hw + x'
)
2655 ignore
(drawstring1 fs x'
(y+nfs) s1);
2656 drawstring1 fs (hw + x'
) (y+nfs) s2
2660 let x = if helpmode
&& row > 0 then x +. ww else x in
2661 let tabpos = nindex
s '
\t'
in
2664 let len = String.length
s - tabpos - 1 in
2665 let s1 = String.sub
s 0 tabpos
2666 and s2
= String.sub
s (tabpos + 1) len in
2667 let nx = drawstr x s1 in
2669 let x = x +. (max
tabw sw) in
2672 let len = String.length
s - 2 in
2673 if len > 0 && s.[0] = '
\xc2'
&& s.[1] = '
\xb7'
2675 let s = String.sub
s 2 len in
2676 let x = if not helpmode
then x +. ww else x in
2677 GlDraw.color (1.2, 1.2, 1.2);
2678 let vinc = drawstring1 (fs+fs/4)
2679 (truncate
(x -. ww)) (y+nfs) s in
2680 GlDraw.color (1., 1., 1.);
2681 vinc +. (float fs *. 0.8)
2687 ignore
(drawtabularstring s);
2693 GlDraw.color (1.0, 1.0, 1.0) ~
alpha:0.5;
2694 let xadj = float (xadjsb () + 5) in
2696 if (row - m_first
) > fstate
.maxrows
2699 if row >= 0 && row < itemcount
2701 let (s, level
) = source#getitem
row in
2702 let pos0 = nindex
s '
\000'
in
2703 let y = (row - m_first
) * nfs in
2704 let x = float (level
+ m_pan
) *. ww in
2705 let (first
, last
) = minfo.(row) in
2707 if pos0 > 0 && first
> pos0
2708 then String.sub
s (pos0+1) (first
-pos0-1)
2709 else String.sub
s 0 first
2711 let suffix = String.sub
s first
(last
- first
) in
2712 let w1 = measurestr fstate
.fontsize
prefix in
2713 let w2 = measurestr fstate
.fontsize
suffix in
2714 let x = x +. if conf
.leftscroll
then xadj else 5.0 in
2715 let x = if pos0 > 0 && first
> pos0 then x +. float hw else x in
2717 and y0 = float (y+2) in
2719 and y1 = float (y+fs+3) in
2720 filledrect x0 y0 x1 y1;
2725 Gl.disable `texture_2d
;
2726 if Array.length
minfo > 0 then loop m_first
;
2729 method updownlevel incr
=
2730 let len = source#getitemcount
in
2732 if m_active
>= 0 && m_active
< len
2733 then snd
(source#getitem m_active
)
2737 if i
= len then i
-1 else if i
= -1 then 0 else
2738 let _, l = source#getitem i
in
2739 if l != curlevel then i
else flow (i
+incr
)
2741 let active = flow m_active
in
2742 let first = calcfirst m_first
active in
2743 G.postRedisplay "outline updownlevel";
2744 {< m_active
= active; m_first
= first >}
2746 method private key1
key mask
=
2747 let set1 active first qsearch
=
2748 coe {< m_active
= active; m_first
= first; m_qsearch
= qsearch
>}
2750 let search active pattern incr
=
2751 let active = if active = -1 then m_first
else active in
2754 if n >= 0 && n < source#getitemcount
2756 let s, _ = source#getitem
n in
2757 match Str.search_forward re
s 0 with
2758 | (exception Not_found
) -> loop (n + incr
)
2765 Str.regexp_case_fold pattern
|> dosearch
2767 let itemcount = source#getitemcount
in
2768 let find start incr
=
2770 if i
= -1 || i
= itemcount
2773 if source#hasaction i
2775 else find (i
+ incr
)
2780 let set active first =
2781 let first = bound
first 0 (itemcount - fstate
.maxrows
) in
2783 coe {< m_active
= active; m_first
= first; m_qsearch
= E.s >}
2786 let isvisible first n = n >= first && n - first <= fstate
.maxrows
in
2788 let incr1 = if incr
> 0 then 1 else -1 in
2789 if isvisible m_first m_active
2792 let next = m_active
+ incr
in
2794 if next < 0 || next >= itemcount
2796 else find next incr1
2798 if abs
(m_active
- next) > fstate
.maxrows
2804 let first = m_first
+ incr
in
2805 let first = bound
first 0 (itemcount - fstate
.maxrows
) in
2807 let next = m_active
+ incr
in
2808 let next = bound
next 0 (itemcount - 1) in
2815 if isvisible first next
2822 let first = min
next m_first
in
2824 if abs
(next - first) > fstate
.maxrows
2830 let first = m_first
+ incr
in
2831 let first = bound
first 0 (itemcount - 1) in
2833 let next = m_active
+ incr
in
2834 let next = bound
next 0 (itemcount - 1) in
2835 let next = find next incr1 in
2837 if next = -1 || abs
(m_active
- first) > fstate
.maxrows
2839 let active = if m_active
= -1 then next else m_active
in
2844 if isvisible first active
2850 G.postRedisplay "listview navigate";
2854 | (@r
|@s) when Wsi.withctrl mask
->
2855 let incr = if key = @r
then -1 else 1 in
2857 match search (m_active
+ incr) m_qsearch
incr with
2859 state
.text <- m_qsearch ^
" [not found]";
2862 state
.text <- m_qsearch
;
2863 active, firstof m_first
active
2865 G.postRedisplay "listview ctrl-r/s";
2866 set1 active first m_qsearch
;
2868 | @insert
when Wsi.withctrl mask
->
2869 if m_active
>= 0 && m_active
< source#getitemcount
2871 let s, _ = source#getitem m_active
in
2877 if emptystr m_qsearch
2880 let qsearch = withoutlastutf8 m_qsearch
in
2884 G.postRedisplay "listview empty qsearch";
2885 set1 m_active m_first
E.s;
2889 match search m_active
qsearch ~
-1 with
2891 state
.text <- qsearch ^
" [not found]";
2894 state
.text <- qsearch;
2895 active, firstof m_first
active
2897 G.postRedisplay "listview backspace qsearch";
2898 set1 active first qsearch
2901 | key when (key != 0 && key land 0xff00 != 0xff00) ->
2902 let pattern = m_qsearch ^ toutf8
key in
2904 match search m_active
pattern 1 with
2906 state
.text <- pattern ^
" [not found]";
2909 state
.text <- pattern;
2910 active, firstof m_first
active
2912 G.postRedisplay "listview qsearch add";
2913 set1 active first pattern;
2917 if emptystr m_qsearch
2919 G.postRedisplay "list view escape";
2920 let mx, my
= state
.mpos
in
2924 source#exit ~uioh
:(coe self
)
2925 ~cancel
:true ~
active:m_active ~
first:m_first ~pan
:m_pan
2927 | None
-> m_prev_uioh
2932 G.postRedisplay "list view kill qsearch";
2933 coe {< m_qsearch
= E.s >}
2936 | @enter
| @kpenter
->
2938 let self = {< m_qsearch
= E.s >} in
2940 G.postRedisplay "listview enter";
2941 if m_active
>= 0 && m_active
< source#getitemcount
2943 source#exit ~uioh
:(coe self) ~cancel
:false
2944 ~
active:m_active ~
first:m_first ~pan
:m_pan
;
2947 source#exit ~uioh
:(coe self) ~cancel
:true
2948 ~
active:m_active ~
first:m_first ~pan
:m_pan
;
2951 begin match opt with
2952 | None
-> m_prev_uioh
2956 | @delete
| @kpdelete
->
2959 | @up
| @kpup
-> navigate ~
-1
2960 | @down
| @kpdown
-> navigate 1
2961 | @prior
| @kpprior
-> navigate ~
-(fstate
.maxrows
)
2962 | @next | @kpnext
-> navigate fstate
.maxrows
2964 | @right
| @kpright
->
2966 G.postRedisplay "listview right";
2967 coe {< m_pan
= m_pan
- 1 >}
2969 | @left | @kpleft
->
2971 G.postRedisplay "listview left";
2972 coe {< m_pan
= m_pan
+ 1 >}
2974 | @home
| @kphome
->
2975 let active = find 0 1 in
2976 G.postRedisplay "listview home";
2980 let first = max
0 (itemcount - fstate
.maxrows
) in
2981 let active = find (itemcount - 1) ~
-1 in
2982 G.postRedisplay "listview end";
2985 | key when (key = 0 || key land 0xff00 = 0xff00) ->
2989 dolog
"listview unknown key %#x" key; coe self
2991 method key key mask
=
2992 match state
.mode
with
2993 | Textentry te
-> textentrykeyboard key mask te
; coe self
2996 | LinkNav
_ -> self#key1
key mask
2998 method button button down
x y _ =
3001 | 1 when vscrollhit x ->
3002 G.postRedisplay "listview scroll";
3005 let _, position, sh = self#
scrollph in
3006 if y > truncate
position && y < truncate
(position +. sh)
3008 state
.mstate
<- Mscrolly
;
3012 let s = float (max
0 (y - conf
.scrollh
)) /. float state
.winh
in
3013 let first = truncate
(s *. float source#getitemcount
) in
3014 let first = min source#getitemcount
first in
3015 Some
(coe {< m_first
= first; m_active
= first >})
3017 state
.mstate
<- Mnone
;
3021 begin match self#elemunder
y with
3023 G.postRedisplay "listview click";
3024 source#exit ~uioh
:(coe {< m_active
= n >})
3025 ~cancel
:false ~
active:n ~
first:m_first ~pan
:m_pan
3029 | n when (n == 4 || n == 5) && not down
->
3030 let len = source#getitemcount
in
3032 if n = 5 && m_first
+ fstate
.maxrows
>= len
3036 let first = m_first
+ (if n == 4 then -1 else 1) in
3037 bound
first 0 (len - 1)
3039 G.postRedisplay "listview wheel";
3040 Some
(coe {< m_first
= first >})
3041 | n when (n = 6 || n = 7) && not down
->
3042 let inc = if n = 7 then -1 else 1 in
3043 G.postRedisplay "listview hwheel";
3044 Some
(coe {< m_pan
= m_pan
+ inc >})
3049 | None
-> m_prev_uioh
3052 method multiclick
_ x y = self#button
1 true x y
3055 match state
.mstate
with
3057 let s = float (max
0 (y - conf
.scrollh
)) /. float state
.winh
in
3058 let first = truncate
(s *. float source#getitemcount
) in
3059 let first = min source#getitemcount
first in
3060 G.postRedisplay "listview motion";
3061 coe {< m_first
= first; m_active
= first >}
3069 method pmotion
x y =
3070 if x < state
.winw
- conf
.scrollbw
3073 match self#elemunder
y with
3074 | None
-> Wsi.setcursor
Wsi.CURSOR_INHERIT
; m_active
3075 | Some
n -> Wsi.setcursor
Wsi.CURSOR_INFO
; n
3079 then (G.postRedisplay "listview pmotion"; {< m_active
= n >})
3084 Wsi.setcursor
Wsi.CURSOR_INHERIT
;
3088 method infochanged
_ = ()
3090 method scrollpw
= (0, 0.0, 0.0)
3092 let nfs = fstate
.fontsize
+ 1 in
3093 let y = m_first
* nfs in
3094 let itemcount = source#getitemcount
in
3095 let maxi = max
0 (itemcount - fstate
.maxrows
) in
3096 let maxy = maxi * nfs in
3097 let p, h = scrollph y maxy in
3100 method modehash
= modehash
3101 method eformsgs
= false
3102 method alwaysscrolly
= true
3105 class outlinelistview ~zebra ~source
=
3106 let settext autonarrow
s =
3109 let ss = source#statestr
in
3113 else "{" ^
ss ^
"} [" ^
s ^
"]"
3114 else state
.text <- s
3120 ~source
:(source
:> lvsource
)
3122 ~modehash
:(findkeyhash conf
"outline")
3125 val m_autonarrow
= false
3127 method! key key mask
=
3129 if emptystr state
.text
3131 else fstate
.maxrows - 2
3133 let calcfirst first active =
3136 let rows = active - first in
3137 if rows > maxrows then active - maxrows else first
3141 let active = m_active
+ incr in
3142 let active = bound
active 0 (source#getitemcount
- 1) in
3143 let first = calcfirst m_first
active in
3144 G.postRedisplay "outline navigate";
3145 coe {< m_active
= active; m_first
= first >}
3147 let navscroll first =
3149 let dist = m_active
- first in
3155 else first + maxrows
3158 G.postRedisplay "outline navscroll";
3159 coe {< m_first
= first; m_active
= active >}
3161 let ctrl = Wsi.withctrl mask
in
3166 then (source#denarrow
; E.s)
3168 let pattern = source#renarrow
in
3169 if nonemptystr m_qsearch
3170 then (source#narrow m_qsearch
; m_qsearch
)
3174 settext (not m_autonarrow
) text;
3175 G.postRedisplay "toggle auto narrowing";
3176 coe {< m_first
= 0; m_active
= 0; m_autonarrow
= not m_autonarrow
>}
3178 | @slash
when emptystr m_qsearch
&& not m_autonarrow
->
3180 G.postRedisplay "toggle auto narrowing";
3181 coe {< m_first
= 0; m_active
= 0; m_autonarrow
= true >}
3184 source#narrow m_qsearch
;
3186 then source#add_narrow_pattern m_qsearch
;
3187 G.postRedisplay "outline ctrl-n";
3188 coe {< m_first
= 0; m_active
= 0 >}
3191 let active = source#calcactive
(getanchor
()) in
3192 let first = firstof m_first
active in
3193 G.postRedisplay "outline ctrl-s";
3194 coe {< m_first
= first; m_active
= active >}
3197 G.postRedisplay "outline ctrl-u";
3198 if m_autonarrow
&& nonemptystr m_qsearch
3200 ignore
(source#renarrow
);
3201 settext m_autonarrow
E.s;
3202 coe {< m_first
= 0; m_active
= 0; m_qsearch
= E.s >}
3205 source#del_narrow_pattern
;
3206 let pattern = source#renarrow
in
3208 if emptystr
pattern then E.s else "Narrowed to " ^
pattern
3210 settext m_autonarrow
text;
3211 coe {< m_first
= 0; m_active
= 0; m_qsearch
= E.s >}
3215 let first = max
0 (m_active
- (fstate
.maxrows / 2)) in
3216 G.postRedisplay "outline ctrl-l";
3217 coe {< m_first
= first >}
3219 | @tab
when m_autonarrow
->
3220 if nonemptystr m_qsearch
3222 G.postRedisplay "outline list view tab";
3223 source#add_narrow_pattern m_qsearch
;
3225 coe {< m_qsearch
= E.s >}
3229 | @escape
when m_autonarrow
->
3230 if nonemptystr m_qsearch
3231 then source#add_narrow_pattern m_qsearch
;
3234 | @enter
| @kpenter
when m_autonarrow
->
3235 if nonemptystr m_qsearch
3236 then source#add_narrow_pattern m_qsearch
;
3239 | key when m_autonarrow
&& (key != 0 && key land 0xff00 != 0xff00) ->
3240 let pattern = m_qsearch ^ toutf8
key in
3241 G.postRedisplay "outlinelistview autonarrow add";
3242 source#narrow
pattern;
3243 settext true pattern;
3244 coe {< m_first
= 0; m_active
= 0; m_qsearch
= pattern >}
3246 | key when m_autonarrow
&& key = @backspace
->
3247 if emptystr m_qsearch
3250 let pattern = withoutlastutf8 m_qsearch
in
3251 G.postRedisplay "outlinelistview autonarrow backspace";
3252 ignore
(source#renarrow
);
3253 source#narrow
pattern;
3254 settext true pattern;
3255 coe {< m_first
= 0; m_active
= 0; m_qsearch
= pattern >}
3257 | @up
| @kpup
when ctrl ->
3258 navscroll (max
0 (m_first
- 1))
3260 | @down
| @kpdown
when ctrl ->
3261 navscroll (min
(source#getitemcount
- 1) (m_first
+ 1))
3263 | @up
| @kpup
-> navigate ~
-1
3264 | @down
| @kpdown
-> navigate 1
3265 | @prior
| @kpprior
-> navigate ~
-(fstate
.maxrows)
3266 | @next | @kpnext
-> navigate fstate
.maxrows
3268 | @right
| @kpright
->
3272 G.postRedisplay "outline ctrl right";
3273 {< m_pan
= m_pan
+ 1 >}
3275 else self#updownlevel
1
3279 | @left | @kpleft
->
3283 G.postRedisplay "outline ctrl left";
3284 {< m_pan
= m_pan
- 1 >}
3286 else self#updownlevel ~
-1
3290 | @home
| @kphome
->
3291 G.postRedisplay "outline home";
3292 coe {< m_first
= 0; m_active
= 0 >}
3295 let active = source#getitemcount
- 1 in
3296 let first = max
0 (active - fstate
.maxrows) in
3297 G.postRedisplay "outline end";
3298 coe {< m_active
= active; m_first
= first >}
3300 | _ -> super#
key key mask
3303 let genhistoutlines () =
3305 |> List.sort
(fun (_, c1
, _, _, _, _) (_, c2
, _, _, _, _) ->
3306 compare c2
.lastvisit c1
.lastvisit
)
3308 (fun ((path
, c, _, _, _, origin
) as hist
) ->
3309 let path = if nonemptystr origin
then origin
else path in
3310 let base = mbtoutf8
@@ Filename.basename
path in
3311 (base ^
"\000" ^
c.title
, 1, Ohistory hist
)
3316 let gotohist (path, c, bookmarks
, x, anchor, origin
) =
3317 Config.save
leavebirdseye;
3318 state
.anchor <- anchor;
3319 state
.bookmarks
<- bookmarks
;
3320 state
.origin
<- origin
;
3323 let x0, y0, x1, y1 = conf
.trimfuzz
in
3324 wcmd "trimset %d %d %d %d %d" (btod conf
.trimmargins
) x0 y0 x1 y1;
3325 reshape ~firsttime
:true state
.winw state
.winh
;
3326 opendoc path origin
;
3330 let makecheckers () =
3331 (* Based on lablGL-1.04/LablGlut/examples/lablGL/checker.ml which had
3333 converted by Issac Trotts. July 25, 2002 *)
3334 let image = GlPix.create `ubyte ~format
:`luminance ~width
:2 ~height
:2 in
3335 Raw.sets_string
(GlPix.to_raw
image) ~
pos:0 "\255\200\200\255";
3336 let id = GlTex.gen_texture
() in
3337 GlTex.bind_texture ~target
:`texture_2d
id;
3338 GlPix.store
(`unpack_alignment
1);
3339 GlTex.image2d
image;
3340 List.iter
(GlTex.parameter ~target
:`texture_2d
)
3341 [ `mag_filter `nearest
; `min_filter `nearest
];
3345 let setcheckers enabled
=
3346 match state
.checkerstexid
with
3348 if enabled
then state
.checkerstexid
<- Some
(makecheckers ())
3350 | Some checkerstexid
->
3353 GlTex.delete_texture checkerstexid
;
3354 state
.checkerstexid
<- None
;
3358 let describe_location () =
3359 let fn = page_of_y state
.y in
3360 let ln = page_of_y
(state
.y + state
.winh
- hscrollh () - 1) in
3361 let maxy = state
.maxy - (if conf
.maxhfit
then state
.winh
else 0) in
3365 else (100. *. (float state
.y /. float maxy))
3369 Printf.sprintf
"page %d of %d [%.2f%%]"
3370 (fn+1) state
.pagecount
percent
3373 "pages %d-%d of %d [%.2f%%]"
3374 (fn+1) (ln+1) state
.pagecount
percent
3377 let setpresentationmode v
=
3378 let n = page_of_y state
.y in
3379 state
.anchor <- (n, 0.0, 1.0);
3380 conf
.presentation
<- v
;
3381 if conf
.fitmodel
= FitPage
3382 then reqlayout conf
.angle conf
.fitmodel
;
3387 let btos b = if b then "@Uradical" else E.s in
3388 let showextended = ref false in
3389 let leave mode
_ = state
.mode
<- mode
in
3392 val mutable m_l
= []
3393 val mutable m_a
= E.a
3394 val mutable m_prev_uioh
= nouioh
3395 val mutable m_prev_mode
= View
3397 inherit lvsourcebase
3399 method reset prev_mode prev_uioh
=
3400 m_a
<- Array.of_list
(List.rev m_l
);
3402 m_prev_mode
<- prev_mode
;
3403 m_prev_uioh
<- prev_uioh
;
3405 method int name get
set =
3407 (name
, `
int get
, 1, Action
(
3410 try set (int_of_string
s)
3412 state
.text <- Printf.sprintf
"bad integer `%s': %s"
3416 let te = name ^
": ", E.s, None
, intentry, ondone, true in
3417 state
.mode
<- Textentry
(te, leave m_prev_mode
);
3421 method int_with_suffix name get
set =
3423 (name
, `intws get
, 1, Action
(
3426 try set (int_of_string_with_suffix
s)
3428 state
.text <- Printf.sprintf
"bad integer `%s': %s"
3433 name ^
": ", E.s, None
, intentry_with_suffix, ondone, true
3435 state
.mode
<- Textentry
(te, leave m_prev_mode
);
3439 method bool ?
(offset
=1) ?
(btos=btos) name get
set =
3441 (name
, `
bool (btos, get
), offset
, Action
(
3448 method color name get
set =
3450 (name
, `
color get
, 1, Action
(
3452 let invalid = (nan
, nan
, nan
) in
3455 try color_of_string
s
3457 state
.text <- Printf.sprintf
"bad color `%s': %s"
3464 let te = name ^
": ", E.s, None
, textentry, ondone, true in
3465 state
.text <- color_to_string
(get
());
3466 state
.mode
<- Textentry
(te, leave m_prev_mode
);
3470 method string name get
set =
3472 (name
, `
string get
, 1, Action
(
3474 let ondone s = set s in
3475 let te = name ^
": ", E.s, None
, textentry, ondone, true in
3476 state
.mode
<- Textentry
(te, leave m_prev_mode
);
3480 method colorspace name get
set =
3482 (name
, `
string get
, 1, Action
(
3486 inherit lvsourcebase
3489 m_active
<- CSTE.to_int conf
.colorspace
;
3492 method getitemcount
=
3493 Array.length
CSTE.names
3496 method exit ~uioh ~cancel ~
active ~
first ~pan
=
3497 ignore
(uioh
, first, pan
);
3498 if not cancel
then set active;
3500 method hasaction
_ = true
3504 let modehash = findkeyhash conf
"info" in
3505 coe (new listview ~zebra
:false ~helpmode
:false
3506 ~
source ~trusted
:true ~
modehash)
3509 method paxmark name get
set =
3511 (name
, `
string get
, 1, Action
(
3515 inherit lvsourcebase
3518 m_active
<- MTE.to_int conf
.paxmark
;
3521 method getitemcount
= Array.length
MTE.names
3522 method getitem
n = (MTE.names
.(n), 0)
3523 method exit ~uioh ~cancel ~
active ~
first ~pan
=
3524 ignore
(uioh
, first, pan
);
3525 if not cancel
then set active;
3527 method hasaction
_ = true
3531 let modehash = findkeyhash conf
"info" in
3532 coe (new listview ~zebra
:false ~helpmode
:false
3533 ~
source ~trusted
:true ~
modehash)
3536 method fitmodel name get
set =
3538 (name
, `
string get
, 1, Action
(
3542 inherit lvsourcebase
3545 m_active
<- FMTE.to_int conf
.fitmodel
;
3548 method getitemcount
= Array.length
FMTE.names
3549 method getitem
n = (FMTE.names
.(n), 0)
3550 method exit ~uioh ~cancel ~
active ~
first ~pan
=
3551 ignore
(uioh
, first, pan
);
3552 if not cancel
then set active;
3554 method hasaction
_ = true
3558 let modehash = findkeyhash conf
"info" in
3559 coe (new listview ~zebra
:false ~helpmode
:false
3560 ~
source ~trusted
:true ~
modehash)
3563 method caption
s offset
=
3564 m_l
<- (s, `empty
, offset
, Noaction
) :: m_l
3566 method caption2
s f offset
=
3567 m_l
<- (s, `
string f, offset
, Noaction
) :: m_l
3569 method getitemcount
= Array.length m_a
3572 let tostr = function
3573 | `
int f -> string_of_int
(f ())
3574 | `intws
f -> string_with_suffix_of_int
(f ())
3576 | `
color f -> color_to_string
(f ())
3577 | `
bool (btos, f) -> btos (f ())
3580 let name, t
, offset
, _ = m_a
.(n) in
3581 ((let s = tostr t
in
3583 then Printf.sprintf
"%s\t%s" name s
3587 method exit ~uioh ~cancel ~
active ~
first ~pan
=
3592 match m_a
.(active) with
3593 | _, _, _, Action
f -> f uioh
3594 | _, _, _, Noaction
-> uioh
3605 method hasaction
n =
3607 | _, _, _, Action
_ -> true
3608 | _, _, _, Noaction
-> false
3610 initializer m_active
<- 1
3613 let rec fillsrc prevmode prevuioh
=
3614 let sep () = src#caption
E.s 0 in
3615 let colorp name get
set =
3617 (fun () -> color_to_string
(get
()))
3620 let c = color_of_string
v in
3623 state
.text <- Printf.sprintf
"bad color `%s': %s" v @@ exntos exn
3626 let oldmode = state
.mode
in
3627 let birdseye = isbirdseye state
.mode
in
3629 src#caption
(if birdseye then "Setup (Bird's eye)" else "Setup") 0;
3631 src#
bool "presentation mode"
3632 (fun () -> conf
.presentation
)
3633 (fun v -> setpresentationmode v);
3635 src#
bool "ignore case in searches"
3636 (fun () -> conf
.icase
)
3637 (fun v -> conf
.icase
<- v);
3640 (fun () -> conf
.preload)
3641 (fun v -> conf
.preload <- v);
3643 src#
bool "highlight links"
3644 (fun () -> conf
.hlinks
)
3645 (fun v -> conf
.hlinks
<- v);
3647 src#
bool "under info"
3648 (fun () -> conf
.underinfo
)
3649 (fun v -> conf
.underinfo
<- v);
3651 src#
bool "persistent bookmarks"
3652 (fun () -> conf
.savebmarks
)
3653 (fun v -> conf
.savebmarks
<- v);
3655 src#fitmodel
"fit model"
3656 (fun () -> FMTE.to_string conf
.fitmodel
)
3657 (fun v -> reqlayout conf
.angle
(FMTE.of_int
v));
3659 src#
bool "trim margins"
3660 (fun () -> conf
.trimmargins
)
3661 (fun v -> settrim v conf
.trimfuzz
; fillsrc prevmode prevuioh
);
3663 src#
bool "persistent location"
3664 (fun () -> conf
.jumpback
)
3665 (fun v -> conf
.jumpback
<- v);
3668 src#
int "inter-page space"
3669 (fun () -> conf
.interpagespace
)
3671 conf
.interpagespace
<- n;
3672 docolumns conf
.columns
;
3674 match state
.layout with
3679 state
.maxy <- calcheight
();
3680 let y = getpagey
pageno in
3685 (fun () -> conf
.pagebias
)
3686 (fun v -> conf
.pagebias
<- v);
3688 src#
int "scroll step"
3689 (fun () -> conf
.scrollstep
)
3690 (fun n -> conf
.scrollstep
<- n);
3692 src#
int "horizontal scroll step"
3693 (fun () -> conf
.hscrollstep
)
3694 (fun v -> conf
.hscrollstep
<- v);
3696 src#
int "auto scroll step"
3698 match state
.autoscroll
with
3700 | _ -> conf
.autoscrollstep
)
3702 let n = boundastep state
.winh
n in
3703 if state
.autoscroll
<> None
3704 then state
.autoscroll
<- Some
n;
3705 conf
.autoscrollstep
<- n);
3708 (fun () -> truncate
(conf
.zoom *. 100.))
3709 (fun v -> setzoom ((float v) /. 100.));
3712 (fun () -> conf
.angle
)
3713 (fun v -> reqlayout v conf
.fitmodel
);
3715 src#
int "scroll bar width"
3716 (fun () -> conf
.scrollbw
)
3719 reshape state
.winw state
.winh
;
3722 src#
int "scroll handle height"
3723 (fun () -> conf
.scrollh
)
3724 (fun v -> conf
.scrollh
<- v;);
3726 src#
int "thumbnail width"
3727 (fun () -> conf
.thumbw
)
3729 conf
.thumbw
<- min
4096 v;
3732 leavebirdseye beye
false;
3739 let mode = state
.mode in
3740 src#
string "columns"
3742 match conf
.columns
with
3744 | Cmulti
(multi
, _) -> multicolumns_to_string multi
3745 | Csplit
(count
, _) -> "-" ^ string_of_int count
3748 let n, a, b = multicolumns_of_string
v in
3749 setcolumns mode n a b);
3752 src#caption
"Pixmap cache" 0;
3753 src#int_with_suffix
"size (advisory)"
3754 (fun () -> conf
.memlimit
)
3755 (fun v -> conf
.memlimit
<- v);
3758 (fun () -> Printf.sprintf
"%s bytes, %d tiles"
3759 (string_with_suffix_of_int state
.memused
)
3760 (Hashtbl.length state
.tilemap
)) 1;
3763 src#caption
"Layout" 0;
3764 src#caption2
"Dimension"
3766 Printf.sprintf
"%dx%d (virtual %dx%d)"
3767 state
.winw state
.winh
3772 src#caption2
"Position" (fun () ->
3773 Printf.sprintf
"%dx%d" state
.x state
.y
3776 src#caption2
"Position" (fun () -> describe_location ()) 1
3780 src#
bool ~offset
:0 ~
btos:(fun v -> if v then "(on)" else "(off)")
3781 "Save these parameters as global defaults at exit"
3782 (fun () -> conf
.bedefault
)
3783 (fun v -> conf
.bedefault
<- v)
3787 let btos b = if b then "@Ulguillemet" else "@Urguillemet" in
3788 src#
bool ~offset
:0 ~
btos "Extended parameters"
3789 (fun () -> !showextended)
3790 (fun v -> showextended := v; fillsrc prevmode prevuioh
);
3794 (fun () -> conf
.checkers
)
3795 (fun v -> conf
.checkers
<- v; setcheckers v);
3796 src#
bool "update cursor"
3797 (fun () -> conf
.updatecurs
)
3798 (fun v -> conf
.updatecurs
<- v);
3799 src#
bool "scroll-bar on the left"
3800 (fun () -> conf
.leftscroll
)
3801 (fun v -> conf
.leftscroll
<- v);
3803 (fun () -> conf
.verbose
)
3804 (fun v -> conf
.verbose
<- v);
3805 src#
bool "invert colors"
3806 (fun () -> conf
.invert
)
3807 (fun v -> conf
.invert
<- v);
3809 (fun () -> conf
.maxhfit
)
3810 (fun v -> conf
.maxhfit
<- v);
3812 (fun () -> conf
.pax
!= None
)
3815 then conf
.pax
<- Some
(ref (now
(), 0, 0))
3816 else conf
.pax
<- None
);
3817 src#
string "uri launcher"
3818 (fun () -> conf
.urilauncher
)
3819 (fun v -> conf
.urilauncher
<- v);
3820 src#
string "path launcher"
3821 (fun () -> conf
.pathlauncher
)
3822 (fun v -> conf
.pathlauncher
<- v);
3823 src#
string "tile size"
3824 (fun () -> Printf.sprintf
"%dx%d" conf
.tilew conf
.tileh
)
3827 let w, h = Scanf.sscanf
v "%dx%d" (fun w h -> w, h) in
3828 conf
.tilew
<- max
64 w;
3829 conf
.tileh
<- max
64 h;
3832 state
.text <- Printf.sprintf
"bad tile size `%s': %s"
3835 src#
int "texture count"
3836 (fun () -> conf
.texcount
)
3839 then conf
.texcount
<- v
3840 else impmsg "failed to set texture count please retry later"
3842 src#
int "slice height"
3843 (fun () -> conf
.sliceheight
)
3845 conf
.sliceheight
<- v;
3846 wcmd "sliceh %d" conf
.sliceheight
;
3848 src#
int "anti-aliasing level"
3849 (fun () -> conf
.aalevel
)
3851 conf
.aalevel
<- bound
v 0 8;
3852 state
.anchor <- getanchor
();
3853 opendoc state
.path state
.password;
3855 src#
string "page scroll scaling factor"
3856 (fun () -> string_of_float conf
.pgscale)
3859 let s = float_of_string
v in
3862 state
.text <- Printf.sprintf
3863 "bad page scroll scaling factor `%s': %s" v @@ exntos exn
3866 src#
int "ui font size"
3867 (fun () -> fstate
.fontsize
)
3868 (fun v -> setfontsize (bound
v 5 100));
3869 src#
int "hint font size"
3870 (fun () -> conf
.hfsize
)
3871 (fun v -> conf
.hfsize
<- bound
v 5 100);
3872 colorp "background color"
3873 (fun () -> conf
.bgcolor
)
3874 (fun v -> conf
.bgcolor
<- v);
3875 src#
bool "crop hack"
3876 (fun () -> conf
.crophack
)
3877 (fun v -> conf
.crophack
<- v);
3878 src#
string "trim fuzz"
3879 (fun () -> irect_to_string conf
.trimfuzz
)
3882 conf
.trimfuzz
<- irect_of_string
v;
3884 then settrim true conf
.trimfuzz
;
3886 state
.text <- Printf.sprintf
"bad irect `%s': %s" v @@ exntos exn
3888 src#
string "throttle"
3890 match conf
.maxwait
with
3891 | None
-> "show place holder if page is not ready"
3894 then "wait for page to fully render"
3896 "wait " ^ string_of_float
time
3897 ^
" seconds before showing placeholder"
3901 let f = float_of_string
v in
3903 then conf
.maxwait
<- None
3904 else conf
.maxwait
<- Some
f
3906 state
.text <- Printf.sprintf
"bad time `%s': %s" v @@ exntos exn
3908 src#
string "ghyll scroll"
3910 match conf
.ghyllscroll
with
3912 | Some nab
-> ghyllscroll_to_string nab
3915 try conf
.ghyllscroll
<- ghyllscroll_of_string
v
3918 state
.text <- Printf.sprintf
"bad ghyll `%s': %s" v msg
3920 state
.text <- Printf.sprintf
"bad ghyll `%s': %s" v @@ exntos exn
3922 src#
string "selection command"
3923 (fun () -> conf
.selcmd
)
3924 (fun v -> conf
.selcmd
<- v);
3925 src#
string "synctex command"
3926 (fun () -> conf
.stcmd
)
3927 (fun v -> conf
.stcmd
<- v);
3928 src#
string "pax command"
3929 (fun () -> conf
.paxcmd
)
3930 (fun v -> conf
.paxcmd
<- v);
3931 src#
string "ask password command"
3932 (fun () -> conf
.passcmd)
3933 (fun v -> conf
.passcmd <- v);
3934 src#
string "save path command"
3935 (fun () -> conf
.savecmd
)
3936 (fun v -> conf
.savecmd
<- v);
3937 src#colorspace
"color space"
3938 (fun () -> CSTE.to_string conf
.colorspace
)
3940 conf
.colorspace
<- CSTE.of_int
v;
3944 src#paxmark
"pax mark method"
3945 (fun () -> MTE.to_string conf
.paxmark
)
3946 (fun v -> conf
.paxmark
<- MTE.of_int
v);
3950 (fun () -> conf
.usepbo
)
3951 (fun v -> conf
.usepbo
<- v);
3952 src#
bool "mouse wheel scrolls pages"
3953 (fun () -> conf
.wheelbypage
)
3954 (fun v -> conf
.wheelbypage
<- v);
3955 src#
bool "open remote links in a new instance"
3956 (fun () -> conf
.riani
)
3957 (fun v -> conf
.riani
<- v);
3958 src#
bool "edit annotations inline"
3959 (fun () -> conf
.annotinline
)
3960 (fun v -> conf
.annotinline
<- v);
3964 src#caption
"Document" 0;
3965 List.iter
(fun (_, s) -> src#caption
s 1) state
.docinfo
;
3966 src#caption2
"Pages"
3967 (fun () -> string_of_int state
.pagecount
) 1;
3968 src#caption2
"Dimensions"
3969 (fun () -> string_of_int
(List.length state
.pdims
)) 1;
3973 src#caption
"Trimmed margins" 0;
3974 src#caption2
"Dimensions"
3975 (fun () -> string_of_int
(List.length state
.pdims
)) 1;
3979 src#caption
"OpenGL" 0;
3980 src#caption
(Printf.sprintf
"Vendor\t%s" (GlMisc.get_string `vendor
)) 1;
3981 src#caption
(Printf.sprintf
"Renderer\t%s" (GlMisc.get_string `renderer
)) 1;
3984 src#caption
"Location" 0;
3985 if nonemptystr state
.origin
3986 then src#caption
("Orign\t" ^ mbtoutf8 state
.origin
) 1;
3987 src#caption
("Path\t" ^ mbtoutf8 state
.path) 1;
3989 src#reset prevmode prevuioh
;
3994 let prevmode = state
.mode
3995 and prevuioh
= state
.uioh in
3996 fillsrc prevmode prevuioh
;
3997 let source = (src :> lvsource
) in
3998 let modehash = findkeyhash conf
"info" in
3999 state
.uioh <- coe (object (self)
4000 inherit listview ~zebra
:false ~helpmode
:false
4001 ~
source ~trusted
:true ~
modehash as super
4002 val mutable m_prevmemused
= 0
4003 method! infochanged
= function
4005 if m_prevmemused
!= state
.memused
4007 m_prevmemused
<- state
.memused
;
4008 G.postRedisplay "memusedchanged";
4010 | Pdim
-> G.postRedisplay "pdimchanged"
4011 | Docinfo
-> fillsrc prevmode prevuioh
4013 method! key key mask
=
4014 if not
(Wsi.withctrl mask
)
4017 | @left | @kpleft
-> coe (self#updownlevel ~
-1)
4018 | @right
| @kpright
-> coe (self#updownlevel
1)
4019 | _ -> super#
key key mask
4020 else super#
key key mask
4022 G.postRedisplay "info";
4028 inherit lvsourcebase
4029 method getitemcount
= Array.length state
.help
4031 let s, l, _ = state
.help
.(n) in
4034 method exit ~
uioh ~cancel ~
active ~
first ~pan
=
4038 match state
.help
.(active) with
4039 | _, _, Action
f -> Some
(f uioh)
4040 | _, _, Noaction
-> Some
uioh
4049 method hasaction
n =
4050 match state
.help
.(n) with
4051 | _, _, Action
_ -> true
4052 | _, _, Noaction
-> false
4058 let modehash = findkeyhash conf
"help" in
4060 state
.uioh <- coe (new listview
4061 ~zebra
:false ~helpmode
:true
4062 ~
source ~trusted
:true ~
modehash);
4063 G.postRedisplay "help";
4069 inherit lvsourcebase
4070 val mutable m_items
= E.a
4072 method getitemcount
= 1 + Array.length m_items
4077 else m_items
.(n-1), 0
4079 method exit ~
uioh ~cancel ~
active ~
first ~pan
=
4084 then Buffer.clear state
.errmsgs
;
4091 method hasaction
n =
4095 state
.newerrmsgs
<- false;
4096 let l = Str.split newlinere
(Buffer.contents state
.errmsgs
) in
4097 m_items
<- Array.of_list
l
4106 let source = (msgsource :> lvsource
) in
4107 let modehash = findkeyhash conf
"listview" in
4108 state
.uioh <- coe (object
4109 inherit listview ~zebra
:false ~helpmode
:false
4110 ~
source ~trusted
:false ~
modehash as super
4113 then msgsource#reset
;
4116 G.postRedisplay "msgs";
4120 let editor = getenvwithdef
"EDITOR" E.s in
4124 let tmppath = Filename.temp_file
"llpp" "note" in
4127 let oc = open_out
tmppath in
4131 let execstr = editor ^
" " ^
tmppath in
4133 match spawn
execstr [] with
4134 | (exception exn
) ->
4135 impmsg "spawn(%S) failed: %s" execstr @@ exntos exn
;
4138 match Unix.waitpid
[] pid with
4139 | (exception exn
) ->
4140 impmsg "waitpid(%d) failed: %s" pid @@ exntos exn
;
4144 | Unix.WEXITED
0 -> filecontents
tmppath
4146 impmsg "editor process(%s) exited abnormally: %d" execstr n;
4148 | Unix.WSIGNALED
n ->
4149 impmsg "editor process(%s) was killed by signal %d" execstr n;
4151 | Unix.WSTOPPED
n ->
4152 impmsg "editor(%s) process was stopped by signal %d" execstr n;
4155 match Unix.unlink
tmppath with
4156 | (exception exn
) ->
4157 impmsg "failed to ulink %S: %s" tmppath @@ exntos exn
;
4162 let enterannotmode opaque slinkindex
=
4165 inherit lvsourcebase
4166 val mutable m_text
= E.s
4167 val mutable m_items
= E.a
4169 method getitemcount
= Array.length m_items
4172 let label, _func
= m_items
.(n) in
4175 method exit ~
uioh ~cancel ~
active ~
first ~pan
=
4176 ignore
(uioh, first, pan
);
4179 let _label, func
= m_items
.(active) in
4184 method hasaction
n = nonemptystr
@@ fst m_items
.(n)
4187 let rec split accu b i
=
4189 if p = String.length
s
4190 then (String.sub
s b (p-b), unit) :: accu
4192 if (i
> 70 && s.[p] = ' '
) || s.[p] = '
\r'
|| s.[p] = '
\n'
4194 let ss = if i
= 0 then E.s else String.sub
s b i
in
4195 split ((ss, unit)::accu) (p+1) 0
4200 wcmd "freepage %s" (~
> opaque);
4202 Hashtbl.fold (fun key opaque'
accu ->
4203 if opaque'
= opaque'
4204 then key :: accu else accu) state
.pagemap
[]
4206 List.iter
(Hashtbl.remove state
.pagemap
) keys;
4211 delannot
opaque slinkindex
;
4214 let edit inline
() =
4219 modannot
opaque slinkindex
s;
4225 let mode = state
.mode in
4228 ("annotation: ", m_text
, None
, textentry, update, true),
4229 fun _ -> state
.mode <- mode);
4233 let s = getusertext m_text
in
4238 ( "[Copy]", fun () -> selstring m_text
)
4239 :: ("[Delete]", dele)
4240 :: ("[Edit]", edit conf
.annotinline
)
4242 :: split [] 0 0 |> List.rev
|> Array.of_list
4249 let s = getannotcontents
opaque slinkindex
in
4252 let source = (msgsource :> lvsource
) in
4253 let modehash = findkeyhash conf
"listview" in
4254 state
.uioh <- coe (object
4255 inherit listview ~zebra
:false ~helpmode
:false
4256 ~
source ~trusted
:false ~
modehash
4258 G.postRedisplay "enterannotmode";
4261 let gotounder under =
4262 let getpath filename
=
4264 if nonemptystr filename
4266 if Filename.is_relative filename
4268 let dir = Filename.dirname state
.path in
4270 if Filename.is_implicit
dir
4271 then Filename.concat
(Sys.getcwd
()) dir
4274 Filename.concat
dir filename
4278 if Sys.file_exists
path
4283 | Ulinkgoto
(pageno, top) ->
4287 gotopage1 pageno top;
4290 | Ulinkuri
s -> gotouri
s
4292 | Uremote
(filename
, pageno) ->
4293 let path = getpath filename
in
4298 let command = Printf.sprintf
"%s -page %d %S" !selfexec pageno path in
4299 match spawn
command [] with
4301 | (exception exn
) ->
4302 dolog
"failed to execute `%s': %s" command @@ exntos exn
4304 let anchor = getanchor
() in
4305 let ranchor = state
.path, state
.password, anchor, state
.origin
in
4306 state
.origin
<- E.s;
4307 state
.anchor <- (pageno, 0.0, 0.0);
4308 state
.ranchors
<- ranchor :: state
.ranchors
;
4311 else impmsg "cannot find %s" filename
4313 | Uremotedest
(filename
, destname
) ->
4314 let path = getpath filename
in
4319 let command = !selfexec ^
" " ^
path ^
" -dest " ^ destname
in
4320 match spawn
command [] with
4321 | (exception exn
) ->
4322 dolog
"failed to execute `%s': %s" command @@ exntos exn
4325 let anchor = getanchor
() in
4326 let ranchor = state
.path, state
.password, anchor, state
.origin
in
4327 state
.origin
<- E.s;
4328 state
.nameddest
<- destname
;
4329 state
.ranchors
<- ranchor :: state
.ranchors
;
4332 else impmsg "cannot find %s" filename
4334 | Uunexpected
_ | Ulaunch
_ | Unamed
_ | Utext
_ | Unone
-> ()
4335 | Uannotation
(opaque, slinkindex
) -> enterannotmode opaque slinkindex
4338 let gotooutline (_, _, kind
) =
4342 let (pageno, y, _) = anchor in
4344 (if conf
.presentation
then (pageno, y, 1.0) else anchor)
4348 | Ouri
uri -> gotounder (Ulinkuri
uri)
4349 | Olaunch cmd
-> gotounder (Ulaunch cmd
)
4350 | Oremote remote
-> gotounder (Uremote remote
)
4351 | Ohistory hist
-> gotohist hist
4352 | Oremotedest remotedest
-> gotounder (Uremotedest remotedest
)
4355 class outlinesoucebase fetchoutlines
= object (self)
4356 inherit lvsourcebase
4357 val mutable m_items
= E.a
4358 val mutable m_minfo
= E.a
4359 val mutable m_orig_items
= E.a
4360 val mutable m_orig_minfo
= E.a
4361 val mutable m_narrow_patterns
= []
4362 val mutable m_gen
= -1
4364 method getitemcount
= Array.length m_items
4367 let s, n, _ = m_items
.(n) in
4370 method exit ~
(uioh:uioh) ~cancel ~
active ~
(first:int) ~pan
:
4372 ignore
(uioh, first);
4374 if m_narrow_patterns
= []
4375 then m_orig_items
, m_orig_minfo
4376 else m_items
, m_minfo
4383 gotooutline m_items
.(active);
4391 method hasaction
(_:int) = true
4394 if Array.length m_items
!= Array.length m_orig_items
4397 match m_narrow_patterns
with
4399 | many
-> String.concat
"@Uellipsis" (List.rev many
)
4401 "Narrowed to " ^
s ^
" (ctrl-u to restore)"
4405 match m_narrow_patterns
with
4408 | head
:: _ -> "@Uellipsis" ^ head
4410 method narrow
pattern =
4411 match Str.regexp_case_fold
pattern with
4412 | (exception _) -> ()
4414 let rec loop accu minfo n =
4417 m_items
<- Array.of_list
accu;
4418 m_minfo
<- Array.of_list
minfo;
4421 let (s, _, _) as o = m_items
.(n) in
4423 match Str.search_forward re
s 0 with
4424 | (exception Not_found
) -> accu, minfo
4425 | first -> o :: accu, (first, Str.match_end
()) :: minfo
4427 loop accu minfo (n-1)
4429 loop [] [] (Array.length m_items
- 1)
4431 method! getminfo
= m_minfo
4434 m_orig_items
<- fetchoutlines
();
4435 m_minfo
<- m_orig_minfo
;
4436 m_items
<- m_orig_items
4438 method add_narrow_pattern
pattern =
4439 m_narrow_patterns
<- pattern :: m_narrow_patterns
4441 method del_narrow_pattern
=
4442 match m_narrow_patterns
with
4443 | _ :: rest
-> m_narrow_patterns
<- rest
4448 match m_narrow_patterns
with
4449 | pattern :: [] -> self#narrow
pattern; pattern
4451 List.fold_left
(fun accu pattern ->
4452 self#narrow
pattern;
4453 pattern ^
"@Uellipsis" ^
accu) E.s list
4455 method calcactive
(_:anchor) = 0
4457 method reset
anchor items =
4458 if state
.gen
!= m_gen
4460 m_orig_items
<- items;
4462 m_narrow_patterns
<- [];
4464 m_orig_minfo
<- E.a;
4468 if items != m_orig_items
4470 m_orig_items
<- items;
4471 if m_narrow_patterns
== []
4472 then m_items
<- items;
4475 let active = self#calcactive
anchor in
4477 m_first
<- firstof m_first
active
4481 let outlinesource fetchoutlines
=
4483 inherit outlinesoucebase fetchoutlines
4484 method! calcactive
anchor =
4485 let rely = getanchory anchor in
4486 let rec loop n best bestd
=
4487 if n = Array.length m_items
4490 let _, _, kind
= m_items
.(n) in
4493 let orely = getanchory anchor in
4494 let d = abs
(orely - rely) in
4497 else loop (n+1) best bestd
4498 | Onone
| Oremote
_ | Olaunch
_
4499 | Oremotedest
_ | Ouri
_ | Ohistory
_ ->
4500 loop (n+1) best bestd
4506 let enteroutlinemode, enterbookmarkmode
, enterhistmode
=
4507 let mkselector sourcetype
=
4508 let fetchoutlines () =
4509 match sourcetype
with
4510 | `bookmarks
-> Array.of_list state
.bookmarks
4511 | `outlines
-> state
.outlines
4512 | `history
-> genhistoutlines ()
4515 if sourcetype
= `history
4516 then new outlinesoucebase
fetchoutlines
4517 else outlinesource fetchoutlines
4520 let outlines = fetchoutlines () in
4521 if Array.length
outlines = 0
4523 showtext ' ' errmsg
;
4527 Wsi.setcursor
Wsi.CURSOR_INHERIT
;
4528 let anchor = getanchor
() in
4529 source#reset
anchor outlines;
4530 state
.text <- source#greetmsg
;
4532 coe (new outlinelistview ~zebra
:(sourcetype
=`history
) ~
source);
4533 G.postRedisplay "enter selector";
4536 let mkenter sourcetype errmsg
=
4537 let enter = mkselector sourcetype
in
4538 fun () -> enter errmsg
4540 (**)mkenter `
outlines "document has no outline"
4541 , mkenter `bookmarks
"document has no bookmarks (yet)"
4542 , mkenter `history
"history is empty"
4545 let quickbookmark ?title
() =
4546 match state
.layout with
4552 let tm = Unix.localtime
(now
()) in
4554 "Quick (page %d) (bookmarked at %02d/%02d/%d %02d:%02d)"
4558 (tm.Unix.tm_year
+ 1900)
4561 | Some
title -> title
4563 state
.bookmarks
<- (title, 0, Oanchor
(getanchor1
l)) :: state
.bookmarks
4566 let setautoscrollspeed step goingdown
=
4567 let incr = max
1 ((abs step
) / 2) in
4568 let incr = if goingdown
then incr else -incr in
4569 let astep = boundastep state
.winh
(step
+ incr) in
4570 state
.autoscroll
<- Some
astep;
4574 match conf
.columns
with
4576 | Csingle
_ | Cmulti
_ -> state
.x != 0 || conf
.zoom > 1.0
4579 let panbound x = bound
x (-state
.w) (wadjsb () + state
.winw
);;
4581 let existsinrow pageno (columns
, coverA
, coverB
) p =
4582 let last = ((pageno - coverA
) mod columns
) + columns
in
4583 let rec any = function
4586 if l.pageno = coverA
- 1 || l.pageno = state
.pagecount
- coverB
4590 then (if l.pageno = last then false else any rest
)
4598 match state
.layout with
4600 let pageno = page_of_y state
.y in
4601 gotoghyll (getpagey
(pageno+1))
4603 match conf
.columns
with
4605 if conf
.presentation
&& rest
== [] && l.pageh
> l.pagey + l.pagevh
4607 let y = clamp (pgscale state
.winh
) in
4610 let pageno = min
(l.pageno+1) (state
.pagecount
-1) in
4611 gotoghyll (getpagey
pageno)
4612 | Cmulti
((c, _, _) as cl, _) ->
4613 if conf
.presentation
4614 && (existsinrow l.pageno cl
4615 (fun l -> l.pageh
> l.pagey + l.pagevh))
4617 let y = clamp (pgscale state
.winh
) in
4620 let pageno = min
(l.pageno+c) (state
.pagecount
-1) in
4621 gotoghyll (getpagey
pageno)
4623 if l.pageno < state
.pagecount
- 1 || l.pagecol
< n - 1
4625 let pagey, pageh
= getpageyh
l.pageno in
4626 let pagey = pagey + pageh
* l.pagecol
in
4627 let ips = if l.pagecol
= 0 then 0 else conf
.interpagespace
in
4628 gotoghyll (pagey + pageh
+ ips)
4632 match state
.layout with
4634 let pageno = page_of_y state
.y in
4635 gotoghyll (getpagey
(pageno-1))
4637 match conf
.columns
with
4639 if conf
.presentation
&& l.pagey != 0
4641 gotoghyll (clamp (pgscale ~
-(state
.winh
)))
4643 let pageno = max
0 (l.pageno-1) in
4644 gotoghyll (getpagey
pageno)
4645 | Cmulti
((c, _, coverB
) as cl, _) ->
4646 if conf
.presentation
&&
4647 (existsinrow l.pageno cl (fun l -> l.pagey != 0))
4649 gotoghyll (clamp (pgscale ~
-(state
.winh
)))
4652 if l.pageno = state
.pagecount
- coverB
4656 let pageno = max
0 (l.pageno-decr) in
4657 gotoghyll (getpagey
pageno)
4665 let pageno = max
0 (l.pageno-1) in
4666 let pagey, pageh
= getpageyh
pageno in
4669 let pagey, pageh
= getpageyh
l.pageno in
4670 pagey + pageh
* (l.pagecol
-1) - conf
.interpagespace
4676 if emptystr conf
.savecmd
4677 then error
"don't know where to save modified document"
4679 let savecmd = Str.global_replace percentsre state
.path conf
.savecmd in
4682 (fun s -> error
"failed to obtain path to the saved copy: %s" s)
4687 let tmp = path ^
".tmp" in
4689 Unix.rename
tmp path;
4692 let viewkeyboard key mask
=
4694 let mode = state
.mode in
4695 state
.mode <- Textentry
(te, fun _ -> state
.mode <- mode);
4698 G.postRedisplay "view:enttext"
4700 let ctrl = Wsi.withctrl mask
in
4702 if key >= 0xffb0 && key < 0xffb9 then key - 0xffb0 + 48 else key
4708 if hasunsavedchanges
()
4712 if conf
.angle
mod 360 = 0 && not
(isbirdseye state
.mode)
4714 state
.mode <- LinkNav
(Ltgendir
0);
4717 else impmsg "keyboard link navigation does not work under rotation"
4720 begin match state
.mstate
with
4723 G.postRedisplay "kill rect";
4726 | Mscrolly
| Mscrollx
4729 begin match state
.mode with
4732 G.postRedisplay "esc leave linknav"
4736 match state
.ranchors
with
4738 | (path, password, anchor, origin
) :: rest
->
4739 state
.ranchors
<- rest
;
4740 state
.anchor <- anchor;
4741 state
.origin
<- origin
;
4742 state
.nameddest
<- E.s;
4743 opendoc path password
4748 gotoghyll (getnav ~
-1)
4759 Hashtbl.iter
(fun _ opaque ->
4761 Hashtbl.clear state
.prects
) state
.pagemap
;
4762 G.postRedisplay "dehighlight";
4764 | @slash
| @question
->
4765 let ondone isforw
s =
4766 cbput state
.hists
.pat
s;
4767 state
.searchpattern
<- s;
4770 let s = String.make
1 (Char.chr
key) in
4771 enttext (s, E.s, Some
(onhist state
.hists
.pat
),
4772 textentry, ondone (key = @slash
), true)
4774 | @plus
| @kpplus
| @equals
when ctrl ->
4775 let incr = if conf
.zoom +. 0.01 > 0.1 then 0.1 else 0.01 in
4776 setzoom (conf
.zoom +. incr)
4778 | @plus
| @kpplus
->
4781 try int_of_string
s with exc
->
4782 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exc
;
4788 state
.text <- "page bias is now " ^ string_of_int
n;
4791 enttext ("page bias: ", E.s, None
, intentry, ondone, true)
4793 | @minus
| @kpminus
when ctrl ->
4794 let decr = if conf
.zoom -. 0.1 < 0.1 then 0.01 else 0.1 in
4795 setzoom (max
0.01 (conf
.zoom -. decr))
4797 | @minus
| @kpminus
->
4798 let ondone msg
= state
.text <- msg
in
4800 "option [acfhilpstvxACFPRSZTISM]: ", E.s, None
,
4801 optentry state
.mode, ondone, true
4812 | (@1 | @2) when ctrl && conf
.fitmodel
!= FitPage
-> (* ctrl-1/2 *)
4814 match conf
.columns
with
4815 | Csingle
_ | Cmulti
_ -> 1
4816 | Csplit
(n, _) -> n
4818 let h = state
.winh
-
4819 conf
.interpagespace
lsl (if conf
.presentation
then 1 else 0)
4821 let zoom = zoomforh state
.winw
h (vscrollw ()) cols in
4822 if zoom > 0.0 && (key = @2 || zoom < 1.0)
4827 match conf
.fitmodel
with
4828 | FitWidth
-> FitProportional
4829 | FitProportional
-> FitPage
4830 | FitPage
-> FitWidth
4832 state
.text <- "fit model: " ^
FMTE.to_string
fm;
4833 reqlayout conf
.angle
fm
4835 | @4 when ctrl -> (* ctrl-4 *)
4836 let zoom = getmaxw
() /. float state
.winw
in
4837 if zoom > 0.0 then setzoom zoom
4845 | (48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57)
4846 when not
ctrl -> (* 0..9 *)
4849 try int_of_string
s with exc
->
4850 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exc
;
4856 cbput state
.hists
.pag
(string_of_int
n);
4857 gotopage1 (n + conf
.pagebias
- 1) 0;
4860 let pageentry text key =
4861 match Char.unsafe_chr
key with
4862 | '
g'
-> TEdone
text
4863 | _ -> intentry text key
4865 let text = String.make
1 (Char.chr
key) in
4866 enttext (":", text, Some
(onhist state
.hists
.pag
),
4867 pageentry, ondone, true)
4870 conf
.scrollb
<- if conf
.scrollb
= 0 then (scrollbvv
lor scrollbhv
) else 0;
4871 reshape state
.winw state
.winh
;
4874 state
.bzoom
<- not state
.bzoom
;
4876 showtext ' '
("block zoom " ^
if state
.bzoom
then "on" else "off")
4879 conf
.hlinks
<- not conf
.hlinks
;
4880 state
.text <- "highlightlinks " ^
if conf
.hlinks
then "on" else "off";
4881 G.postRedisplay "toggle highlightlinks";
4884 if conf
.angle
mod 360 = 0
4886 state
.glinks
<- true;
4887 let mode = state
.mode in
4890 (":", E.s, None
, linknentry, linknact gotounder, false),
4892 state
.glinks
<- false;
4896 G.postRedisplay "view:linkent(F)"
4898 else impmsg "hint mode does not work under rotation"
4901 state
.glinks
<- true;
4902 let mode = state
.mode in
4903 state
.mode <- Textentry
(
4905 ":", E.s, None
, linknentry, linknact (fun under ->
4906 selstring (undertext under);
4910 state
.glinks
<- false;
4914 G.postRedisplay "view:linkent"
4917 begin match state
.autoscroll
with
4919 conf
.autoscrollstep
<- step
;
4920 state
.autoscroll
<- None
4922 if conf
.autoscrollstep
= 0
4923 then state
.autoscroll
<- Some
1
4924 else state
.autoscroll
<- Some conf
.autoscrollstep
4928 launchpath () (* XXX where do error messages go? *)
4931 setpresentationmode (not conf
.presentation
);
4932 showtext ' '
("presentation mode " ^
4933 if conf
.presentation
then "on" else "off");
4936 if List.mem
Wsi.Fullscreen state
.winstate
4937 then Wsi.reshape conf
.cwinw conf
.cwinh
4938 else Wsi.fullscreen
()
4941 search state
.searchpattern
false
4944 search state
.searchpattern
true
4947 begin match state
.layout with
4950 gotoghyll (getpagey
l.pageno)
4956 | @delete
| @kpdelete
-> (* delete *)
4960 showtext ' '
(describe_location ());
4963 begin match state
.layout with
4966 Wsi.reshape (l.pagew
+ vscrollw ()) l.pageh
;
4971 enterbookmarkmode
()
4979 | @e when Buffer.length state
.errmsgs
> 0 ->
4984 match state
.layout with
4989 (s, 0, Oanchor
(getanchor1
l)) :: state
.bookmarks
4992 enttext ("bookmark: ", E.s, None
, textentry, ondone, true)
4996 showtext ' '
"Quick bookmark added";
4999 begin match state
.layout with
5001 let rect = getpdimrect
l.pagedimno
in
5005 (truncate
(1.8 *. (rect.(1) -. rect.(0))),
5006 truncate
(1.2 *. (rect.(3) -. rect.(0))))
5008 (truncate
(rect.(1) -. rect.(0)),
5009 truncate
(rect.(3) -. rect.(0)))
5011 let w = truncate
((float w)*.conf
.zoom)
5012 and h = truncate
((float h)*.conf
.zoom) in
5015 state
.anchor <- getanchor
();
5016 Wsi.reshape (w + vscrollw ()) (h + conf
.interpagespace
)
5018 G.postRedisplay "z";
5023 | @x -> state
.roam
()
5026 reqlayout (conf
.angle
+
5027 (if key = @Gt
then 30 else -30)) conf
.fitmodel
5031 bound
(conf
.colorscale
+. (if key = 93 then 0.1 else -0.1)) 0.0 1.0
5033 G.postRedisplay "brightness";
5035 | @c when state
.mode = View
->
5040 let m = (wadjsb () + state
.winw
- state
.w) / 2 in
5042 gotoy_and_clear_text state
.y
5046 match state
.prevcolumns
with
5047 | None
-> (1, 0, 0), 1.0
5048 | Some
(columns
, z
) ->
5051 | Csplit
(c, _) -> -c, 0, 0
5052 | Cmulti
((c, a, b), _) -> c, a, b
5053 | Csingle
_ -> 1, 0, 0
5057 setcolumns View
c a b;
5060 | @down
| @up
when ctrl && Wsi.withshift mask
->
5061 let zoom, x = state
.prevzoom
in
5065 | @k
| @up
| @kpup
->
5066 begin match state
.autoscroll
with
5068 begin match state
.mode with
5069 | Birdseye beye
-> upbirdseye 1 beye
5074 then gotoy_and_clear_text (clamp ~
-(state
.winh
/2))
5076 if not
(Wsi.withshift mask
) && conf
.presentation
5078 else gotoghyll1 true (clamp (-conf
.scrollstep
))
5082 setautoscrollspeed n false
5085 | @j
| @down
| @kpdown
->
5086 begin match state
.autoscroll
with
5088 begin match state
.mode with
5089 | Birdseye beye
-> downbirdseye 1 beye
5094 then gotoy_and_clear_text (clamp (state
.winh
/2))
5096 if not
(Wsi.withshift mask
) && conf
.presentation
5098 else gotoghyll1 true (clamp (conf
.scrollstep
))
5102 setautoscrollspeed n true
5105 | @left | @right
| @kpleft
| @kpright
when not
(Wsi.withalt mask
) ->
5111 else conf
.hscrollstep
5113 let dx = if key = @left || key = @kpleft
then dx else -dx in
5114 state
.x <- panbound (state
.x + dx);
5115 gotoy_and_clear_text state
.y
5118 G.postRedisplay "left/right"
5121 | @prior
| @kpprior
->
5125 match state
.layout with
5127 | l :: _ -> state
.y - l.pagey
5129 clamp (pgscale (-state
.winh
))
5133 | @next | @kpnext
->
5137 match List.rev state
.layout with
5139 | l :: _ -> getpagey
l.pageno
5141 clamp (pgscale state
.winh
)
5145 | @g | @home
| @kphome
->
5148 | @G
| @jend
| @kpend
->
5150 gotoghyll (clamp state
.maxy)
5152 | @right
| @kpright
when Wsi.withalt mask
->
5153 gotoghyll (getnav 1)
5154 | @left | @kpleft
when Wsi.withalt mask
->
5155 gotoghyll (getnav ~
-1)
5160 | @v when conf
.debug
->
5163 match getopaque l.pageno with
5166 let x0, y0, x1, y1 = pagebbox
opaque in
5167 let a,b = float x0, float y0 in
5168 let c,d = float x1, float y0 in
5169 let e,f = float x1, float y1 in
5170 let h,j
= float x0, float y1 in
5171 let rect = (a,b,c,d,e,f,h,j
) in
5173 let color = (0.0, 0.0, 1.0 /. (l.pageno mod 3 |> float), 0.5) in
5174 state
.rects
<- (l.pageno, color, rect) :: state
.rects
;
5176 G.postRedisplay "v";
5179 let mode = state
.mode in
5180 let cmd = ref E.s in
5181 let onleave = function
5182 | Cancel
-> state
.mode <- mode
5185 match getopaque l.pageno with
5186 | Some
opaque -> pipesel opaque !cmd
5187 | None
-> ()) state
.layout;
5191 cbput state
.hists
.sel
s;
5195 "| ", !cmd, Some
(onhist state
.hists
.sel
), textentry, ondone, true
5197 G.postRedisplay "|";
5198 state
.mode <- Textentry
(te, onleave);
5201 vlog "huh? %s" (Wsi.keyname
key)
5204 let linknavkeyboard key mask
linknav =
5205 let getpage pageno =
5206 let rec loop = function
5208 | l :: _ when l.pageno = pageno -> Some
l
5209 | _ :: rest
-> loop rest
5210 in loop state
.layout
5212 let doexact (pageno, n) =
5213 match getopaque pageno, getpage pageno with
5214 | Some
opaque, Some
l ->
5215 if key = @enter || key = @kpenter
5217 let under = getlink
opaque n in
5218 G.postRedisplay "link gotounder";
5225 Some
(findlink
opaque LDfirst
), -1
5228 Some
(findlink
opaque LDlast
), 1
5231 Some
(findlink
opaque (LDleft
n)), -1
5234 Some
(findlink
opaque (LDright
n)), 1
5237 Some
(findlink
opaque (LDup
n)), -1
5240 Some
(findlink
opaque (LDdown
n)), 1
5245 begin match findpwl
l.pageno dir with
5249 state
.mode <- LinkNav
(Ltgendir
dir);
5250 let y, h = getpageyh
pageno in
5253 then y + h - state
.winh
5258 begin match getopaque pageno, getpage pageno with
5259 | Some
opaque, Some
_ ->
5261 let ld = if dir > 0 then LDfirst
else LDlast
in
5264 begin match link with
5266 showlinktype (getlink
opaque m);
5267 state
.mode <- LinkNav
(Ltexact
(pageno, m));
5268 G.postRedisplay "linknav jpage";
5269 | Lnotfound
-> notfound dir
5275 begin match opt with
5276 | Some Lnotfound
-> pwl l dir;
5277 | Some
(Lfound
m) ->
5281 let _, y0, _, y1 = getlinkrect
opaque m in
5283 then gotopage1 l.pageno y0
5285 let d = fstate
.fontsize
+ 1 in
5286 if y1 - l.pagey > l.pagevh - d
5287 then gotopage1 l.pageno (y1 - state
.winh
- hscrollh () + d)
5288 else G.postRedisplay "linknav";
5290 showlinktype (getlink
opaque m);
5291 state
.mode <- LinkNav
(Ltexact
(l.pageno, m));
5294 | None
-> viewkeyboard key mask
5296 | _ -> viewkeyboard key mask
5301 G.postRedisplay "leave linknav"
5305 | Ltgendir
_ | Ltnotready
_ -> viewkeyboard key mask
5306 | Ltexact exact
-> doexact exact
5309 let keyboard key mask
=
5310 if (key = @g && Wsi.withctrl mask
) && not
(istextentry state
.mode)
5311 then wcmd "interrupt"
5312 else state
.uioh <- state
.uioh#
key key mask
5315 let birdseyekeyboard key mask
5316 ((oconf
, leftx
, pageno, hooverpageno
, anchor) as beye
) =
5318 match conf
.columns
with
5320 | Cmulti
((c, _, _), _) -> c
5321 | Csplit
_ -> failwith
"bird's eye split mode"
5323 let pgh layout = List.fold_left
5324 (fun m l -> max
l.pageh
m) state
.winh
layout in
5326 | @l when Wsi.withctrl mask
->
5327 let y, h = getpageyh
pageno in
5328 let top = (state
.winh
- h) / 2 in
5329 gotoy (max
0 (y - top))
5330 | @enter | @kpenter
-> leavebirdseye beye
false
5331 | @escape
-> leavebirdseye beye
true
5332 | @up
-> upbirdseye incr beye
5333 | @down
-> downbirdseye incr beye
5334 | @left -> upbirdseye 1 beye
5335 | @right
-> downbirdseye 1 beye
5338 begin match state
.layout with
5342 state
.mode <- Birdseye
(
5343 oconf
, leftx
, l.pageno, hooverpageno
, anchor
5345 gotopage1 l.pageno 0;
5348 let layout = layout state
.x (state
.y-state
.winh
)
5350 (pgh state
.layout) in
5352 | [] -> gotoy (clamp (-state
.winh
))
5354 state
.mode <- Birdseye
(
5355 oconf
, leftx
, l.pageno, hooverpageno
, anchor
5357 gotopage1 l.pageno 0
5360 | [] -> gotoy (clamp (-state
.winh
))
5364 begin match List.rev state
.layout with
5366 let layout = layout state
.x
5367 (state
.y + (pgh state
.layout))
5368 state
.winw state
.winh
in
5369 begin match layout with
5371 let incr = l.pageh
- l.pagevh in
5376 oconf
, leftx
, state
.pagecount
- 1, hooverpageno
, anchor
5378 G.postRedisplay "birdseye pagedown";
5380 else gotoy (clamp (incr + conf
.interpagespace
*2));
5384 Birdseye
(oconf
, leftx
, l.pageno, hooverpageno
, anchor);
5385 gotopage1 l.pageno 0;
5388 | [] -> gotoy (clamp state
.winh
)
5392 state
.mode <- Birdseye
(oconf
, leftx
, 0, hooverpageno
, anchor);
5396 let pageno = state
.pagecount
- 1 in
5397 state
.mode <- Birdseye
(oconf
, leftx
, pageno, hooverpageno
, anchor);
5398 if not
(pagevisible state
.layout pageno)
5401 match List.rev state
.pdims
with
5403 | (_, _, h, _) :: _ -> h
5405 gotoy (max
0 (getpagey
pageno - (state
.winh
- h - conf
.interpagespace
)))
5406 else G.postRedisplay "birdseye end";
5408 | _ -> viewkeyboard key mask
5413 match state
.mode with
5414 | Textentry
_ -> scalecolor 0.4
5416 | View
-> scalecolor 1.0
5417 | Birdseye
(_, _, pageno, hooverpageno
, _) ->
5418 if l.pageno = hooverpageno
5421 if l.pageno = pageno
5423 let c = scalecolor 1.0 in
5425 GlDraw.line_width
3.0;
5426 let dispx = xadjsb () + l.pagedispx in
5428 (float (dispx-1)) (float (l.pagedispy-1))
5429 (float (dispx+l.pagevw+1))
5430 (float (l.pagedispy+l.pagevh+1))
5432 GlDraw.line_width
1.0;
5441 let postdrawpage l linkindexbase
=
5442 match getopaque l.pageno with
5444 if tileready l l.pagex
l.pagey
5446 let x = l.pagedispx - l.pagex
+ xadjsb ()
5447 and y = l.pagedispy - l.pagey in
5449 match conf
.columns
with
5450 | Csingle
_ | Cmulti
_ ->
5451 (if conf
.hlinks
then 1 else 0)
5453 && not
(isbirdseye state
.mode) then 2 else 0)
5457 match state
.mode with
5458 | Textentry
((_, s, _, _, _, _), _) when state
.glinks
-> s
5464 Hashtbl.find_all state
.prects
l.pageno |>
5465 List.iter
(fun vals
-> drawprect
opaque x y vals
);
5466 postprocess
opaque hlmask x y (linkindexbase
, s, conf
.hfsize
);
5471 let scrollindicator () =
5472 let sbw, ph
, sh = state
.uioh#
scrollph in
5473 let sbh, pw, sw = state
.uioh#scrollpw
in
5478 else ((state
.winw
- sbw), state
.winw
, 0)
5481 GlDraw.color (0.64, 0.64, 0.64);
5482 filledrect (float x0) 0. (float x1) (float state
.winh
);
5484 (float hx0
) (float (state
.winh
- sbh))
5485 (float (hx0
+ wadjsb () + state
.winw
)) (float state
.winh
)
5487 GlDraw.color (0.0, 0.0, 0.0);
5489 filledrect (float x0) ph
(float x1) (ph
+. sh);
5490 let pw = pw +. float hx0
in
5491 filledrect pw (float (state
.winh
- sbh)) (pw +. sw) (float state
.winh
);
5495 match state
.mstate
with
5496 | Mnone
| Mscrolly
| Mscrollx
| Mpan
_ | Mzoom
_ | Mzoomrect
_ ->
5499 | Msel
((x0, y0), (x1, y1)) ->
5500 let identify opaque l px py = Some
(opaque, l.pageno, px, py) in
5501 let o0,n0
,px0
,py0
= onppundermouse identify x0 y0 (~
< E.s, -1, 0, 0) in
5502 let _o1,n1
,px1
,py1
= onppundermouse identify x1 y1 (~
< E.s, -1, 0, 0) in
5503 if n0
!= -1 && n0
= n1
then seltext
o0 (px0
, py0
, px1
, py1
);
5506 let showrects = function [] -> () | rects
->
5508 GlDraw.color (0.0, 0.0, 1.0) ~
alpha:0.5;
5509 GlFunc.blend_func ~
src:`src_alpha ~dst
:`one_minus_src_alpha
;
5511 (fun (pageno, c, (x0, y0, x1, y1, x2
, y2
, x3
, y3
)) ->
5513 if l.pageno = pageno
5515 let dx = float (l.pagedispx - l.pagex
) in
5516 let dy = float (l.pagedispy - l.pagey) in
5517 let r, g, b, alpha = c in
5518 GlDraw.color (r, g, b) ~
alpha;
5519 Raw.sets_float state
.vraw ~
pos:0
5524 GlArray.vertex `two state
.vraw
;
5525 GlArray.draw_arrays `triangle_strip ~
first:0 ~count
:4;
5534 GlClear.color (scalecolor2 conf
.bgcolor
);
5535 GlClear.clear
[`
color];
5536 List.iter
drawpage state
.layout;
5538 match state
.mode with
5539 | LinkNav
(Ltexact
(pageno, linkno
)) ->
5540 begin match getopaque pageno with
5542 let dx = xadjsb () in
5543 let x0, y0, x1, y1 = getlinkrect
opaque linkno
in
5544 let x0 = x0 + dx and x1 = x1 + dx in
5545 let color = (0.0, 0.0, 0.5, 0.5) in
5552 | None
-> state
.rects
5554 | LinkNav
(Ltgendir
_) | LinkNav
(Ltnotready
_)
5557 | View
-> state
.rects
5560 let rec postloop linkindexbase
= function
5562 let linkindexbase = linkindexbase + postdrawpage l linkindexbase in
5563 postloop linkindexbase rest
5567 postloop 0 state
.layout;
5569 begin match state
.mstate
with
5570 | Mzoomrect
((x0, y0), (x1, y1)) ->
5572 GlDraw.color (0.3, 0.3, 0.3) ~
alpha:0.5;
5573 GlFunc.blend_func ~
src:`src_alpha ~dst
:`one_minus_src_alpha
;
5574 filledrect (float x0) (float y0) (float x1) (float y1);
5578 | Mscrolly
| Mscrollx
5587 let zoomrect x y x1 y1 =
5590 and y0 = min
y y1 in
5591 gotoy (state
.y + y0);
5592 state
.anchor <- getanchor
();
5593 let zoom = (float state
.w) /. float (x1 - x0) in
5596 let adjw = wadjsb () + state
.winw
in
5598 then (adjw - state
.w) / 2
5601 match conf
.fitmodel
with
5602 | FitWidth
| FitProportional
-> simple ()
5604 match conf
.columns
with
5606 onppundermouse (fun _ l _ _ -> Some
l.pagedispx) x0 y0 x0
5607 | Cmulti
_ | Csingle
_ -> simple ()
5609 state
.x <- (state
.x + margin) - x0;
5614 let annot inline
x y =
5615 match unproject x y with
5616 | Some
(opaque, n, ux
, uy
) ->
5618 addannot
opaque ux uy
text;
5619 wcmd "freepage %s" (~
> opaque);
5620 Hashtbl.remove state
.pagemap
(n, state
.gen
);
5626 let ondone s = add s in
5627 let mode = state
.mode in
5628 state
.mode <- Textentry
(
5629 ("annotation: ", E.s, None
, textentry, ondone, true),
5630 fun _ -> state
.mode <- mode);
5633 G.postRedisplay "annot"
5635 add @@ getusertext E.s
5640 let g opaque l px py =
5641 match rectofblock
opaque px py with
5643 let x0 = a.(0) -. 20. in
5644 let x1 = a.(1) +. 20. in
5645 let y0 = a.(2) -. 20. in
5646 let zoom = (float state
.w) /. (x1 -. x0) in
5647 let pagey = getpagey
l.pageno in
5648 gotoy_and_clear_text (pagey + truncate
y0);
5649 state
.anchor <- getanchor
();
5650 let margin = (state
.w - l.pagew
)/2 in
5651 state
.x <- -truncate
x0 - margin;
5656 match conf
.columns
with
5658 impmsg "block zooming does not work properly in split columns mode"
5659 | Cmulti
_ | Csingle
_ -> onppundermouse g x y ()
5663 let winw = wadjsb () + state
.winw - 1 in
5664 let s = float x /. float winw in
5665 let destx = truncate
(float (state
.w + winw) *. s) in
5666 state
.x <- winw - destx;
5667 gotoy_and_clear_text state
.y;
5668 state
.mstate
<- Mscrollx
;
5672 let s = float y /. float state
.winh
in
5673 let desty = truncate
(float (state
.maxy - state
.winh
) *. s) in
5674 gotoy_and_clear_text desty;
5675 state
.mstate
<- Mscrolly
;
5678 let viewmulticlick clicks
x y mask
=
5679 let g opaque l px py =
5687 if markunder
opaque px py mark
5691 match getopaque l.pageno with
5693 | Some
opaque -> pipesel opaque cmd
5695 state
.roam
<- (fun () -> dopipe conf
.paxcmd
);
5696 if not
(Wsi.withctrl mask
) then dopipe conf
.selcmd
;
5701 G.postRedisplay "viewmulticlick";
5702 onppundermouse g x y (fun () -> impmsg "nothing to select") ();
5706 match conf
.columns
with
5708 | Csingle
_ | Cmulti
_ -> conf
.angle
mod 360 = 0
5711 let viewmouse button down
x y mask
=
5713 | n when (n == 4 || n == 5) && not down
->
5714 if Wsi.withctrl mask
5716 match state
.mstate
with
5717 | Mzoom
(oldn
, i
) ->
5725 if conf
.zoom +. 0.01 > 0.1 then 0.1 else 0.01
5727 if conf
.zoom -. 0.1 < 0.1 then -0.01 else -0.1
5729 let zoom = conf
.zoom -. incr in
5731 state
.mstate
<- Mzoom
(n, 0);
5733 state
.mstate
<- Mzoom
(n, i
+1);
5735 else state
.mstate
<- Mzoom
(n, 0)
5739 | Mscrolly
| Mscrollx
5741 | Mnone
-> state
.mstate
<- Mzoom
(n, 0)
5744 match state
.autoscroll
with
5745 | Some step
-> setautoscrollspeed step
(n=4)
5747 if conf
.wheelbypage
|| conf
.presentation
5756 then -conf
.scrollstep
5757 else conf
.scrollstep
5759 let incr = incr * 2 in
5760 let y = clamp incr in
5761 gotoy_and_clear_text y
5764 | n when (n = 6 || n = 7) && not down
&& canpan () ->
5766 panbound (state
.x + (if n = 7 then -2 else 2) * conf
.hscrollstep
);
5767 gotoy_and_clear_text state
.y
5769 | 1 when Wsi.withshift mask
->
5770 state
.mstate
<- Mnone
;
5773 match unproject x y with
5775 | Some
(_, pageno, ux
, uy
) ->
5776 let cmd = Printf.sprintf
5778 conf
.stcmd state
.path pageno ux uy
5780 match spawn
cmd [] with
5781 | (exception exn
) ->
5782 impmsg "execution of synctex command(%S) failed: %S"
5783 conf
.stcmd
@@ exntos exn
5787 | 1 when Wsi.withctrl mask
->
5790 Wsi.setcursor
Wsi.CURSOR_FLEUR
;
5791 state
.mstate
<- Mpan
(x, y)
5794 state
.mstate
<- Mnone
5799 if Wsi.withshift mask
5801 annot conf
.annotinline
x y;
5802 G.postRedisplay "addannot"
5806 Wsi.setcursor
Wsi.CURSOR_CYCLE
;
5807 state
.mstate
<- Mzoomrect
(p, p)
5810 match state
.mstate
with
5811 | Mzoomrect
((x0, y0), _) ->
5812 if abs
(x-x0) > 10 && abs
(y - y0) > 10
5813 then zoomrect x0 y0 x y
5816 G.postRedisplay "kill accidental zoom rect";
5820 | Mscrolly
| Mscrollx
5826 | 1 when vscrollhit x ->
5829 let _, position, sh = state
.uioh#
scrollph in
5830 if y > truncate
position && y < truncate
(position +. sh)
5831 then state
.mstate
<- Mscrolly
5834 state
.mstate
<- Mnone
5836 | 1 when y > state
.winh
- hscrollh () ->
5839 let _, position, sw = state
.uioh#scrollpw
in
5840 if x > truncate
position && x < truncate
(position +. sw)
5841 then state
.mstate
<- Mscrollx
5844 state
.mstate
<- Mnone
5846 | 1 when state
.bzoom
-> if not down
then zoomblock x y
5849 let dest = if down
then getunder x y else Unone
in
5850 begin match dest with
5853 | Uremote
_ | Uremotedest
_
5854 | Uunexpected
_ | Ulaunch
_ | Unamed
_ ->
5857 | Unone
when down
->
5858 Wsi.setcursor
Wsi.CURSOR_FLEUR
;
5859 state
.mstate
<- Mpan
(x, y);
5861 | Uannotation
(opaque, slinkindex
) -> enterannotmode opaque slinkindex
5863 | Unone
| Utext
_ ->
5868 state
.mstate
<- Msel
((x, y), (x, y));
5869 G.postRedisplay "mouse select";
5873 match state
.mstate
with
5876 | Mzoom
_ | Mscrollx
| Mscrolly
->
5877 state
.mstate
<- Mnone
5879 | Mzoomrect
((x0, y0), _) ->
5883 Wsi.setcursor
Wsi.CURSOR_INHERIT
;
5884 state
.mstate
<- Mnone
5886 | Msel
((x0, y0), (x1, y1)) ->
5887 let rec loop = function
5891 let a0 = l.pagedispy in
5892 let a1 = a0 + l.pagevh in
5893 let b0 = l.pagedispx in
5894 let b1 = b0 + l.pagevw in
5895 ((y0 >= a0 && y0 <= a1) || (y1 >= a0 && y1 <= a1))
5896 && ((x0 >= b0 && x0 <= b1) || (x1 >= b0 && x1 <= b1))
5900 match getopaque l.pageno with
5903 match Unix.pipe
() with
5904 | (exception exn
) ->
5905 impmsg "cannot create sel pipe: %s" @@
5909 Ne.clo fd
(fun msg
->
5910 dolog
"%s close failed: %s" what msg
)
5913 try spawn
cmd [r, 0; w, -1]
5915 dolog
"cannot execute %S: %s"
5922 G.postRedisplay "copysel";
5924 else clo "Msel pipe/w" w;
5925 clo "Msel pipe/r" r;
5927 dosel conf
.selcmd
();
5928 state
.roam
<- dosel conf
.paxcmd
;
5940 let birdseyemouse button down
x y mask
5941 (conf
, leftx
, _, hooverpageno
, anchor) =
5944 let rec loop = function
5947 if y > l.pagedispy && y < l.pagedispy + l.pagevh
5948 && x > l.pagedispx && x < l.pagedispx + l.pagevw
5950 leavebirdseye (conf
, leftx
, l.pageno, hooverpageno
, anchor) false;
5956 | _ -> viewmouse button down
x y mask
5962 method key key mask
=
5963 begin match state
.mode with
5964 | Textentry
textentry -> textentrykeyboard key mask
textentry
5965 | Birdseye
birdseye -> birdseyekeyboard key mask
birdseye
5966 | View
-> viewkeyboard key mask
5967 | LinkNav
linknav -> linknavkeyboard key mask
linknav
5971 method button button bstate
x y mask
=
5972 begin match state
.mode with
5974 | View
-> viewmouse button bstate
x y mask
5975 | Birdseye beye
-> birdseyemouse button bstate
x y mask beye
5980 method multiclick clicks
x y mask
=
5981 begin match state
.mode with
5983 | View
-> viewmulticlick clicks
x y mask
5990 begin match state
.mode with
5992 | View
| Birdseye
_ | LinkNav
_ ->
5993 match state
.mstate
with
5994 | Mzoom
_ | Mnone
-> ()
5999 state
.mstate
<- Mpan
(x, y);
6001 then state
.x <- panbound (state
.x + dx);
6003 gotoy_and_clear_text y
6006 state
.mstate
<- Msel
(a, (x, y));
6007 G.postRedisplay "motion select";
6010 let y = min state
.winh
(max
0 y) in
6014 let x = min state
.winw (max
0 x) in
6017 | Mzoomrect
(p0
, _) ->
6018 state
.mstate
<- Mzoomrect
(p0
, (x, y));
6019 G.postRedisplay "motion zoomrect";
6023 method pmotion
x y =
6024 begin match state
.mode with
6025 | Birdseye
(conf
, leftx
, pageno, hooverpageno
, anchor) ->
6026 let rec loop = function
6028 if hooverpageno
!= -1
6030 state
.mode <- Birdseye
(conf
, leftx
, pageno, -1, anchor);
6031 G.postRedisplay "pmotion birdseye no hoover";
6034 if y > l.pagedispy && y < l.pagedispy + l.pagevh
6035 && x > l.pagedispx && x < l.pagedispx + l.pagevw
6037 state
.mode <- Birdseye
(conf
, leftx
, pageno, l.pageno, anchor);
6038 G.postRedisplay "pmotion birdseye hoover";
6048 match state
.mstate
with
6049 | Mpan
_ | Msel
_ | Mzoom
_ | Mscrolly
| Mscrollx
| Mzoomrect
_ -> ()
6057 let past, _, _ = !r in
6059 let delta = now -. past in
6062 else r := (now, x, y)
6066 method infochanged
_ = ()
6069 let maxy = state
.maxy - (if conf
.maxhfit
then state
.winh
else 0) in
6072 then 0.0, float state
.winh
6073 else scrollph state
.y maxy
6078 let winw = wadjsb () + state
.winw in
6079 let fwinw = float winw in
6081 let sw = fwinw /. float state
.w in
6082 let sw = fwinw *. sw in
6083 max
sw (float conf
.scrollh
)
6086 let maxx = state
.w + winw in
6087 let x = winw - state
.x in
6088 let percent = float x /. float maxx in
6089 (fwinw -. sw) *. percent
6091 hscrollh (), position, sw
6095 match state
.mode with
6096 | LinkNav
_ -> "links"
6097 | Textentry
_ -> "textentry"
6098 | Birdseye
_ -> "birdseye"
6101 findkeyhash conf
modename
6103 method eformsgs
= true
6104 method alwaysscrolly
= false
6107 let adderrmsg src msg
=
6108 Buffer.add_string state
.errmsgs msg
;
6109 state
.newerrmsgs
<- true;
6113 let adderrfmt src fmt
=
6114 Format.ksprintf
(fun s -> adderrmsg src s) fmt
;
6117 let addrect pageno r g b a x0 y0 x1 y1 =
6118 Hashtbl.add state
.prects
pageno [|r; g; b; a; x0; y0; x1; y1|];
6122 let cl = splitatspace cmds
in
6124 try Scanf.sscanf
s fmt
f
6126 adderrfmt "remote exec"
6127 "error processing '%S': %s\n" cmds
@@ exntos exn
6129 let rectx s pageno (r, g, b, a) x0 y0 x1 y1 =
6130 vlog "%s page %d color (%f %f %f %f) x0,y0,x1,y1 = %f %f %f %f"
6131 s pageno r g b a x0 y0 x1 y1;
6135 let _,w1,h1
,_ = getpagedim
pageno in
6136 let sw = float w1 /. float w
6137 and sh = float h1
/. float h in
6141 and y1s
= y1 *. sh in
6142 let rect = (x0s,y0s
,x1s
,y0s
,x1s
,y1s
,x0s,y1s
) in
6143 let color = (r, g, b, a) in
6144 if conf
.verbose
then debugrect rect;
6145 state
.rects <- (pageno, color, rect) :: state
.rects;
6150 | "reload" :: [] -> reload ()
6151 | "goto" :: args
:: [] ->
6152 scan args
"%u %f %f"
6154 let cmd, _ = state
.geomcmds
in
6156 then gotopagexy !wtmode pageno x y
6159 gotopagexy !wtmode pageno x y;
6162 state
.reprf
<- f state
.reprf
6164 | "goto1" :: args
:: [] -> scan args
"%u %f" gotopage
6165 | "gotor" :: args
:: [] ->
6167 (fun filename
pageno -> gotounder (Uremote
(filename
, pageno)))
6168 | "gotord" :: args
:: [] ->
6170 (fun filename
dest -> gotounder (Uremotedest
(filename
, dest)))
6171 | "rect" :: args
:: [] ->
6172 scan args
"%u %u %f %f %f %f"
6173 (fun pageno c x0 y0 x1 y1 ->
6174 let color = (0.0, 0.0, 1.0 /. float c, 0.5) in
6175 rectx "rect" pageno color x0 y0 x1 y1;
6177 | "prect" :: args
:: [] ->
6178 scan args
"%u %f %f %f %f %f %f %f %f"
6179 (fun pageno r g b alpha x0 y0 x1 y1 ->
6180 addrect pageno r g b alpha x0 y0 x1 y1;
6181 G.postRedisplay "prect"
6183 | "pgoto" :: args
:: [] ->
6184 scan args
"%u %f %f"
6187 match getopaque pageno with
6188 | Some
opaque -> opaque
6191 pgoto optopaque pageno x y;
6192 let rec fixx = function
6195 if l.pageno = pageno
6197 state
.x <- state
.x - l.pagedispx;
6204 match conf
.columns
with
6205 | Csingle
_ | Csplit
_ -> 1
6206 | Cmulti
((n, _, _), _) -> n
6208 layout 0 state
.y (state
.winw * mult) state
.winh
6212 | "activatewin" :: [] -> Wsi.activatewin
()
6213 | "quit" :: [] -> raise Quit
6214 | "clearrects" :: [] ->
6215 Hashtbl.clear state
.prects
;
6216 G.postRedisplay "clearrects"
6218 adderrfmt "remote command"
6219 "error processing remote command: %S\n" cmds
;
6223 let scratch = Bytes.create
80 in
6224 let buf = Buffer.create
80 in
6226 match tempfailureretry
(Unix.read fd
scratch 0) 80 with
6227 | (exception Unix.Unix_error
(Unix.EAGAIN
, _, _)) -> None
6230 if Buffer.length
buf > 0
6232 let s = Buffer.contents
buf in
6240 match Bytes.index_from
scratch ppos '
\n'
with
6241 | pos -> if pos >= n then -1 else pos
6242 | (exception Not_found
) -> -1
6246 Buffer.add_subbytes
buf scratch ppos
(nlpos-ppos
);
6247 let s = Buffer.contents
buf in
6253 Buffer.add_subbytes
buf scratch ppos
(n-ppos
);
6259 let remoteopen path =
6260 try Some
(Unix.openfile
path [Unix.O_NONBLOCK
; Unix.O_RDONLY
] 0o0)
6262 adderrfmt "remoteopen" "error opening %S: %s" path @@ exntos exn
;
6267 let gcconfig = ref E.s in
6268 let trimcachepath = ref E.s in
6269 let rcmdpath = ref E.s in
6270 let pageno = ref None
in
6271 let rootwid = ref 0 in
6272 let openlast = ref false in
6273 let nofc = ref false in
6274 let doreap = ref false in
6275 selfexec := Sys.executable_name
;
6278 [("-p", Arg.String
(fun s -> state
.password <- s),
6279 "<password> Set password");
6283 Config.fontpath
:= s;
6284 selfexec := !selfexec ^
" -f " ^
Filename.quote
s;
6286 "<path> Set path to the user interface font");
6290 selfexec := !selfexec ^
" -c " ^
Filename.quote
s;
6291 Config.confpath
:= s),
6292 "<path> Set path to the configuration file");
6294 ("-last", Arg.Set
openlast, " Open last document");
6296 ("-page", Arg.Int
(fun pageno1
-> pageno := Some
(pageno1
-1)),
6297 "<page-number> Jump to page");
6299 ("-tcf", Arg.String
(fun s -> trimcachepath := s),
6300 "<path> Set path to the trim cache file");
6302 ("-dest", Arg.String
(fun s -> state
.nameddest
<- s),
6303 "<named-destination> Set named destination");
6305 ("-wtmode", Arg.Set
wtmode, " Operate in wt mode");
6306 ("-cxack", Arg.Set
cxack, " Cut corners");
6308 ("-remote", Arg.String
(fun s -> rcmdpath := s),
6309 "<path> Set path to the remote commands source");
6311 ("-origin", Arg.String
(fun s -> state
.origin
<- s),
6312 "<original-path> Set original path");
6314 ("-gc", Arg.Set_string
gcconfig,
6315 "<script-path> Collect garbage with the help of a script");
6317 ("-nofc", Arg.Set
nofc, " Do not use fontconfig");
6319 ("-v", Arg.Unit
(fun () ->
6321 "%s\nconfiguration path: %s\n"
6325 exit
0), " Print version and exit");
6327 ("-embed", Arg.Set_int
rootwid,
6328 "<window-id> Embed into window")
6331 (fun s -> state
.path <- s)
6332 ("Usage: " ^
Sys.argv
.(0) ^
" [options] some.pdf\nOptions:")
6335 then selfexec := !selfexec ^
" -wtmode";
6337 let histmode = emptystr state
.path && not
!openlast in
6339 if not
(Config.load !openlast)
6340 then dolog
"failed to load configuration";
6341 begin match !pageno with
6342 | Some
pageno -> state
.anchor <- (pageno, 0.0, 0.0)
6346 if nonemptystr
!gcconfig
6349 match Unix.socketpair
Unix.PF_UNIX
Unix.SOCK_STREAM
0 with
6350 | (exception exn
) -> error
"socketpair for gc failed: %s" @@ exntos exn
6353 match spawn
!gcconfig [(c, 0); (c, 1); (s, -1)] with
6354 | (exception exn
) -> error
"failed to execute gc script: %s" @@ exntos exn
6356 Ne.clo c @@ (fun s -> error
"failed to close gc fd %s" s);
6361 let wsfd, winw, winh
= Wsi.init
(object (self)
6362 val mutable m_clicks
= 0
6363 val mutable m_click_x
= 0
6364 val mutable m_click_y
= 0
6365 val mutable m_lastclicktime
= infinity
6367 method private cleanup =
6368 state
.roam
<- noroam
;
6369 Hashtbl.iter
(fun _ opaque -> clearmark
opaque) state
.pagemap
6370 method expose
= G.postRedisplay "expose"
6374 | Wsi.Unobscured
-> "unobscured"
6375 | Wsi.PartiallyObscured
-> "partiallyobscured"
6376 | Wsi.FullyObscured
-> "fullyobscured"
6378 vlog "visibility change %s" name
6379 method display = display ()
6380 method map mapped
= vlog "mapped %b" mapped
6381 method reshape w h =
6384 method mouse
b d x y m =
6385 if d && canselect ()
6387 (* http://blogs.msdn.com/b/oldnewthing/archive/2004/10/18/243925.aspx *)
6393 if abs
x - m_click_x
> 10
6394 || abs
y - m_click_y
> 10
6395 || abs_float
(t -. m_lastclicktime
) > 0.3
6397 m_clicks
<- m_clicks
+ 1;
6398 m_lastclicktime
<- t;
6402 G.postRedisplay "cleanup";
6403 state
.uioh <- state
.uioh#button
b d x y m;
6405 else state
.uioh <- state
.uioh#multiclick m_clicks
x y m
6410 m_lastclicktime
<- infinity
;
6411 state
.uioh <- state
.uioh#button
b d x y m
6415 state
.uioh <- state
.uioh#button
b d x y m
6418 state
.mpos
<- (x, y);
6419 state
.uioh <- state
.uioh#motion
x y
6420 method pmotion
x y =
6421 state
.mpos
<- (x, y);
6422 state
.uioh <- state
.uioh#pmotion
x y
6424 let mascm = m land (
6425 Wsi.altmask
+ Wsi.shiftmask
+ Wsi.ctrlmask
+ Wsi.metamask
6428 let x = state
.x and y = state
.y in
6430 if x != state
.x || y != state
.y then self#
cleanup
6432 match state
.keystate
with
6434 let km = k
, mascm in
6437 let modehash = state
.uioh#
modehash in
6438 try Hashtbl.find modehash km
6440 try Hashtbl.find (findkeyhash conf
"global") km
6441 with Not_found
-> KMinsrt
(k
, m)
6443 | KMinsrt
(k
, m) -> keyboard k
m
6444 | KMinsrl
l -> List.iter
(fun (k
, m) -> keyboard k
m) l
6445 | KMmulti
(l, r) -> state
.keystate
<- KSinto
(l, r)
6447 | KSinto
((k'
, m'
) :: [], insrt
) when k'
=k
&& m'
land mascm = m'
->
6448 List.iter
(fun (k
, m) -> keyboard k
m) insrt
;
6449 state
.keystate
<- KSnone
6450 | KSinto
((k'
, m'
) :: keys, insrt
) when k'
=k
&& m'
land mascm = m'
->
6451 state
.keystate
<- KSinto
(keys, insrt
)
6452 | KSinto
_ -> state
.keystate
<- KSnone
6455 state
.mpos
<- (x, y);
6456 state
.uioh <- state
.uioh#pmotion
x y
6457 method leave = state
.mpos
<- (-1, -1)
6458 method winstate wsl
= state
.winstate
<- wsl
6459 method quit
= raise Quit
6460 end) !rootwid conf
.cwinw conf
.cwinh platform
in
6465 List.exists
GlMisc.check_extension
6466 [ "GL_ARB_texture_rectangle"
6467 ; "GL_EXT_texture_recangle"
6468 ; "GL_NV_texture_rectangle" ]
6470 then (dolog
"OpenGL does not suppport rectangular textures"; exit
1);
6473 let r = GlMisc.get_string `renderer
in
6474 let p = "Mesa DRI Intel(" in
6475 let l = String.length
p in
6476 String.length
r > l && String.sub
r 0 l = p
6479 defconf
.sliceheight
<- 1024;
6480 defconf
.texcount
<- 32;
6481 defconf
.usepbo
<- true;
6485 match Unix.socketpair
Unix.PF_UNIX
Unix.SOCK_STREAM
0 with
6486 | (exception exn
) ->
6487 dolog
"socketpair failed: %s" @@ exntos exn
;
6495 setcheckers conf
.checkers
;
6498 conf
.angle
, conf
.fitmodel
, (conf
.trimmargins
, conf
.trimfuzz
),
6499 conf
.texcount
, conf
.sliceheight
, conf
.mustoresize
, conf
.colorspace
,
6500 !Config.fontpath
, !trimcachepath,
6501 GlMisc.check_extension
"GL_ARB_pixel_buffer_object",
6504 List.iter
GlArray.enable
[`texture_coord
; `vertex
];
6506 reshape ~firsttime
:true winw winh
;
6510 Wsi.settitle
"llpp (history)";
6514 state
.text <- "Opening " ^
(mbtoutf8 state
.path);
6515 opendoc state
.path state
.password;
6519 Wsi.setcursor
Wsi.CURSOR_INHERIT
;
6520 Sys.set_signal
Sys.sighup
(Sys.Signal_handle
(fun _ -> reload ()));
6523 match Unix.waitpid
[Unix.WNOHANG
] ~
-1 with
6524 | (exception (Unix.Unix_error
(Unix.ECHILD
, _, _))) -> ()
6525 | (exception exn
) -> dolog
"Unix.waitpid: %s" @@ exntos exn
6527 | _pid
, _status
-> reap ()
6529 Sys.set_signal
Sys.sigchld
(Sys.Signal_handle
(fun _ -> doreap := true));
6533 if nonemptystr
!rcmdpath
6534 then remoteopen !rcmdpath
6539 let rec loop deadline
=
6545 let r = [state
.ss; state
.wsfd] in
6549 | Some fd
-> fd
:: r
6553 state
.redisplay
<- false;
6560 if deadline
= infinity
6562 else max
0.0 (deadline
-. now)
6567 try Unix.select
r [] [] timeout
6568 with Unix.Unix_error
(Unix.EINTR
, _, _) -> [], [], []
6574 if state
.ghyll
== noghyll
6576 match state
.autoscroll
with
6577 | Some step
when step
!= 0 ->
6578 let y = state
.y + step
in
6582 else if y >= state
.maxy then 0 else y
6584 if state
.mode = View
6585 then gotoy_and_clear_text y
6589 else deadline
+. 0.01
6594 let rec checkfds = function
6596 | fd
:: rest
when fd
= state
.ss ->
6597 let cmd = readcmd state
.ss in
6601 | fd
:: rest
when fd
= state
.wsfd ->
6605 | fd
:: rest
when Some fd
= !optrfd ->
6606 begin match remote fd
with
6607 | None
-> optrfd := remoteopen !rcmdpath;
6608 | opt -> optrfd := opt
6613 dolog
"select returned unknown descriptor";
6619 if deadline
= infinity
6623 match state
.autoscroll
with
6624 | Some step
when step
!= 0 -> deadline1
6625 | _ -> if state
.ghyll
== noghyll
then infinity
else deadline1
6633 Config.save leavebirdseye;
6634 if hasunsavedchanges
()