6 external init
: Unix.file_descr
-> params
-> unit = "ml_init";;
7 external seltext
: opaque
-> (int * int * int * int) -> unit = "ml_seltext";;
8 external hassel
: opaque
-> bool = "ml_hassel";;
9 external copysel
: Unix.file_descr
-> opaque
-> unit = "ml_copysel";;
10 external getpdimrect
: int -> float array
= "ml_getpdimrect";;
11 external whatsunder
: opaque
-> int -> int -> under
= "ml_whatsunder";;
12 external markunder
: opaque
-> int -> int -> mark
-> bool = "ml_markunder";;
13 external clearmark
: opaque
-> unit = "ml_clearmark";;
14 external zoomforh
: int -> int -> int -> int -> float = "ml_zoom_for_height";;
15 external getmaxw
: unit -> float = "ml_getmaxw";;
16 external drawstr
: int -> int -> int -> string -> float = "ml_draw_string";;
17 external measurestr
: int -> string -> float = "ml_measure_string";;
18 external postprocess
:
19 opaque
-> int -> int -> int -> (int * string * int) -> int
21 external pagebbox
: opaque
-> (int * int * int * int) = "ml_getpagebox";;
22 external setaalevel
: int -> unit = "ml_setaalevel";;
23 external realloctexts
: int -> bool = "ml_realloctexts";;
24 external findlink
: opaque
-> linkdir
-> link
= "ml_findlink";;
25 external getlink
: opaque
-> int -> under
= "ml_getlink";;
26 external getlinkrect
: opaque
-> int -> irect
= "ml_getlinkrect";;
27 external getlinkcount
: opaque
-> int = "ml_getlinkcount";;
28 external findpwl
: int -> int -> pagewithlinks
= "ml_find_page_with_links";;
29 external getpbo
: width
-> height
-> colorspace
-> opaque
= "ml_getpbo";;
30 external freepbo
: opaque
-> unit = "ml_freepbo";;
31 external unmappbo
: opaque
-> unit = "ml_unmappbo";;
32 external pbousable
: unit -> bool = "ml_pbo_usable";;
33 external unproject
: opaque
-> int -> int -> (int * int) option
35 external project
: opaque
-> int -> int -> float -> float -> (float * float)
37 external drawtile
: tileparams
-> opaque
-> unit = "ml_drawtile";;
38 external rectofblock
: opaque
-> int -> int -> float array
option
40 external begintiles
: unit -> unit = "ml_begintiles";;
41 external endtiles
: unit -> unit = "ml_endtiles";;
42 external addannot
: opaque
-> int -> int -> string -> unit = "ml_addannot";;
43 external modannot
: opaque
-> slinkindex
-> string -> unit = "ml_modannot";;
44 external delannot
: opaque
-> slinkindex
-> unit = "ml_delannot";;
45 external hasunsavedchanges
: unit -> bool = "ml_hasunsavedchanges";;
46 external savedoc
: string -> unit = "ml_savedoc";;
47 external getannotcontents
: opaque
-> slinkindex
-> string
48 = "ml_getannotcontents";;
49 external drawprect
: opaque
-> int -> int -> float array
-> unit =
52 let selfexec = ref E.s
;;
54 let drawstring size x y s
=
56 Gl.enable `texture_2d
;
57 GlFunc.blend_func ~src
:`src_alpha ~dst
:`one_minus_src_alpha
;
58 ignore
(drawstr size x y s
);
60 Gl.disable `texture_2d
;
63 let drawstring1 size x y s
=
67 let drawstring2 size x y fmt
=
68 Printf.kprintf
(drawstring size
(x
+1) (y
+size
+1)) fmt
72 dolog
"l %d dim=%d {" l
.pageno l
.pagedimno
;
73 dolog
" WxH %dx%d" l
.pagew l
.pageh
;
74 dolog
" vWxH %dx%d" l
.pagevw l
.pagevh
;
75 dolog
" pagex,y %d,%d" l
.pagex l
.pagey
;
76 dolog
" dispx,y %d,%d" l
.pagedispx l
.pagedispy
;
77 dolog
" column %d" l
.pagecol
;
81 let debugrect (x0
, y0
, x1
, y1
, x2
, y2
, x3
, y3
) =
83 dolog
" x0,y0=(% f, % f)" x0 y0
;
84 dolog
" x1,y1=(% f, % f)" x1 y1
;
85 dolog
" x2,y2=(% f, % f)" x2 y2
;
86 dolog
" x3,y3=(% f, % f)" x3 y3
;
90 let isbirdseye = function
97 let istextentry = function
104 let wtmode = ref false;;
105 let cxack = ref false;;
107 let pgscale h
= truncate
(float h
*. conf
.pgscale);;
110 if not state
.uioh#alwaysscrolly
&& (conf
.scrollb
land scrollbhv
= 0)
111 || (state
.x
= 0 && state
.w
<= state
.winw
- conf
.scrollbw
)
117 if not state
.uioh#alwaysscrolly
&& (conf
.scrollb
land scrollbvv
= 0)
125 else x
> state
.winw
- vscrollw ()
128 let wadjsb () = -vscrollw ();;
129 let xadjsb () = if conf
.leftscroll
then vscrollw () else 0;;
132 fstate
.fontsize
<- n
;
133 fstate
.wwidth
<- measurestr fstate
.fontsize
"w";
134 fstate
.maxrows
<- (state
.winh
- fstate
.fontsize
- 1) / (fstate
.fontsize
+ 1);
140 else Printf.kprintf ignore fmt
144 if emptystr conf
.pathlauncher
145 then dolog
"%s" state
.path
147 let command = Str.global_replace percentsre state
.path conf
.pathlauncher
in
148 match spawn
command [] with
151 dolog
"failed to execute `%s': %s" command @@ exntos exn
157 let postRedisplay who
=
158 vlog "redisplay for [%S]" who
;
159 state
.redisplay
<- true;
163 let getopaque pageno
=
164 try Some
(Hashtbl.find state
.pagemap
(pageno
, state
.gen
))
165 with Not_found
-> None
168 let pagetranslatepoint l x y
=
169 let dy = y
- l
.pagedispy
in
170 let y = dy + l
.pagey
in
171 let dx = x
- l
.pagedispx
in
172 let x = dx + l
.pagex
in
176 let onppundermouse g
x y d
=
179 begin match getopaque l
.pageno
with
181 let x0 = l
.pagedispx
in
182 let x1 = x0 + l
.pagevw
in
183 let y0 = l
.pagedispy
in
184 let y1 = y0 + l
.pagevh
in
185 if y >= y0 && y <= y1 && x >= x0 && x <= x1
187 let px, py
= pagetranslatepoint l
x y in
188 match g opaque l
px py
with
201 let g opaque l
px py
=
204 match rectofblock opaque
px py
with
205 | Some
[|x0;x1;y0;y1|] ->
206 let ox = xadjsb () |> float in
207 let rect = (x0+.ox, y0, x1+.ox, y0, x1+.ox, y1, x0+.ox, y1) in
208 let color = (0.0, 0.0, 1.0 /. (l
.pageno
mod 3 |> float), 0.5) in
209 state
.rects
<- [l
.pageno
, color, rect];
210 G.postRedisplay "getunder";
213 let under = whatsunder opaque
px py
in
214 if under = Unone
then None
else Some
under
216 onppundermouse g x y Unone
221 match unproject opaque
x y with
222 | Some
(x, y) -> Some
(Some
(opaque
, l
.pageno
, x, y))
225 onppundermouse g x y None
;
229 state
.text
<- Printf.sprintf
"%c%s" c s
;
230 G.postRedisplay "showtext";
234 Format.ksprintf
(fun s
-> showtext '
!' s
) fmt
;
237 let pipesel opaque cmd
=
240 match Unix.pipe
() with
241 | (exception exn
) -> dolog
"pipesel cannot create pipe: %S" @@ exntos exn
;
243 let doclose what fd
=
244 Ne.clo fd
(fun msg
-> dolog
"%s close failed: %s" what msg
)
247 try spawn cmd
[r
, 0; w
, -1]
249 dolog
"cannot execute %S: %s" cmd
@@ exntos exn
;
255 G.postRedisplay "pipesel";
257 else doclose "pipesel pipe/w" w
;
258 doclose "pipesel pipe/r" r
;
262 let g opaque l
px py
=
263 if markunder opaque
px py conf
.paxmark
266 match getopaque l
.pageno
with
268 | Some opaque
-> pipesel opaque conf
.paxcmd
273 G.postRedisplay "paxunder";
274 if conf
.paxmark
= Mark_page
277 match getopaque l
.pageno
with
279 | Some opaque
-> clearmark opaque
) state
.layout
;
280 state
.roam
<- onppundermouse g x y (fun () -> impmsg "whoopsie daisy");
284 match Unix.pipe
() with
285 | (exception exn
) -> impmsg "pipe failed: %s" @@ exntos exn
288 Ne.clo fd
(fun msg
-> impmsg "failed to close %s: %s" cap msg
)
291 try spawn conf
.selcmd
[r
, 0; w
, -1]
293 impmsg "failed to execute %s: %s" conf
.selcmd
@@ exntos exn
;
299 let l = String.length s
in
300 let bytes = Bytes.unsafe_of_string s
in
301 let n = tempfailureretry
(Unix.write w
bytes 0) l in
303 then impmsg "failed to write %d characters to sel pipe, wrote %d"
306 impmsg "failed to write to sel pipe: %s" @@ exntos exn
309 clo "selstring pipe/r" r
;
310 clo "selstring pipe/w" w
;
313 let undertext ?
(nopath
=false) = function
316 | Ulinkgoto
(pageno
, _
) ->
318 then "page " ^ string_of_int
(pageno
+1)
319 else Printf.sprintf
"%s: page %d" state
.path
(pageno
+1)
320 | Utext s
-> "font: " ^ s
321 | Uunexpected s
-> "unexpected: " ^ s
322 | Ulaunch s
-> "launch: " ^ s
323 | Unamed s
-> "named: " ^ s
324 | Uremote
(filename
, pageno
) ->
325 Printf.sprintf
"%s: page %d" filename
(pageno
+1)
326 | Uremotedest
(filename
, destname
) ->
327 Printf.sprintf
"%s: destination %S" filename destname
328 | Uannotation
(opaque
, slinkindex
) ->
329 "annotation: " ^ getannotcontents opaque slinkindex
332 let updateunder x y =
333 match getunder x y with
334 | Unone
-> Wsi.setcursor
Wsi.CURSOR_INHERIT
336 if conf
.underinfo
then showtext 'u'
("ri: " ^ uri
);
337 Wsi.setcursor
Wsi.CURSOR_INFO
338 | Ulinkgoto
(pageno
, _
) ->
340 then showtext 'p'
("age: " ^ string_of_int
(pageno
+1));
341 Wsi.setcursor
Wsi.CURSOR_INFO
343 if conf
.underinfo
then showtext '
f'
("ont: " ^ s
);
344 Wsi.setcursor
Wsi.CURSOR_TEXT
346 if conf
.underinfo
then showtext 'u'
("nexpected: " ^ s
);
347 Wsi.setcursor
Wsi.CURSOR_INHERIT
349 if conf
.underinfo
then showtext '
l'
("aunch: " ^ s
);
350 Wsi.setcursor
Wsi.CURSOR_INHERIT
352 if conf
.underinfo
then showtext '
n'
("amed: " ^ s
);
353 Wsi.setcursor
Wsi.CURSOR_INHERIT
354 | Uremote
(filename
, pageno
) ->
355 if conf
.underinfo
then showtext 'r'
356 (Printf.sprintf
"emote: %s (%d)" filename
(pageno
+1));
357 Wsi.setcursor
Wsi.CURSOR_INFO
358 | Uremotedest
(filename
, destname
) ->
359 if conf
.underinfo
then showtext 'r'
360 (Printf.sprintf
"emote destination: %s (%S)" filename destname
);
361 Wsi.setcursor
Wsi.CURSOR_INFO
363 if conf
.underinfo
then showtext 'a'
"nnotation";
364 Wsi.setcursor
Wsi.CURSOR_INFO
367 let showlinktype under =
368 if conf
.underinfo
&& under != Unone
369 then showtext ' '
@@ undertext under
372 let intentry_with_suffix text key
=
374 if key
>= 32 && key
< 127
378 match Char.lowercase
c with
380 let text = addchar
text c in
384 let text = addchar
text c in
388 state
.text <- Printf.sprintf
"invalid char (%d, `%c')" key
c;
393 let s = Bytes.create
4 in
394 let n = tempfailureretry
(Unix.read fd
s 0) 4 in
395 if n != 4 then error
"incomplete read(len) = %d" n;
396 let len = (Char.code
(Bytes.get
s 0) lsl 24)
397 lor (Char.code
(Bytes.get
s 1) lsl 16)
398 lor (Char.code
(Bytes.get
s 2) lsl 8)
399 lor (Char.code
(Bytes.get
s 3))
401 let s = Bytes.create
len in
402 let n = tempfailureretry
(Unix.read fd
s 0) len in
403 if n != len then error
"incomplete read(data) %d vs %d" n len;
408 let b = Buffer.create
16 in
409 Buffer.add_string
b "llll";
412 let s = Buffer.to_bytes
b in
413 let n = Bytes.length
s in
415 (* dolog "wcmd %S" (String.sub s 4 len); *)
416 Bytes.set
s 0 (Char.chr
((len lsr 24) land 0xff));
417 Bytes.set
s 1 (Char.chr
((len lsr 16) land 0xff));
418 Bytes.set
s 2 (Char.chr
((len lsr 8) land 0xff));
419 Bytes.set
s 3 (Char.chr
(len land 0xff));
420 let n'
= tempfailureretry
(Unix.write state
.ss
s 0) n in
421 if n'
!= n then error
"write failed %d vs %d" n'
n;
425 let nogeomcmds cmds
=
427 | s, [] -> emptystr
s
431 let layoutN ((columns
, coverA
, coverB
), b) x y sw sh
=
432 let sh = sh - (hscrollh ()) in
433 let wadj = wadjsb () in
434 let rec fold accu
n =
435 if n = Array.length
b
438 let pdimno, dx, vy
, (_
, w
, h
, xoff
) = b.(n) in
441 || n = state
.pagecount
- coverB
442 || (n - coverA
) mod columns
= columns
- 1)
448 let pagey = max
0 (y - vy
) in
449 let pagedispy = if pagey > 0 then 0 else vy
- y in
450 let pagedispx, pagex
=
452 if n = coverA
- 1 || n = state
.pagecount
- coverB
453 then x + (wadj + sw
- w
) / 2
461 let vw = wadj + sw
- pagedispx in
462 let pw = w
- pagex
in
465 let pagevh = min
(h
- pagey) (sh - pagedispy) in
466 if pagevw > 0 && pagevh > 0
477 ; pagedispx = pagedispx
478 ; pagedispy = pagedispy
490 if Array.length
b = 0
492 else List.rev
(fold [] (page_of_y
y))
495 let layoutS (columns
, b) x y sw
sh =
496 let sh = sh - hscrollh () in
497 let wadj = wadjsb () in
498 let rec fold accu n =
499 if n = Array.length
b
502 let pdimno, px, vy
, (_
, pagew
, pageh
, xoff
) = b.(n) in
510 let pagey = max
0 (y - vy
) in
511 let pagedispy = if pagey > 0 then 0 else vy
- y in
512 let pagedispx, pagex
=
526 let pagecolw = pagew
/columns
in
529 then pagedispx + ((wadj + sw
- pagecolw) / 2)
533 let vw = wadj + sw
- pagedispx in
534 let pw = pagew
- pagex
in
537 let pagevw = min
pagevw pagecolw in
538 let pagevh = min
(pageh
- pagey) (sh - pagedispy) in
539 if pagevw > 0 && pagevh > 0
550 ; pagedispx = pagedispx
551 ; pagedispy = pagedispy
552 ; pagecol
= n mod columns
566 let layout x y sw
sh =
567 if nogeomcmds state
.geomcmds
569 match conf
.columns
with
570 | Csingle
b -> layoutN ((1, 0, 0), b) x y sw
sh
571 | Cmulti
c -> layoutN c x y sw
sh
572 | Csplit
s -> layoutS s x y sw
sh
577 let y = state
.y + incr
in
579 let y = min
y (state
.maxy
- (if conf
.maxhfit
then state
.winh
else 0)) in
584 let tilex = l.pagex
mod conf
.tilew
in
585 let tiley = l.pagey mod conf
.tileh
in
587 let col = l.pagex
/ conf
.tilew
in
588 let row = l.pagey / conf
.tileh
in
590 let xadj = xadjsb () in
591 let rec rowloop row y0 dispy h
=
595 let dh = conf
.tileh
- y0 in
597 let rec colloop col x0 dispx w
=
601 let dw = conf
.tilew
- x0 in
603 let dispx'
= xadj + dispx in
604 f col row dispx' dispy
x0 y0 dw dh;
605 colloop (col+1) 0 (dispx+dw) (w
-dw)
608 colloop col tilex l.pagedispx l.pagevw;
609 rowloop (row+1) 0 (dispy
+dh) (h
-dh)
612 if l.pagevw > 0 && l.pagevh > 0
613 then rowloop row tiley l.pagedispy l.pagevh;
616 let gettileopaque l col row =
618 l.pageno
, state
.gen
, conf
.colorspace
, conf
.angle
, l.pagew
, l.pageh
, col, row
620 try Some
(Hashtbl.find state
.tilemap
key)
621 with Not_found
-> None
624 let puttileopaque l col row gen colorspace angle opaque size elapsed
=
625 let key = l.pageno
, gen
, colorspace
, angle
, l.pagew
, l.pageh
, col, row in
626 Hashtbl.add state
.tilemap
key (opaque
, size
, elapsed
)
629 let filledrect x0 y0 x1 y1 =
630 GlArray.disable `texture_coord
;
631 Raw.sets_float state
.vraw ~pos
:0 [| x0; y0; x0; y1; x1; y0; x1; y1 |];
632 GlArray.vertex `two state
.vraw
;
633 GlArray.draw_arrays `triangle_strip ~first
:0 ~count
:4;
634 GlArray.enable `texture_coord
;
637 let linerect x0 y0 x1 y1 =
638 GlArray.disable `texture_coord
;
639 Raw.sets_float state
.vraw ~pos
:0 [| x0; y0; x0; y1; x1; y1; x1; y0 |];
640 GlArray.vertex `two state
.vraw
;
641 GlArray.draw_arrays `line_loop ~first
:0 ~count
:4;
642 GlArray.enable `texture_coord
;
645 let drawtiles l color =
647 let wadj = wadjsb () in
649 let f col row x y tilex tiley w h
=
650 match gettileopaque l col row with
651 | Some
(opaque
, _
, t
) ->
652 let params = x, y, w
, h
, tilex, tiley in
654 then GlTex.env
(`mode `blend
);
655 drawtile
params opaque
;
657 then GlTex.env
(`mode `modulate
);
661 let s = Printf.sprintf
665 let w = measurestr fstate
.fontsize
s in
666 GlDraw.color (0.0, 0.0, 0.0);
667 filledrect (float (x-2))
670 (float (y + fstate
.fontsize
+ 2));
671 GlDraw.color (1.0, 1.0, 1.0);
672 drawstring fstate
.fontsize
x (y + fstate
.fontsize
- 1) s;
682 let lw = wadj + state
.winw
- x in
685 let lh = state
.winh
- y in
689 then GlTex.env
(`mode `blend
);
690 begin match state
.checkerstexid
with
692 Gl.enable `texture_2d
;
693 GlTex.bind_texture ~target
:`texture_2d id
;
697 and y1 = float (y+h
) in
699 let tw = float w /. 16.0
700 and th
= float h
/. 16.0 in
701 let tx0 = float tilex /. 16.0
702 and ty0
= float tiley /. 16.0 in
704 and ty1
= ty0
+. th
in
705 Raw.sets_float state
.vraw ~pos
:0
706 [| x0; y0; x0; y1; x1; y0; x1; y1 |];
707 Raw.sets_float state
.traw ~pos
:0
708 [| tx0; ty0
; tx0; ty1
; tx1; ty0
; tx1; ty1
|];
709 GlArray.vertex `two state
.vraw
;
710 GlArray.tex_coord `two state
.traw
;
711 GlArray.draw_arrays `triangle_strip ~first
:0 ~count
:4;
712 Gl.disable `texture_2d
;
715 GlDraw.color (1.0, 1.0, 1.0);
716 filledrect (float x) (float y) (float (x+w)) (float (y+h
));
719 then GlTex.env
(`mode `modulate
);
720 if w > 128 && h
> fstate
.fontsize
+ 10
722 let c = if conf
.invert
then 1.0 else 0.0 in
723 GlDraw.color (c, c, c);
726 then (col*conf
.tilew
, row*conf
.tileh
)
729 drawstring2 fstate
.fontsize
x y "Loading %d [%d,%d]" l.pageno
c r
;
738 let pagevisible layout n = List.exists
(fun l -> l.pageno
= n) layout;;
740 let tilevisible1 l x y =
742 and ax1
= l.pagex
+ l.pagevw
744 and ay1
= l.pagey + l.pagevh in
748 let bx1 = min
(bx0 + conf
.tilew
) l.pagew
749 and by1
= min
(by0
+ conf
.tileh
) l.pageh
in
751 let rx0 = max
ax0 bx0
752 and ry0
= max ay0 by0
753 and rx1
= min ax1
bx1
754 and ry1
= min ay1 by1
in
756 let nonemptyintersection = rx1
> rx0 && ry1
> ry0
in
760 let tilevisible layout n x y =
761 let rec findpageinlayout m
= function
762 | l :: rest
when l.pageno
= n ->
763 tilevisible1 l x y || (
764 match conf
.columns
with
765 | Csplit
(c, _
) when c > m
-> findpageinlayout (m
+1) rest
770 | _
:: rest
-> findpageinlayout 0 rest
773 findpageinlayout 0 layout;
776 let tileready l x y =
777 tilevisible1 l x y &&
778 gettileopaque l (x/conf
.tilew
) (y/conf
.tileh
) != None
781 let tilepage n p
layout =
782 let rec loop = function
786 let f col row _ _ _ _ _ _
=
787 if state
.currently
= Idle
789 match gettileopaque l col row with
792 let x = col*conf
.tilew
793 and y = row*conf
.tileh
in
795 let w = l.pagew
- x in
799 let h = l.pageh
- y in
804 then getpbo
w h conf
.colorspace
807 wcmd "tile %s %d %d %d %d %s"
808 (~
> p
) x y w h (~
> pbo);
811 l, p
, conf
.colorspace
, conf
.angle
,
812 state
.gen
, col, row, conf
.tilew
, conf
.tileh
821 if nogeomcmds state
.geomcmds
825 let preloadlayout x y sw
sh =
826 let y = if y < sh then 0 else y - sh in
827 let x = min
0 (x + sw
) in
835 if state
.currently
!= Idle
840 begin match getopaque l.pageno
with
842 wcmd "page %d %d" l.pageno
l.pagedimno
;
843 state
.currently
<- Loading
(l, state
.gen
);
845 tilepage l.pageno opaque pages
;
850 if nogeomcmds state
.geomcmds
856 if conf
.preload && state
.currently
= Idle
857 then load (preloadlayout state
.x state
.y state
.winw state
.winh
);
860 let layoutready layout =
861 let rec fold all ls
=
864 let seen = ref false in
865 let allvisible = ref true in
866 let foo col row _ _ _ _ _ _
=
868 allvisible := !allvisible &&
869 begin match gettileopaque l col row with
875 fold (!seen && !allvisible) rest
878 let alltilesvisible = fold true layout in
883 let y = bound
y 0 state
.maxy
in
884 let y, layout, proceed
=
885 match conf
.maxwait
with
886 | Some time
when state
.ghyll
== noghyll
->
887 begin match state
.throttle
with
889 let layout = layout state
.x y state
.winw state
.winh
in
890 let ready = layoutready layout in
894 state
.throttle
<- Some
(layout, y, now
());
896 else G.postRedisplay "gotoy showall (None)";
898 | Some
(_
, _
, started
) ->
899 let dt = now
() -. started
in
902 state
.throttle
<- None
;
903 let layout = layout state
.x y state
.winw state
.winh
in
905 G.postRedisplay "maxwait";
912 let layout = layout state
.x y state
.winw state
.winh
in
913 if not
!wtmode || layoutready layout
914 then G.postRedisplay "gotoy ready";
920 state
.layout <- layout;
921 begin match state
.mode
with
924 | Ltexact
(pageno
, linkno
) ->
925 let rec loop = function
927 state
.mode
<- LinkNav
(Ltgendir
0)
928 | l :: _
when l.pageno
= pageno
->
929 begin match getopaque pageno
with
930 | None
-> state
.mode
<- LinkNav
(Ltnotready
(pageno
, 0))
932 let x0, y0, x1, y1 = getlinkrect opaque linkno
in
933 if not
(x0 >= l.pagex
&& x1 <= l.pagex
+ l.pagevw
934 && y0 >= l.pagey && y1 <= l.pagey + l.pagevh)
935 then state
.mode
<- LinkNav
(Ltgendir
0)
937 | _
:: rest
-> loop rest
940 | Ltnotready _
| Ltgendir _
-> ()
946 begin match state
.mode
with
947 | Birdseye
(conf
, leftx
, pageno
, hooverpageno
, anchor
) ->
948 if not
(pagevisible layout pageno
)
950 match state
.layout with
953 state
.mode
<- Birdseye
(
954 conf
, leftx
, l.pageno
, hooverpageno
, anchor
959 | Ltnotready
(_
, dir
)
962 let rec loop = function
965 match getopaque l.pageno
with
966 | None
-> Ltnotready
(l.pageno
, dir
)
971 then LDfirstvisible
(l.pagex
, l.pagey, dir
)
973 if dir
> 0 then LDfirst
else LDlast
979 | Lnotfound
-> loop rest
981 showlinktype (getlink opaque
n);
982 Ltexact
(l.pageno
, n)
986 state
.mode
<- LinkNav
linknav
994 state
.ghyll
<- noghyll
;
997 let mx, my
= state
.mpos
in
1002 let conttiling pageno opaque
=
1003 tilepage pageno opaque
1005 then preloadlayout state
.x state
.y state
.winw state
.winh
1009 let gotoy_and_clear_text y =
1010 if not conf
.verbose
then state
.text <- E.s;
1014 let getanchory (n, top
, dtop
) =
1015 let y, h = getpageyh
n in
1016 if conf
.presentation
1018 let ips = calcips
h in
1019 y + truncate
(top
*.float h -. dtop
*.float ips) + ips;
1021 y + truncate
(top
*.float h -. dtop
*.float conf
.interpagespace
)
1024 let gotoanchor anchor
=
1025 gotoy (getanchory anchor
);
1029 cbput state
.hists
.nav
(getanchor
());
1033 let anchor = cbgetc state
.hists
.nav dir
in
1037 let gotoghyll1 single
y =
1038 let scroll f n a
b =
1039 (* http://devmaster.net/forums/topic/9796-ease-in-ease-out-algorithm/ *)
1041 let s x = 3.0*.x**2.0 -. 2.0*.x**3.0 in
1043 then s (float f /. float a
)
1046 then 1.0 -. s ((float (f-b) /. float (n-b)))
1052 let ins = float a
*. 0.5
1053 and outs
= float (n-b) *. 0.5 in
1055 ins +. outs
+. float ones
1057 let rec set nab
y sy
=
1058 let (_N
, _A
, _B
), y =
1061 let scl = if y > sy
then 2 else -2 in
1062 let _N, _
, _
= nab
in
1063 (_N,0,_N), y+conf
.scrollstep
*scl
1065 let sum = summa
_N _A _B
in
1066 let dy = float (y - sy
) in
1070 then state
.ghyll
<- noghyll
1073 let s = scroll n _N _A _B
in
1074 let y1 = y1 +. ((s *. dy) /. sum) in
1075 gotoy_and_clear_text (truncate
y1);
1076 state
.ghyll
<- gf (n+1) y1;
1080 | Some
y'
when single
-> set nab
y' state
.y
1081 | Some
y'
-> set (_N/2, 1, 1) y' state
.y
1083 gf 0 (float state
.y)
1086 match conf
.ghyllscroll
with
1087 | Some nab
when not conf
.presentation
->
1088 if state
.ghyll
== noghyll
1089 then set nab
y state
.y
1090 else state
.ghyll
(Some
y)
1092 gotoy_and_clear_text y
1095 let gotoghyll = gotoghyll1 false;;
1097 let gotopage n top
=
1098 let y, h = getpageyh
n in
1099 let y = y + (truncate
(top
*. float h)) in
1103 let gotopage1 n top
=
1104 let y = getpagey
n in
1109 let invalidate s f =
1114 match state
.geomcmds
with
1115 | ps
, [] when emptystr ps
->
1117 state
.geomcmds
<- s, [];
1120 state
.geomcmds
<- ps
, [s, f];
1122 | ps
, (s'
, _
) :: rest
when s'
= s ->
1123 state
.geomcmds
<- ps
, ((s, f) :: rest
);
1126 state
.geomcmds
<- ps
, ((s, f) :: cmds
);
1130 Hashtbl.iter
(fun _ opaque
->
1131 wcmd "freepage %s" (~
> opaque
);
1133 Hashtbl.clear state
.pagemap
;
1137 if not
(Queue.is_empty state
.tilelru
)
1139 Queue.iter
(fun (k
, p
, s) ->
1140 wcmd "freetile %s" (~
> p
);
1141 state
.memused
<- state
.memused
- s;
1142 Hashtbl.remove state
.tilemap k
;
1144 state
.uioh#infochanged Memused
;
1145 Queue.clear state
.tilelru
;
1151 let h = truncate
(float h*.conf
.zoom
) in
1152 let d = conf
.interpagespace
lsl (if conf
.presentation
then 1 else 0) in
1156 let opendoc path password
=
1158 state
.password
<- password
;
1159 state
.gen
<- state
.gen
+ 1;
1160 state
.docinfo
<- [];
1161 state
.outlines
<- [||];
1164 setaalevel conf
.aalevel
;
1166 if emptystr state
.origin
1170 Wsi.settitle
("llpp " ^
(mbtoutf8
(Filename.basename
titlepath)));
1171 wcmd "open %d %d %s\000%s\000" (btod
!wtmode) (btod
!cxack) path password
;
1172 invalidate "reqlayout"
1174 wcmd "reqlayout %d %d %d %s\000"
1175 conf
.angle
(FMTE.to_int conf
.fitmodel
)
1176 (stateh state
.winh
) state
.nameddest
1181 state
.anchor <- getanchor
();
1182 opendoc state
.path state
.password
;
1186 let c = c *. conf
.colorscale
in
1190 let scalecolor2 (r
, g, b) =
1191 (r
*. conf
.colorscale
, g *. conf
.colorscale
, b *. conf
.colorscale
);
1194 let docolumns columns
=
1195 let wadj = wadjsb () in
1198 let a = Array.make state
.pagecount
(-1, -1, -1, (-1, -1, -1, -1)) in
1199 let wadj = wadjsb () in
1200 let rec loop pageno
pdimno pdim
y ph pdims
=
1201 if pageno
= state
.pagecount
1204 let pdimno, ((_
, w, h, xoff
) as pdim
), pdims
=
1206 | ((pageno'
, _
, _
, _
) as pdim
) :: rest
when pageno'
= pageno
->
1207 pdimno+1, pdim
, rest
1211 let x = max
0 (((wadj + state
.winw
- w) / 2) - xoff
) in
1213 (if conf
.presentation
1214 then (if pageno
= 0 then calcips
h else calcips ph
+ calcips
h)
1215 else (if pageno
= 0 then 0 else conf
.interpagespace
)
1218 a.(pageno
) <- (pdimno, x, y, pdim
);
1219 loop (pageno
+1) pdimno pdim
(y + h) h pdims
1221 loop 0 ~
-1 (-1,-1,-1,-1) 0 0 state
.pdims
;
1222 conf
.columns
<- Csingle
a;
1224 | Cmulti
((columns
, coverA
, coverB
), _
) ->
1225 let a = Array.make state
.pagecount
(-1, -1, -1, (-1, -1, -1, -1)) in
1226 let rec loop pageno
pdimno pdim
x y rowh pdims
=
1227 let rec fixrow m
= if m
= pageno
then () else
1228 let (pdimno, x, y, ((_
, _
, h, _
) as pdim
)) = a.(m
) in
1231 let y = y + (rowh
- h) / 2 in
1232 a.(m
) <- (pdimno, x, y, pdim
);
1236 if pageno
= state
.pagecount
1237 then fixrow (((pageno
- 1) / columns
) * columns
)
1239 let pdimno, ((_
, w, h, xoff
) as pdim
), pdims
=
1241 | ((pageno'
, _
, _
, _
) as pdim
) :: rest
when pageno'
= pageno
->
1242 pdimno+1, pdim
, rest
1247 if pageno
= coverA
- 1 || pageno
= state
.pagecount
- coverB
1249 let x = (wadj + state
.winw
- w) / 2 in
1251 if conf
.presentation
then calcips
h else conf
.interpagespace
in
1252 x, y + ips + rowh
, h
1255 if (pageno
- coverA
) mod columns
= 0
1257 let x = max
0 (wadj + state
.winw
- state
.w) / 2 in
1259 if conf
.presentation
1261 let ips = calcips
h in
1262 y + (if pageno
= 0 then 0 else calcips rowh
+ ips)
1264 y + (if pageno
= 0 then 0 else conf
.interpagespace
)
1268 else x, y, max rowh
h
1272 if pageno
> 1 && (pageno
- coverA
) mod columns
= 0
1275 if pageno
= columns
&& conf
.presentation
1277 let ips = calcips rowh
in
1278 for i
= 0 to pred columns
1280 let (pdimno, x, y, pdim
) = a.(i
) in
1281 a.(i
) <- (pdimno, x, y+ips, pdim
)
1287 fixrow (pageno
- columns
);
1292 a.(pageno
) <- (pdimno, x, y, pdim
);
1293 let x = x + w + xoff
*2 + conf
.interpagespace
in
1294 loop (pageno
+1) pdimno pdim
x y rowh' pdims
1296 loop 0 ~
-1 (-1,-1,-1,-1) 0 0 0 state
.pdims
;
1297 conf
.columns
<- Cmulti
((columns
, coverA
, coverB
), a);
1300 let a = Array.make
(state
.pagecount
*c) (-1, -1, -1, (-1, -1, -1, -1)) in
1301 let rec loop pageno
pdimno pdim
y pdims
=
1302 if pageno
= state
.pagecount
1305 let pdimno, ((_
, w, h, _
) as pdim
), pdims
=
1307 | ((pageno'
, _
, _
, _
) as pdim
) :: rest
when pageno'
= pageno
->
1308 pdimno+1, pdim
, rest
1313 let rec loop1 n x y =
1314 if n = c then y else (
1315 a.(pageno
*c + n) <- (pdimno, x, y, pdim
);
1316 loop1 (n+1) (x+cw) (y + h + conf
.interpagespace
)
1319 let y = loop1 0 0 y in
1320 loop (pageno
+1) pdimno pdim
y pdims
1322 loop 0 ~
-1 (-1,-1,-1,-1) 0 state
.pdims
;
1323 conf
.columns
<- Csplit
(c, a);
1327 docolumns conf
.columns
;
1328 state
.maxy
<- calcheight
();
1329 if state
.reprf
== noreprf
1331 match state
.mode
with
1332 | Birdseye
(_
, _
, pageno
, _
, _
) ->
1333 let y, h = getpageyh pageno
in
1334 let top = (state
.winh
- h) / 2 in
1335 gotoy (max
0 (y - top))
1339 let y = getanchory state
.anchor in
1340 let y = min
y (state
.maxy
- state
.winw
- hscrollh ()) in
1345 state
.reprf
<- noreprf
;
1349 let reshape ?
(firsttime
=false) w h =
1350 GlDraw.viewport ~
x:0 ~
y:0 ~
w:w ~
h:h;
1351 if not firsttime
&& nogeomcmds state
.geomcmds
1352 then state
.anchor <- getanchor
();
1355 let w = wadjsb () + (truncate
(float w *. conf
.zoom
)) in
1358 setfontsize fstate
.fontsize
;
1359 GlMat.mode `modelview
;
1360 GlMat.load_identity
();
1362 GlMat.mode `projection
;
1363 GlMat.load_identity
();
1364 GlMat.rotate ~
x:1.0 ~angle
:180.0 ();
1365 GlMat.translate ~
x:~
-.1.0 ~
y:~
-.1.0 ();
1366 GlMat.scale3
(2.0 /. float state
.winw
, 2.0 /. float state
.winh
, 1.0);
1371 else float state
.x /. float state
.w
1373 invalidate "geometry"
1377 then state
.x <- truncate
(relx *. float w);
1379 match conf
.columns
with
1381 | Cmulti
((c, _
, _
), _
) -> (w - (c-1)*conf
.interpagespace
) / c
1382 | Csplit
(c, _
) -> w * c
1384 wcmd "geometry %d %d %d"
1385 w (stateh h) (FMTE.to_int conf
.fitmodel
)
1390 let len = String.length state
.text in
1391 let x0 = xadjsb () in
1394 match state
.mode
with
1395 | Textentry _
| View
| LinkNav _
->
1396 let h, _
, _
= state
.uioh#scrollpw
in
1401 filledrect x (float (state
.winh
- (fstate
.fontsize
+ 4) - hscrollh))
1402 (x+.w) (float (state
.winh
- hscrollh))
1405 let w = float (wadjsb () + state
.winw
- 1) in
1406 if state
.progress
>= 0.0 && state
.progress
< 1.0
1408 GlDraw.color (0.3, 0.3, 0.3);
1409 let w1 = w *. state
.progress
in
1411 GlDraw.color (0.0, 0.0, 0.0);
1412 rect (float x0+.w1) (float x0+.w-.w1)
1415 GlDraw.color (0.0, 0.0, 0.0);
1419 GlDraw.color (1.0, 1.0, 1.0);
1420 drawstring fstate
.fontsize
1421 (if conf
.leftscroll
then x0 + 2 else x0 + if len > 0 then 8 else 2)
1422 (state
.winh
- hscrollh - 5) s;
1425 match state
.mode
with
1426 | Textentry
((prefix
, text, _
, _
, _
, _
), _
) ->
1430 Printf.sprintf
"%s%s_ [%s]" prefix
text state
.text
1432 Printf.sprintf
"%s%s_" prefix
text
1438 | LinkNav _
-> state
.text
1443 if not
(istextentry state
.mode
) && state
.uioh#eformsgs
1445 let s1 = "(press 'e' to review error messasges)" in
1446 if nonemptystr
s then s ^
" " ^
s1 else s1
1456 let len = Queue.length state
.tilelru
in
1458 match state
.throttle
with
1461 then preloadlayout state
.x state
.y state
.winw state
.winh
1463 | Some
(layout, _
, _
) ->
1467 if state
.memused
<= conf
.memlimit
1472 let (k
, p
, s) as lruitem
= Queue.pop state
.tilelru
in
1473 let n, gen
, colorspace
, angle
, pagew
, pageh
, col, row = k
in
1474 let (_
, pw, ph
, _
) = getpagedim
n in
1477 && colorspace
= conf
.colorspace
1478 && angle
= conf
.angle
1482 let x = col*conf
.tilew
1483 and y = row*conf
.tileh
in
1484 tilevisible (Lazy.force_val
layout) n x y
1486 then Queue.push lruitem state
.tilelru
1489 wcmd "freetile %s" (~
> p
);
1490 state
.memused
<- state
.memused
- s;
1491 state
.uioh#infochanged Memused
;
1492 Hashtbl.remove state
.tilemap k
;
1500 let onpagerect pageno
f =
1502 match conf
.columns
with
1503 | Cmulti
(_
, b) -> b
1505 | Csplit
(_
, b) -> b
1507 if pageno
>= 0 && pageno
< Array.length
b
1509 let (_
, _
, _
, (_
, w, h, _
)) = b.(pageno
) in
1513 let gotopagexy1 wtmode pageno
x y =
1514 let _,w1,h1
,leftx
= getpagedim pageno
in
1515 let top = y /. (float h1
) in
1516 let left = x /. (float w1) in
1517 let py, w, h = getpageywh pageno
in
1518 let wh = state
.winh
- hscrollh () in
1519 let x = left *. (float w) in
1520 let x = leftx
+ state
.x + truncate
x in
1521 let wadj = wadjsb () in
1523 if x < 0 || x >= wadj + state
.winw
1527 let pdy = truncate
(top *. float h) in
1528 let y'
= py + pdy in
1529 let dy = y'
- state
.y in
1531 if x != state
.x || not
(dy > 0 && dy < wh)
1533 if conf
.presentation
1535 if abs
(py - y'
) > wh
1542 if state
.x != sx || state
.y != sy
1547 let ww = wadj + state
.winw
in
1549 and qy
= pdy / wh in
1551 and y = py + qy
* wh in
1552 let x = if -x + ww > w1 then -(w1-ww) else x
1553 and y'
= if y + wh > state
.maxy
then state
.maxy
- wh else y in
1555 if conf
.presentation
1557 if abs
(py - y'
) > wh
1567 gotoy_and_clear_text y;
1569 else gotoy_and_clear_text state
.y;
1572 let gotopagexy wtmode pageno
x y =
1573 match state
.mode
with
1574 | Birdseye
_ -> gotopage pageno
0.0
1577 | LinkNav
_ -> gotopagexy1 wtmode pageno
x y
1580 let getpassword () =
1581 let passcmd = getenvwithdef
"LLPP_ASKPASS" conf
.passcmd in
1586 impmsg "error getting password: %s" s;
1587 dolog
"%s" s) passcmd;
1590 let pgoto opaque pageno
x y =
1591 let pdimno = getpdimno pageno
in
1592 let x, y = project opaque pageno
pdimno x y in
1593 gotopagexy false pageno
x y;
1597 (* dolog "%S" cmds; *)
1598 let cl = splitatspace cmds
in
1600 try Scanf.sscanf
s fmt
f
1602 dolog
"error processing '%S': %s" cmds
@@ exntos exn
;
1605 let addoutline outline
=
1606 match state
.currently
with
1607 | Outlining outlines
->
1608 state
.currently
<- Outlining
(outline
:: outlines
)
1609 | Idle
-> state
.currently
<- Outlining
[outline
]
1612 dolog
"invalid outlining state";
1613 logcurrently state
.currently
1617 state
.uioh#infochanged Pdim
;
1620 | "clearrects" :: [] ->
1621 state
.rects
<- state
.rects1
;
1622 G.postRedisplay "clearrects";
1624 | "continue" :: args
:: [] ->
1625 let n = scan args
"%u" (fun n -> n) in
1626 state
.pagecount
<- n;
1627 begin match state
.currently
with
1629 state
.currently
<- Idle
;
1630 state
.outlines
<- Array.of_list
(List.rev
l)
1636 let cur, cmds
= state
.geomcmds
in
1638 then failwith
"umpossible";
1640 begin match List.rev cmds
with
1642 state
.geomcmds
<- E.s, [];
1643 state
.throttle
<- None
;
1647 state
.geomcmds
<- s, List.rev rest
;
1649 if conf
.maxwait
= None
&& not
!wtmode
1650 then G.postRedisplay "continue";
1652 | "msg" :: args
:: [] ->
1655 | "vmsg" :: args
:: [] ->
1657 then showtext ' ' args
1659 | "emsg" :: args
:: [] ->
1660 Buffer.add_string state
.errmsgs args
;
1661 state
.newerrmsgs
<- true;
1662 G.postRedisplay "error message"
1664 | "progress" :: args
:: [] ->
1665 let progress, text =
1668 f, String.sub args pos
(String.length args
- pos
))
1671 state
.progress <- progress;
1672 G.postRedisplay "progress"
1674 | "firstmatch" :: args
:: [] ->
1675 let pageno, c, x0, y0, x1, y1, x2
, y2
, x3
, y3
=
1676 scan args
"%u %d %f %f %f %f %f %f %f %f"
1677 (fun p
c x0 y0 x1 y1 x2 y2 x3 y3
->
1678 (p
, c, x0, y0, x1, y1, x2
, y2
, x3
, y3
))
1680 let xoff = float (xadjsb ()) in
1684 and x3
= x3
+. xoff in
1685 let y = (getpagey
pageno) + truncate
y0 in
1687 then state
.x <- truncate
(xoff -. x0) + state
.winw
/2;
1690 let color = (0.0, 0.0, 1.0 /. float c, 0.5) in
1691 state
.rects1
<- [pageno, color, (x0, y0, x1, y1, x2
, y2
, x3
, y3
)]
1693 | "match" :: args
:: [] ->
1694 let pageno, c, x0, y0, x1, y1, x2
, y2
, x3
, y3
=
1695 scan args
"%u %d %f %f %f %f %f %f %f %f"
1696 (fun p
c x0 y0 x1 y1 x2 y2 x3 y3
->
1697 (p
, c, x0, y0, x1, y1, x2
, y2
, x3
, y3
))
1699 let xoff = float (xadjsb ()) in
1703 and x3
= x3
+. xoff in
1704 let color = (0.0, 0.0, 1.0 /. float c, 0.5) in
1706 (pageno, color, (x0, y0, x1, y1, x2
, y2
, x3
, y3
)) :: state
.rects1
1708 | "page" :: args
:: [] ->
1709 let pageopaques, t
= scan args
"%s %f" (fun p t
-> p
, t
) in
1710 let pageopaque = ~
< pageopaques in
1711 begin match state
.currently
with
1712 | Loading
(l, gen
) ->
1713 vlog "page %d took %f sec" l.pageno t
;
1714 Hashtbl.replace state
.pagemap
(l.pageno, gen
) pageopaque;
1715 begin match state
.throttle
with
1717 let preloadedpages =
1719 then preloadlayout state
.x state
.y state
.winw state
.winh
1724 List.fold_left
(fun s l -> IntSet.add
l.pageno s)
1725 IntSet.empty
preloadedpages
1728 Hashtbl.fold (fun ((pageno, _) as key) opaque
accu ->
1729 if not
(IntSet.mem
pageno set)
1731 wcmd "freepage %s" (~
> opaque
);
1737 List.iter
(Hashtbl.remove state
.pagemap
) evictedpages;
1740 state
.currently
<- Idle
;
1743 tilepage l.pageno pageopaque state
.layout;
1745 load preloadedpages;
1746 let visible = pagevisible state
.layout l.pageno in
1749 match state
.mode
with
1750 | LinkNav
(Ltnotready
(pageno, dir
)) ->
1751 if pageno = l.pageno
1756 then LDfirstvisible
(l.pagex
, l.pagey, dir
)
1758 if dir
> 0 then LDfirst
else LDlast
1761 findlink
pageopaque ld
1766 showlinktype (getlink
pageopaque n);
1767 state
.mode
<- LinkNav
(Ltexact
(l.pageno, n))
1769 | LinkNav
(Ltgendir
_)
1770 | LinkNav
(Ltexact
_)
1776 if visible && layoutready state
.layout
1778 G.postRedisplay "page";
1782 | Some
(layout, _, _) ->
1783 state
.currently
<- Idle
;
1784 tilepage l.pageno pageopaque layout;
1791 dolog
"Inconsistent loading state";
1792 logcurrently state
.currently
;
1796 | "tile" :: args
:: [] ->
1797 let (x, y, opaques
, size
, t
) =
1798 scan args
"%u %u %s %u %f"
1799 (fun x y p size t
-> (x, y, p
, size
, t
))
1801 let opaque = ~
< opaques
in
1802 begin match state
.currently
with
1803 | Tiling
(l, pageopaque, cs
, angle
, gen
, col, row, tilew
, tileh
) ->
1804 vlog "tile %d [%d,%d] took %f sec" l.pageno col row t
;
1807 if tilew
!= conf
.tilew
|| tileh
!= conf
.tileh
1809 wcmd "freetile %s" (~
> opaque);
1810 state
.currently
<- Idle
;
1814 puttileopaque l col row gen cs angle
opaque size t
;
1815 state
.memused
<- state
.memused
+ size
;
1816 state
.uioh#infochanged Memused
;
1818 Queue.push
((l.pageno, gen
, cs
, angle
, l.pagew
, l.pageh
, col, row),
1819 opaque, size
) state
.tilelru
;
1822 match state
.throttle
with
1823 | None
-> state
.layout
1824 | Some
(layout, _, _) -> layout
1827 state
.currently
<- Idle
;
1829 && conf
.colorspace
= cs
1830 && conf
.angle
= angle
1831 && tilevisible layout l.pageno x y
1832 then conttiling l.pageno pageopaque;
1834 begin match state
.throttle
with
1836 preload state
.layout;
1838 && conf
.colorspace
= cs
1839 && conf
.angle
= angle
1840 && tilevisible state
.layout l.pageno x y
1841 && (not
!wtmode || layoutready state
.layout)
1842 then G.postRedisplay "tile nothrottle";
1844 | Some
(layout, y, _) ->
1845 let ready = layoutready layout in
1849 state
.layout <- layout;
1850 state
.throttle
<- None
;
1851 G.postRedisplay "throttle";
1860 dolog
"Inconsistent tiling state";
1861 logcurrently state
.currently
;
1865 | "pdim" :: args
:: [] ->
1866 let (n, w, h, _) as pdim
=
1867 scan args
"%u %u %u %u" (fun n w h x -> n, w, h, x)
1870 match conf
.fitmodel
with
1872 | FitPage
| FitProportional
->
1873 match conf
.columns
with
1874 | Csplit
_ -> (n, w, h, 0)
1875 | Csingle
_ | Cmulti
_ -> pdim
1877 state
.uioh#infochanged Pdim
;
1878 state
.pdims
<- pdim :: state
.pdims
1880 | "o" :: args
:: [] ->
1881 let (l, n, t
, h, pos
) =
1882 scan args
"%u %u %d %u %n"
1883 (fun l n t
h pos
-> l, n, t
, h, pos
)
1885 let s = String.sub args pos
(String.length args
- pos
) in
1886 addoutline (s, l, Oanchor
(n, float t
/. float h, 0.0))
1888 | "ou" :: args
:: [] ->
1889 let (l, len, pos
) = scan args
"%u %u %n" (fun l len pos
-> l, len, pos
) in
1890 let s = String.sub args pos
len in
1891 let pos2 = pos
+ len + 1 in
1892 let uri = String.sub args
pos2 (String.length args
- pos2) in
1893 addoutline (s, l, Ouri
uri)
1895 | "on" :: args
:: [] ->
1896 let (l, pos
) = scan args
"%u %n" (fun l pos
-> l, pos
) in
1897 let s = String.sub args pos
(String.length args
- pos
) in
1898 addoutline (s, l, Onone
)
1900 | "a" :: args
:: [] ->
1902 scan args
"%u %d %d" (fun n l t
-> n, l, t
)
1904 state
.reprf
<- (fun () -> gotopagexy !wtmode n (float l) (float t
))
1906 | "info" :: args
:: [] ->
1907 let pos = nindex args '
\t'
in
1908 if pos >= 0 && String.sub args
0 pos = "Title"
1910 let s = String.sub args
(pos+1) @@ String.length args
- pos - 1 in
1914 state
.docinfo
<- (1, args
) :: state
.docinfo
1916 | "infoend" :: [] ->
1917 state
.uioh#infochanged Docinfo
;
1918 state
.docinfo
<- List.rev state
.docinfo
1922 then Wsi.settitle
"Wrong password";
1923 let password = getpassword () in
1924 if emptystr
password
1925 then error
"document is password protected"
1926 else opendoc state
.path
password
1928 error
"unknown cmd `%S'" cmds
1933 let action = function
1934 | HCprev
-> cbget cb ~
-1
1935 | HCnext
-> cbget cb
1
1936 | HCfirst
-> cbget cb ~
-(cb
.rc)
1937 | HClast
-> cbget cb
(cb
.len - 1 - cb
.rc)
1938 and cancel
() = cb
.rc <- rc
1942 let search pattern forward
=
1943 match conf
.columns
with
1944 | Csplit
_ -> impmsg "searching does not work properly in split columns mode"
1947 if nonemptystr pattern
1950 match state
.layout with
1953 l.pageno, (l.pagey + if forward
then 0 else 0*l.pagevh)
1955 wcmd "search %d %d %d %d,%s\000"
1956 (btod conf
.icase
) pn py (btod forward
) pattern
;
1959 let intentry text key =
1961 if key >= 32 && key < 127
1967 let text = addchar
text c in
1971 state
.text <- Printf.sprintf
"invalid char (%d, `%c')" key c;
1979 let l = String.length
s in
1980 let rec loop pos n = if pos = l then n else
1981 let m = Char.code
s.[pos] - (if pos = 0 && l > 1 then 96 else 97) in
1982 loop (pos+1) (n*26 + m)
1985 let rec loop n = function
1988 match getopaque l.pageno with
1989 | None
-> loop n rest
1991 let m = getlinkcount
opaque in
1994 let under = getlink
opaque n in
1997 else loop (n-m) rest
1999 loop n state
.layout;
2003 let linknentry text key =
2005 if key >= 32 && key < 127
2011 let text = addchar
text c in
2012 linknact (fun under -> state
.text <- undertext ~nopath
:true under) text;
2016 state
.text <- Printf.sprintf
"invalid char (%d, `%c')" key c;
2020 let textentry text key =
2021 if key land 0xff00 = 0xff00
2023 else TEcont
(text ^ toutf8
key)
2026 let reqlayout angle fitmodel
=
2027 match state
.throttle
with
2029 if nogeomcmds state
.geomcmds
2030 then state
.anchor <- getanchor
();
2031 conf
.angle
<- angle
mod 360;
2034 match state
.mode
with
2035 | LinkNav
_ -> state
.mode
<- View
2040 conf
.fitmodel
<- fitmodel
;
2041 invalidate "reqlayout"
2043 wcmd "reqlayout %d %d %d"
2044 conf
.angle
(FMTE.to_int conf
.fitmodel
) (stateh state
.winh
)
2049 let settrim trimmargins trimfuzz
=
2050 if nogeomcmds state
.geomcmds
2051 then state
.anchor <- getanchor
();
2052 conf
.trimmargins
<- trimmargins
;
2053 conf
.trimfuzz
<- trimfuzz
;
2054 let x0, y0, x1, y1 = trimfuzz
in
2055 invalidate "settrim"
2057 wcmd "settrim %d %d %d %d %d" (btod conf
.trimmargins
) x0 y0 x1 y1);
2062 match state
.throttle
with
2064 let zoom = max
0.0001 zoom in
2065 if zoom <> conf
.zoom
2067 state
.prevzoom
<- (conf
.zoom, state
.x);
2069 reshape state
.winw state
.winh
;
2070 state
.text <- Printf.sprintf
"zoom is now %-5.2f" (zoom *. 100.0);
2073 | Some
(layout, y, started
) ->
2075 match conf
.maxwait
with
2079 let dt = now
() -. started
in
2087 let setcolumns mode columns coverA coverB
=
2088 state
.prevcolumns
<- Some
(conf
.columns
, conf
.zoom);
2092 then impmsg "split mode doesn't work in bird's eye"
2094 conf
.columns
<- Csplit
(-columns
, E.a);
2102 conf
.columns
<- Csingle
E.a;
2107 conf
.columns
<- Cmulti
((columns
, coverA
, coverB
), E.a);
2111 reshape state
.winw state
.winh
;
2114 let resetmstate () =
2115 state
.mstate
<- Mnone
;
2116 Wsi.setcursor
Wsi.CURSOR_INHERIT
;
2119 let enterbirdseye () =
2120 let zoom = float conf
.thumbw
/. float state
.winw
in
2121 let birdseyepageno =
2122 let cy = state
.winh
/ 2 in
2126 let rec fold best
= function
2129 let d = cy - (l.pagedispy + l.pagevh/2)
2130 and dbest
= cy - (best
.pagedispy + best
.pagevh/2) in
2131 if abs
d < abs dbest
2138 state
.mode
<- Birdseye
(
2139 { conf
with zoom = conf
.zoom }, state
.x, birdseyepageno, -1, getanchor
()
2143 conf
.presentation
<- false;
2144 conf
.interpagespace
<- 10;
2145 conf
.hlinks
<- false;
2146 conf
.fitmodel
<- FitPage
;
2148 conf
.maxwait
<- None
;
2150 match conf
.beyecolumns
with
2153 Cmulti
((c, 0, 0), E.a)
2154 | None
-> Csingle
E.a
2158 state
.text <- Printf.sprintf
"birds eye mode on (zoom %3.1f%%)"
2163 reshape state
.winw state
.winh
;
2166 let leavebirdseye (c, leftx
, pageno, _, anchor) goback
=
2168 conf
.zoom <- c.zoom;
2169 conf
.presentation
<- c.presentation
;
2170 conf
.interpagespace
<- c.interpagespace
;
2171 conf
.maxwait
<- c.maxwait
;
2172 conf
.hlinks
<- c.hlinks
;
2173 conf
.fitmodel
<- c.fitmodel
;
2174 conf
.beyecolumns
<- (
2175 match conf
.columns
with
2176 | Cmulti
((c, _, _), _) -> Some
c
2178 | Csplit
_ -> failwith
"leaving bird's eye split mode"
2181 match c.columns
with
2182 | Cmulti
(c, _) -> Cmulti
(c, E.a)
2183 | Csingle
_ -> Csingle
E.a
2184 | Csplit
(c, _) -> Csplit
(c, E.a)
2188 state
.text <- Printf.sprintf
"birds eye mode off (zoom %3.1f%%)"
2191 reshape state
.winw state
.winh
;
2192 state
.anchor <- if goback
then anchor else (pageno, 0.0, 1.0);
2196 let togglebirdseye () =
2197 match state
.mode
with
2198 | Birdseye vals
-> leavebirdseye vals
true
2199 | View
-> enterbirdseye ()
2204 let upbirdseye incr
(conf
, leftx
, pageno, hooverpageno
, anchor) =
2205 let pageno = max
0 (pageno - incr
) in
2206 let rec loop = function
2207 | [] -> gotopage1 pageno 0
2208 | l :: _ when l.pageno = pageno ->
2209 if l.pagedispy >= 0 && l.pagey = 0
2210 then G.postRedisplay "upbirdseye"
2211 else gotopage1 pageno 0
2212 | _ :: rest
-> loop rest
2216 state
.mode
<- Birdseye
(conf
, leftx
, pageno, hooverpageno
, anchor)
2219 let downbirdseye incr
(conf
, leftx
, pageno, hooverpageno
, anchor) =
2220 let pageno = min
(state
.pagecount
- 1) (pageno + incr
) in
2221 state
.mode
<- Birdseye
(conf
, leftx
, pageno, hooverpageno
, anchor);
2222 let rec loop = function
2224 let y, h = getpageyh
pageno in
2225 let dy = (y - state
.y) - (state
.winh
- h - conf
.interpagespace
) in
2227 | l :: _ when l.pageno = pageno ->
2228 if l.pagevh != l.pageh
2229 then gotoy (clamp (l.pageh
- l.pagevh + conf
.interpagespace
))
2230 else G.postRedisplay "downbirdseye"
2231 | _ :: rest
-> loop rest
2237 let optentry mode
_ key =
2238 let btos b = if b then "on" else "off" in
2239 if key >= 32 && key < 127
2241 let c = Char.chr
key in
2245 try conf
.scrollstep
<- int_of_string
s with exc
->
2246 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exc
2248 TEswitch
("scroll step: ", E.s, None
, intentry, ondone, true)
2253 conf
.autoscrollstep
<- boundastep state
.winh
(int_of_string
s);
2254 if state
.autoscroll
<> None
2255 then state
.autoscroll
<- Some conf
.autoscrollstep
2257 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exc
2259 TEswitch
("auto scroll step: ", E.s, None
, intentry, ondone, true)
2264 let n, a, b = multicolumns_of_string
s in
2265 setcolumns mode
n a b;
2267 state
.text <- Printf.sprintf
"bad columns `%s': %s" s @@ exntos exc
2269 TEswitch
("columns: ", E.s, None
, textentry, ondone, true)
2274 let zoom = float (int_of_string
s) /. 100.0 in
2277 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exc
2279 TEswitch
("zoom: ", E.s, None
, intentry, ondone, true)
2284 conf
.thumbw
<- bound
(int_of_string
s) 2 4096;
2286 Printf.sprintf
"thumbnail width is set to %d" conf
.thumbw
;
2287 begin match mode
with
2289 leavebirdseye beye
false;
2296 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exc
2298 TEswitch
("thumbnail width: ", E.s, None
, intentry, ondone, true)
2303 Some
(int_of_string
s)
2306 Printf.sprintf
"bad integer `%s': %s" s @@ exntos exc
;
2309 | Some angle
-> reqlayout angle conf
.fitmodel
2312 TEswitch
("rotation: ", E.s, None
, intentry, ondone, true)
2315 conf
.icase
<- not conf
.icase
;
2316 TEdone
("case insensitive search " ^
(btos conf
.icase
))
2319 conf
.preload <- not conf
.preload;
2321 TEdone
("preload " ^
(btos conf
.preload))
2324 conf
.verbose
<- not conf
.verbose
;
2325 TEdone
("verbose " ^
(btos conf
.verbose
))
2328 conf
.debug
<- not conf
.debug
;
2329 TEdone
("debug " ^
(btos conf
.debug
))
2332 conf
.maxhfit
<- not conf
.maxhfit
;
2333 state
.maxy
<- calcheight
();
2334 TEdone
("maxhfit " ^
(btos conf
.maxhfit
))
2337 conf
.crophack
<- not conf
.crophack
;
2338 TEdone
("crophack " ^
btos conf
.crophack
)
2342 match conf
.maxwait
with
2344 conf
.maxwait
<- Some infinity
;
2345 "always wait for page to complete"
2347 conf
.maxwait
<- None
;
2348 "show placeholder if page is not ready"
2353 conf
.underinfo
<- not conf
.underinfo
;
2354 TEdone
("underinfo " ^
btos conf
.underinfo
)
2357 conf
.savebmarks
<- not conf
.savebmarks
;
2358 TEdone
("persistent bookmarks " ^
btos conf
.savebmarks
)
2364 match state
.layout with
2369 conf
.interpagespace
<- int_of_string
s;
2370 docolumns conf
.columns
;
2371 state
.maxy
<- calcheight
();
2372 let y = getpagey
pageno in
2375 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exc
2377 TEswitch
("vertical margin: ", E.s, None
, intentry, ondone, true)
2381 match conf
.fitmodel
with
2382 | FitProportional
-> FitWidth
2383 | FitWidth
| FitPage
-> FitProportional
2385 reqlayout conf
.angle
fm;
2386 TEdone
("proportional display " ^
btos (fm == FitProportional
))
2389 settrim (not conf
.trimmargins
) conf
.trimfuzz
;
2390 TEdone
("trim margins " ^
btos conf
.trimmargins
)
2393 conf
.invert
<- not conf
.invert
;
2394 TEdone
("invert colors " ^
btos conf
.invert
)
2398 cbput state
.hists
.sel
s;
2401 TEswitch
("selection command: ", E.s, Some
(onhist state
.hists
.sel
),
2402 textentry, ondone, true)
2406 then conf
.pax
<- Some
(ref (0.0, 0, 0))
2407 else conf
.pax
<- None
;
2408 TEdone
("PAX " ^
btos (conf
.pax
!= None
))
2411 state
.text <- Printf.sprintf
"bad option %d `%c'" key c;
2417 class type lvsource
= object
2418 method getitemcount
: int
2419 method getitem
: int -> (string * int)
2420 method hasaction
: int -> bool
2428 method getactive
: int
2429 method getfirst
: int
2431 method getminfo
: (int * int) array
2434 class virtual lvsourcebase
= object
2435 val mutable m_active
= 0
2436 val mutable m_first
= 0
2437 val mutable m_pan
= 0
2438 method getactive
= m_active
2439 method getfirst
= m_first
2440 method getpan
= m_pan
2441 method getminfo
: (int * int) array
= E.a
2444 let textentrykeyboard
2445 key _mask
((c, text, opthist
, onkey
, ondone, cancelonempty
), onleave
) =
2448 if key >= 0xffb0 && key <= 0xffb9
2449 then key - 0xffb0 + 48 else key
2452 state
.mode
<- Textentry
(te
, onleave
);
2454 G.postRedisplay "textentrykeyboard enttext";
2456 let histaction cmd
=
2459 | Some
(action, _) ->
2460 state
.mode
<- Textentry
(
2461 (c, action cmd
, opthist
, onkey
, ondone, cancelonempty
), onleave
2463 G.postRedisplay "textentry histaction"
2467 if emptystr
text && cancelonempty
2470 G.postRedisplay "textentrykeyboard after cancel";
2473 let s = withoutlastutf8
text in
2474 enttext (c, s, opthist
, onkey
, ondone, cancelonempty
)
2476 | @enter
| @kpenter
->
2479 G.postRedisplay "textentrykeyboard after confirm"
2481 | @up
| @kpup
-> histaction HCprev
2482 | @down
| @kpdown
-> histaction HCnext
2483 | @home
| @kphome
-> histaction HCfirst
2484 | @jend
| @kpend
-> histaction HClast
2489 begin match opthist
with
2491 | Some
(_, onhistcancel
) -> onhistcancel
()
2495 G.postRedisplay "textentrykeyboard after cancel2"
2498 enttext (c, E.s, opthist
, onkey
, ondone, cancelonempty
)
2501 | @delete
| @kpdelete
-> ()
2504 && key land 0xff00 != 0xff00 (* keyboard *)
2505 && key land 0xfe00 != 0xfe00 (* xkb *)
2506 && key land 0xfd00 != 0xfd00 (* 3270 *)
2508 begin match onkey
text key with
2512 G.postRedisplay "textentrykeyboard after confirm2";
2515 enttext (c, text, opthist
, onkey
, ondone, cancelonempty
);
2519 G.postRedisplay "textentrykeyboard after cancel3"
2522 state
.mode
<- Textentry
(te
, onleave
);
2523 G.postRedisplay "textentrykeyboard switch";
2527 vlog "unhandled key %s" (Wsi.keyname
key)
2530 let firstof first active
=
2531 if first
> active
|| abs
(first
- active
) > fstate
.maxrows
- 1
2532 then max
0 (active
- (fstate
.maxrows
/2))
2536 let calcfirst first active
=
2539 let rows = active
- first
in
2540 if rows > fstate
.maxrows
then active
- fstate
.maxrows
else first
2544 let scrollph y maxy
=
2545 let sh = float (maxy
+ state
.winh
) /. float state
.winh
in
2546 let sh = float state
.winh
/. sh in
2547 let sh = max
sh (float conf
.scrollh
) in
2549 let percent = float y /. float maxy
in
2550 let position = (float state
.winh
-. sh) *. percent in
2553 if position +. sh > float state
.winh
2554 then float state
.winh
-. sh
2560 let coe s = (s :> uioh
);;
2562 class listview ~zebra ~helpmode ~
(source
:lvsource
) ~trusted ~modehash
=
2564 val m_pan
= source#getpan
2565 val m_first
= source#getfirst
2566 val m_active
= source#getactive
2568 val m_prev_uioh
= state
.uioh
2570 method private elemunder
y =
2574 let n = y / (fstate
.fontsize
+1) in
2575 if m_first
+ n < source#getitemcount
2577 if source#hasaction
(m_first
+ n)
2578 then Some
(m_first
+ n)
2585 GlFunc.blend_func ~src
:`src_alpha ~dst
:`one_minus_src_alpha
;
2586 GlDraw.color (0., 0., 0.) ~alpha
:0.85;
2587 filledrect 0. 0. (float state
.winw
) (float state
.winh
);
2588 GlDraw.color (1., 1., 1.);
2589 Gl.enable `texture_2d
;
2590 let fs = fstate
.fontsize
in
2592 let hw = (wadjsb () + xadjsb () + state
.winw
)/3 in
2593 let ww = fstate
.wwidth
in
2594 let tabw = 17.0*.ww in
2595 let itemcount = source#getitemcount
in
2596 let minfo = source#getminfo
in
2599 then float (xadjsb ()), float (state
.winw
- 1)
2600 else 0.0, float (state
.winw
- conf
.scrollbw
- 1)
2602 let xadj = xadjsb () in
2604 if (row - m_first
) > fstate
.maxrows
2607 if row >= 0 && row < itemcount
2609 let (s, level
) = source#getitem
row in
2610 let y = (row - m_first
) * nfs in
2612 (if conf
.leftscroll
then float xadj else 5.0)
2613 +. (float (level
+ m_pan
)) *. ww in
2616 (let c = if row land 1 = 0 then 1.0 else 0.92 in (c,c,c));
2620 Gl.disable `texture_2d
;
2621 let alpha = if source#hasaction
row then 0.9 else 0.3 in
2622 GlDraw.color (1., 1., 1.) ~
alpha;
2623 linerect (x0 +. 1.) (float (y + 1)) (x1) (float (y + fs + 3));
2624 Gl.enable `texture_2d
;
2627 if zebra
&& row land 1 = 1
2631 GlDraw.color (c,c,c);
2632 let drawtabularstring s =
2634 let x'
= truncate
(x0 +. x) in
2635 let pos = nindex
s '
\000'
in
2637 then drawstring1 fs x'
(y+nfs) s
2639 let s1 = String.sub
s 0 pos
2640 and s2
= String.sub
s (pos+1) (String.length
s - pos - 1) in
2645 let s'
= withoutlastutf8
s in
2646 let s = s' ^
"@Uellipsis" in
2647 let w = measurestr
fs s in
2648 if float x'
+. w +. ww < float (hw + x'
)
2653 if float x'
+. ww +. measurestr
fs s1 > float (hw + x'
)
2657 ignore
(drawstring1 fs x'
(y+nfs) s1);
2658 drawstring1 fs (hw + x'
) (y+nfs) s2
2662 let x = if helpmode
&& row > 0 then x +. ww else x in
2663 let tabpos = nindex
s '
\t'
in
2666 let len = String.length
s - tabpos - 1 in
2667 let s1 = String.sub
s 0 tabpos
2668 and s2
= String.sub
s (tabpos + 1) len in
2669 let nx = drawstr x s1 in
2671 let x = x +. (max
tabw sw) in
2674 let len = String.length
s - 2 in
2675 if len > 0 && s.[0] = '
\xc2'
&& s.[1] = '
\xb7'
2677 let s = String.sub
s 2 len in
2678 let x = if not helpmode
then x +. ww else x in
2679 GlDraw.color (1.2, 1.2, 1.2);
2680 let vinc = drawstring1 (fs+fs/4)
2681 (truncate
(x -. ww)) (y+nfs) s in
2682 GlDraw.color (1., 1., 1.);
2683 vinc +. (float fs *. 0.8)
2689 ignore
(drawtabularstring s);
2695 GlDraw.color (1.0, 1.0, 1.0) ~
alpha:0.5;
2696 let xadj = float (xadjsb () + 5) in
2698 if (row - m_first
) > fstate
.maxrows
2701 if row >= 0 && row < itemcount
2703 let (s, level
) = source#getitem
row in
2704 let pos0 = nindex
s '
\000'
in
2705 let y = (row - m_first
) * nfs in
2706 let x = float (level
+ m_pan
) *. ww in
2707 let (first
, last
) = minfo.(row) in
2709 if pos0 > 0 && first
> pos0
2710 then String.sub
s (pos0+1) (first
-pos0-1)
2711 else String.sub
s 0 first
2713 let suffix = String.sub
s first
(last
- first
) in
2714 let w1 = measurestr fstate
.fontsize
prefix in
2715 let w2 = measurestr fstate
.fontsize
suffix in
2716 let x = x +. if conf
.leftscroll
then xadj else 5.0 in
2717 let x = if pos0 > 0 && first
> pos0 then x +. float hw else x in
2719 and y0 = float (y+2) in
2721 and y1 = float (y+fs+3) in
2722 filledrect x0 y0 x1 y1;
2727 Gl.disable `texture_2d
;
2728 if Array.length
minfo > 0 then loop m_first
;
2731 method updownlevel incr
=
2732 let len = source#getitemcount
in
2734 if m_active
>= 0 && m_active
< len
2735 then snd
(source#getitem m_active
)
2739 if i
= len then i
-1 else if i
= -1 then 0 else
2740 let _, l = source#getitem i
in
2741 if l != curlevel then i
else flow (i
+incr
)
2743 let active = flow m_active
in
2744 let first = calcfirst m_first
active in
2745 G.postRedisplay "outline updownlevel";
2746 {< m_active
= active; m_first
= first >}
2748 method private key1
key mask
=
2749 let set1 active first qsearch
=
2750 coe {< m_active
= active; m_first
= first; m_qsearch
= qsearch
>}
2752 let search active pattern incr
=
2753 let active = if active = -1 then m_first
else active in
2756 if n >= 0 && n < source#getitemcount
2758 let s, _ = source#getitem
n in
2759 match Str.search_forward re
s 0 with
2760 | (exception Not_found
) -> loop (n + incr
)
2767 Str.regexp_case_fold pattern
|> dosearch
2769 let itemcount = source#getitemcount
in
2770 let find start incr
=
2772 if i
= -1 || i
= itemcount
2775 if source#hasaction i
2777 else find (i
+ incr
)
2782 let set active first =
2783 let first = bound
first 0 (itemcount - fstate
.maxrows
) in
2785 coe {< m_active
= active; m_first
= first; m_qsearch
= E.s >}
2788 let isvisible first n = n >= first && n - first <= fstate
.maxrows
in
2790 let incr1 = if incr
> 0 then 1 else -1 in
2791 if isvisible m_first m_active
2794 let next = m_active
+ incr
in
2796 if next < 0 || next >= itemcount
2798 else find next incr1
2800 if abs
(m_active
- next) > fstate
.maxrows
2806 let first = m_first
+ incr
in
2807 let first = bound
first 0 (itemcount - fstate
.maxrows
) in
2809 let next = m_active
+ incr
in
2810 let next = bound
next 0 (itemcount - 1) in
2817 if isvisible first next
2824 let first = min
next m_first
in
2826 if abs
(next - first) > fstate
.maxrows
2832 let first = m_first
+ incr
in
2833 let first = bound
first 0 (itemcount - 1) in
2835 let next = m_active
+ incr
in
2836 let next = bound
next 0 (itemcount - 1) in
2837 let next = find next incr1 in
2839 if next = -1 || abs
(m_active
- first) > fstate
.maxrows
2841 let active = if m_active
= -1 then next else m_active
in
2846 if isvisible first active
2852 G.postRedisplay "listview navigate";
2856 | (@r
|@s) when Wsi.withctrl mask
->
2857 let incr = if key = @r
then -1 else 1 in
2859 match search (m_active
+ incr) m_qsearch
incr with
2861 state
.text <- m_qsearch ^
" [not found]";
2864 state
.text <- m_qsearch
;
2865 active, firstof m_first
active
2867 G.postRedisplay "listview ctrl-r/s";
2868 set1 active first m_qsearch
;
2870 | @insert
when Wsi.withctrl mask
->
2871 if m_active
>= 0 && m_active
< source#getitemcount
2873 let s, _ = source#getitem m_active
in
2879 if emptystr m_qsearch
2882 let qsearch = withoutlastutf8 m_qsearch
in
2886 G.postRedisplay "listview empty qsearch";
2887 set1 m_active m_first
E.s;
2891 match search m_active
qsearch ~
-1 with
2893 state
.text <- qsearch ^
" [not found]";
2896 state
.text <- qsearch;
2897 active, firstof m_first
active
2899 G.postRedisplay "listview backspace qsearch";
2900 set1 active first qsearch
2903 | key when (key != 0 && key land 0xff00 != 0xff00) ->
2904 let pattern = m_qsearch ^ toutf8
key in
2906 match search m_active
pattern 1 with
2908 state
.text <- pattern ^
" [not found]";
2911 state
.text <- pattern;
2912 active, firstof m_first
active
2914 G.postRedisplay "listview qsearch add";
2915 set1 active first pattern;
2919 if emptystr m_qsearch
2921 G.postRedisplay "list view escape";
2922 let mx, my
= state
.mpos
in
2926 source#exit ~uioh
:(coe self
)
2927 ~cancel
:true ~
active:m_active ~
first:m_first ~pan
:m_pan
2929 | None
-> m_prev_uioh
2934 G.postRedisplay "list view kill qsearch";
2935 coe {< m_qsearch
= E.s >}
2938 | @enter
| @kpenter
->
2940 let self = {< m_qsearch
= E.s >} in
2942 G.postRedisplay "listview enter";
2943 if m_active
>= 0 && m_active
< source#getitemcount
2945 source#exit ~uioh
:(coe self) ~cancel
:false
2946 ~
active:m_active ~
first:m_first ~pan
:m_pan
;
2949 source#exit ~uioh
:(coe self) ~cancel
:true
2950 ~
active:m_active ~
first:m_first ~pan
:m_pan
;
2953 begin match opt with
2954 | None
-> m_prev_uioh
2958 | @delete
| @kpdelete
->
2961 | @up
| @kpup
-> navigate ~
-1
2962 | @down
| @kpdown
-> navigate 1
2963 | @prior
| @kpprior
-> navigate ~
-(fstate
.maxrows
)
2964 | @next | @kpnext
-> navigate fstate
.maxrows
2966 | @right
| @kpright
->
2968 G.postRedisplay "listview right";
2969 coe {< m_pan
= m_pan
- 1 >}
2971 | @left | @kpleft
->
2973 G.postRedisplay "listview left";
2974 coe {< m_pan
= m_pan
+ 1 >}
2976 | @home
| @kphome
->
2977 let active = find 0 1 in
2978 G.postRedisplay "listview home";
2982 let first = max
0 (itemcount - fstate
.maxrows
) in
2983 let active = find (itemcount - 1) ~
-1 in
2984 G.postRedisplay "listview end";
2987 | key when (key = 0 || key land 0xff00 = 0xff00) ->
2991 dolog
"listview unknown key %#x" key; coe self
2993 method key key mask
=
2994 match state
.mode
with
2995 | Textentry te
-> textentrykeyboard key mask te
; coe self
2998 | LinkNav
_ -> self#key1
key mask
3000 method button button down
x y _ =
3003 | 1 when vscrollhit x ->
3004 G.postRedisplay "listview scroll";
3007 let _, position, sh = self#
scrollph in
3008 if y > truncate
position && y < truncate
(position +. sh)
3010 state
.mstate
<- Mscrolly
;
3014 let s = float (max
0 (y - conf
.scrollh
)) /. float state
.winh
in
3015 let first = truncate
(s *. float source#getitemcount
) in
3016 let first = min source#getitemcount
first in
3017 Some
(coe {< m_first
= first; m_active
= first >})
3019 state
.mstate
<- Mnone
;
3023 begin match self#elemunder
y with
3025 G.postRedisplay "listview click";
3026 source#exit ~uioh
:(coe {< m_active
= n >})
3027 ~cancel
:false ~
active:n ~
first:m_first ~pan
:m_pan
3031 | n when (n == 4 || n == 5) && not down
->
3032 let len = source#getitemcount
in
3034 if n = 5 && m_first
+ fstate
.maxrows
>= len
3038 let first = m_first
+ (if n == 4 then -1 else 1) in
3039 bound
first 0 (len - 1)
3041 G.postRedisplay "listview wheel";
3042 Some
(coe {< m_first
= first >})
3043 | n when (n = 6 || n = 7) && not down
->
3044 let inc = if n = 7 then -1 else 1 in
3045 G.postRedisplay "listview hwheel";
3046 Some
(coe {< m_pan
= m_pan
+ inc >})
3051 | None
-> m_prev_uioh
3054 method multiclick
_ x y = self#button
1 true x y
3057 match state
.mstate
with
3059 let s = float (max
0 (y - conf
.scrollh
)) /. float state
.winh
in
3060 let first = truncate
(s *. float source#getitemcount
) in
3061 let first = min source#getitemcount
first in
3062 G.postRedisplay "listview motion";
3063 coe {< m_first
= first; m_active
= first >}
3071 method pmotion
x y =
3072 if x < state
.winw
- conf
.scrollbw
3075 match self#elemunder
y with
3076 | None
-> Wsi.setcursor
Wsi.CURSOR_INHERIT
; m_active
3077 | Some
n -> Wsi.setcursor
Wsi.CURSOR_INFO
; n
3081 then (G.postRedisplay "listview pmotion"; {< m_active
= n >})
3086 Wsi.setcursor
Wsi.CURSOR_INHERIT
;
3090 method infochanged
_ = ()
3092 method scrollpw
= (0, 0.0, 0.0)
3094 let nfs = fstate
.fontsize
+ 1 in
3095 let y = m_first
* nfs in
3096 let itemcount = source#getitemcount
in
3097 let maxi = max
0 (itemcount - fstate
.maxrows
) in
3098 let maxy = maxi * nfs in
3099 let p, h = scrollph y maxy in
3102 method modehash
= modehash
3103 method eformsgs
= false
3104 method alwaysscrolly
= true
3107 class outlinelistview ~zebra ~source
=
3108 let settext autonarrow
s =
3111 let ss = source#statestr
in
3115 else "{" ^
ss ^
"} [" ^
s ^
"]"
3116 else state
.text <- s
3122 ~source
:(source
:> lvsource
)
3124 ~modehash
:(findkeyhash conf
"outline")
3127 val m_autonarrow
= false
3129 method! key key mask
=
3131 if emptystr state
.text
3133 else fstate
.maxrows - 2
3135 let calcfirst first active =
3138 let rows = active - first in
3139 if rows > maxrows then active - maxrows else first
3143 let active = m_active
+ incr in
3144 let active = bound
active 0 (source#getitemcount
- 1) in
3145 let first = calcfirst m_first
active in
3146 G.postRedisplay "outline navigate";
3147 coe {< m_active
= active; m_first
= first >}
3149 let navscroll first =
3151 let dist = m_active
- first in
3157 else first + maxrows
3160 G.postRedisplay "outline navscroll";
3161 coe {< m_first
= first; m_active
= active >}
3163 let ctrl = Wsi.withctrl mask
in
3168 then (source#denarrow
; E.s)
3170 let pattern = source#renarrow
in
3171 if nonemptystr m_qsearch
3172 then (source#narrow m_qsearch
; m_qsearch
)
3176 settext (not m_autonarrow
) text;
3177 G.postRedisplay "toggle auto narrowing";
3178 coe {< m_first
= 0; m_active
= 0; m_autonarrow
= not m_autonarrow
>}
3180 | @slash
when emptystr m_qsearch
&& not m_autonarrow
->
3182 G.postRedisplay "toggle auto narrowing";
3183 coe {< m_first
= 0; m_active
= 0; m_autonarrow
= true >}
3186 source#narrow m_qsearch
;
3188 then source#add_narrow_pattern m_qsearch
;
3189 G.postRedisplay "outline ctrl-n";
3190 coe {< m_first
= 0; m_active
= 0 >}
3193 let active = source#calcactive
(getanchor
()) in
3194 let first = firstof m_first
active in
3195 G.postRedisplay "outline ctrl-s";
3196 coe {< m_first
= first; m_active
= active >}
3199 G.postRedisplay "outline ctrl-u";
3200 if m_autonarrow
&& nonemptystr m_qsearch
3202 ignore
(source#renarrow
);
3203 settext m_autonarrow
E.s;
3204 coe {< m_first
= 0; m_active
= 0; m_qsearch
= E.s >}
3207 source#del_narrow_pattern
;
3208 let pattern = source#renarrow
in
3210 if emptystr
pattern then E.s else "Narrowed to " ^
pattern
3212 settext m_autonarrow
text;
3213 coe {< m_first
= 0; m_active
= 0; m_qsearch
= E.s >}
3217 let first = max
0 (m_active
- (fstate
.maxrows / 2)) in
3218 G.postRedisplay "outline ctrl-l";
3219 coe {< m_first
= first >}
3221 | @tab
when m_autonarrow
->
3222 if nonemptystr m_qsearch
3224 G.postRedisplay "outline list view tab";
3225 source#add_narrow_pattern m_qsearch
;
3227 coe {< m_qsearch
= E.s >}
3231 | @escape
when m_autonarrow
->
3232 if nonemptystr m_qsearch
3233 then source#add_narrow_pattern m_qsearch
;
3236 | @enter
| @kpenter
when m_autonarrow
->
3237 if nonemptystr m_qsearch
3238 then source#add_narrow_pattern m_qsearch
;
3241 | key when m_autonarrow
&& (key != 0 && key land 0xff00 != 0xff00) ->
3242 let pattern = m_qsearch ^ toutf8
key in
3243 G.postRedisplay "outlinelistview autonarrow add";
3244 source#narrow
pattern;
3245 settext true pattern;
3246 coe {< m_first
= 0; m_active
= 0; m_qsearch
= pattern >}
3248 | key when m_autonarrow
&& key = @backspace
->
3249 if emptystr m_qsearch
3252 let pattern = withoutlastutf8 m_qsearch
in
3253 G.postRedisplay "outlinelistview autonarrow backspace";
3254 ignore
(source#renarrow
);
3255 source#narrow
pattern;
3256 settext true pattern;
3257 coe {< m_first
= 0; m_active
= 0; m_qsearch
= pattern >}
3259 | @up
| @kpup
when ctrl ->
3260 navscroll (max
0 (m_first
- 1))
3262 | @down
| @kpdown
when ctrl ->
3263 navscroll (min
(source#getitemcount
- 1) (m_first
+ 1))
3265 | @up
| @kpup
-> navigate ~
-1
3266 | @down
| @kpdown
-> navigate 1
3267 | @prior
| @kpprior
-> navigate ~
-(fstate
.maxrows)
3268 | @next | @kpnext
-> navigate fstate
.maxrows
3270 | @right
| @kpright
->
3274 G.postRedisplay "outline ctrl right";
3275 {< m_pan
= m_pan
+ 1 >}
3277 else self#updownlevel
1
3281 | @left | @kpleft
->
3285 G.postRedisplay "outline ctrl left";
3286 {< m_pan
= m_pan
- 1 >}
3288 else self#updownlevel ~
-1
3292 | @home
| @kphome
->
3293 G.postRedisplay "outline home";
3294 coe {< m_first
= 0; m_active
= 0 >}
3297 let active = source#getitemcount
- 1 in
3298 let first = max
0 (active - fstate
.maxrows) in
3299 G.postRedisplay "outline end";
3300 coe {< m_active
= active; m_first
= first >}
3302 | _ -> super#
key key mask
3305 let genhistoutlines () =
3307 |> List.sort
(fun (_, c1
, _, _, _, _) (_, c2
, _, _, _, _) ->
3308 compare c2
.lastvisit c1
.lastvisit
)
3310 (fun ((path
, c, _, _, _, origin
) as hist
) ->
3311 let path = if nonemptystr origin
then origin
else path in
3312 let base = mbtoutf8
@@ Filename.basename
path in
3313 (base ^
"\000" ^
c.title
, 1, Ohistory hist
)
3318 let gotohist (path, c, bookmarks
, x, anchor, origin
) =
3319 Config.save
leavebirdseye;
3320 state
.anchor <- anchor;
3321 state
.bookmarks
<- bookmarks
;
3322 state
.origin
<- origin
;
3325 let x0, y0, x1, y1 = conf
.trimfuzz
in
3326 wcmd "trimset %d %d %d %d %d" (btod conf
.trimmargins
) x0 y0 x1 y1;
3327 reshape ~firsttime
:true state
.winw state
.winh
;
3328 opendoc path origin
;
3332 let makecheckers () =
3333 (* Based on lablGL-1.04/LablGlut/examples/lablGL/checker.ml which had
3335 converted by Issac Trotts. July 25, 2002 *)
3336 let image = GlPix.create `ubyte ~format
:`luminance ~width
:2 ~height
:2 in
3337 Raw.sets_string
(GlPix.to_raw
image) ~
pos:0 "\255\200\200\255";
3338 let id = GlTex.gen_texture
() in
3339 GlTex.bind_texture ~target
:`texture_2d
id;
3340 GlPix.store
(`unpack_alignment
1);
3341 GlTex.image2d
image;
3342 List.iter
(GlTex.parameter ~target
:`texture_2d
)
3343 [ `mag_filter `nearest
; `min_filter `nearest
];
3347 let setcheckers enabled
=
3348 match state
.checkerstexid
with
3350 if enabled
then state
.checkerstexid
<- Some
(makecheckers ())
3352 | Some checkerstexid
->
3355 GlTex.delete_texture checkerstexid
;
3356 state
.checkerstexid
<- None
;
3360 let describe_location () =
3361 let fn = page_of_y state
.y in
3362 let ln = page_of_y
(state
.y + state
.winh
- hscrollh () - 1) in
3363 let maxy = state
.maxy - (if conf
.maxhfit
then state
.winh
else 0) in
3367 else (100. *. (float state
.y /. float maxy))
3371 Printf.sprintf
"page %d of %d [%.2f%%]"
3372 (fn+1) state
.pagecount
percent
3375 "pages %d-%d of %d [%.2f%%]"
3376 (fn+1) (ln+1) state
.pagecount
percent
3379 let setpresentationmode v
=
3380 let n = page_of_y state
.y in
3381 state
.anchor <- (n, 0.0, 1.0);
3382 conf
.presentation
<- v
;
3383 if conf
.fitmodel
= FitPage
3384 then reqlayout conf
.angle conf
.fitmodel
;
3388 let setbgcol (r
, g, b) =
3390 let r = r *. 255.0 |> truncate
3391 and g = g *. 255.0 |> truncate
3392 and b = b *. 255.0 |> truncate
in
3393 r lsl 16 |> (lor) (g lsl 8) |> (lor) b
3395 Wsi.setwinbgcol
col;
3399 let btos b = if b then "@Uradical" else E.s in
3400 let showextended = ref false in
3401 let leave mode
_ = state
.mode
<- mode
in
3404 val mutable m_l
= []
3405 val mutable m_a
= E.a
3406 val mutable m_prev_uioh
= nouioh
3407 val mutable m_prev_mode
= View
3409 inherit lvsourcebase
3411 method reset prev_mode prev_uioh
=
3412 m_a
<- Array.of_list
(List.rev m_l
);
3414 m_prev_mode
<- prev_mode
;
3415 m_prev_uioh
<- prev_uioh
;
3417 method int name get
set =
3419 (name
, `
int get
, 1, Action
(
3422 try set (int_of_string
s)
3424 state
.text <- Printf.sprintf
"bad integer `%s': %s"
3428 let te = name ^
": ", E.s, None
, intentry, ondone, true in
3429 state
.mode
<- Textentry
(te, leave m_prev_mode
);
3433 method int_with_suffix name get
set =
3435 (name
, `intws get
, 1, Action
(
3438 try set (int_of_string_with_suffix
s)
3440 state
.text <- Printf.sprintf
"bad integer `%s': %s"
3445 name ^
": ", E.s, None
, intentry_with_suffix, ondone, true
3447 state
.mode
<- Textentry
(te, leave m_prev_mode
);
3451 method bool ?
(offset
=1) ?
(btos=btos) name get
set =
3453 (name
, `
bool (btos, get
), offset
, Action
(
3460 method color name get
set =
3462 (name
, `
color get
, 1, Action
(
3464 let invalid = (nan
, nan
, nan
) in
3467 try color_of_string
s
3469 state
.text <- Printf.sprintf
"bad color `%s': %s"
3476 let te = name ^
": ", E.s, None
, textentry, ondone, true in
3477 state
.text <- color_to_string
(get
());
3478 state
.mode
<- Textentry
(te, leave m_prev_mode
);
3482 method string name get
set =
3484 (name
, `
string get
, 1, Action
(
3486 let ondone s = set s in
3487 let te = name ^
": ", E.s, None
, textentry, ondone, true in
3488 state
.mode
<- Textentry
(te, leave m_prev_mode
);
3492 method colorspace name get
set =
3494 (name
, `
string get
, 1, Action
(
3498 inherit lvsourcebase
3501 m_active
<- CSTE.to_int conf
.colorspace
;
3504 method getitemcount
=
3505 Array.length
CSTE.names
3508 method exit ~uioh ~cancel ~
active ~
first ~pan
=
3509 ignore
(uioh
, first, pan
);
3510 if not cancel
then set active;
3512 method hasaction
_ = true
3516 let modehash = findkeyhash conf
"info" in
3517 coe (new listview ~zebra
:false ~helpmode
:false
3518 ~
source ~trusted
:true ~
modehash)
3521 method paxmark name get
set =
3523 (name
, `
string get
, 1, Action
(
3527 inherit lvsourcebase
3530 m_active
<- MTE.to_int conf
.paxmark
;
3533 method getitemcount
= Array.length
MTE.names
3534 method getitem
n = (MTE.names
.(n), 0)
3535 method exit ~uioh ~cancel ~
active ~
first ~pan
=
3536 ignore
(uioh
, first, pan
);
3537 if not cancel
then set active;
3539 method hasaction
_ = true
3543 let modehash = findkeyhash conf
"info" in
3544 coe (new listview ~zebra
:false ~helpmode
:false
3545 ~
source ~trusted
:true ~
modehash)
3548 method fitmodel name get
set =
3550 (name
, `
string get
, 1, Action
(
3554 inherit lvsourcebase
3557 m_active
<- FMTE.to_int conf
.fitmodel
;
3560 method getitemcount
= Array.length
FMTE.names
3561 method getitem
n = (FMTE.names
.(n), 0)
3562 method exit ~uioh ~cancel ~
active ~
first ~pan
=
3563 ignore
(uioh
, first, pan
);
3564 if not cancel
then set active;
3566 method hasaction
_ = true
3570 let modehash = findkeyhash conf
"info" in
3571 coe (new listview ~zebra
:false ~helpmode
:false
3572 ~
source ~trusted
:true ~
modehash)
3575 method caption
s offset
=
3576 m_l
<- (s, `empty
, offset
, Noaction
) :: m_l
3578 method caption2
s f offset
=
3579 m_l
<- (s, `
string f, offset
, Noaction
) :: m_l
3581 method getitemcount
= Array.length m_a
3584 let tostr = function
3585 | `
int f -> string_of_int
(f ())
3586 | `intws
f -> string_with_suffix_of_int
(f ())
3588 | `
color f -> color_to_string
(f ())
3589 | `
bool (btos, f) -> btos (f ())
3592 let name, t
, offset
, _ = m_a
.(n) in
3593 ((let s = tostr t
in
3595 then Printf.sprintf
"%s\t%s" name s
3599 method exit ~uioh ~cancel ~
active ~
first ~pan
=
3604 match m_a
.(active) with
3605 | _, _, _, Action
f -> f uioh
3606 | _, _, _, Noaction
-> uioh
3617 method hasaction
n =
3619 | _, _, _, Action
_ -> true
3620 | _, _, _, Noaction
-> false
3622 initializer m_active
<- 1
3625 let rec fillsrc prevmode prevuioh
=
3626 let sep () = src#caption
E.s 0 in
3627 let colorp name get
set =
3629 (fun () -> color_to_string
(get
()))
3632 let c = color_of_string
v in
3635 state
.text <- Printf.sprintf
"bad color `%s': %s" v @@ exntos exn
3638 let oldmode = state
.mode
in
3639 let birdseye = isbirdseye state
.mode
in
3641 src#caption
(if birdseye then "Setup (Bird's eye)" else "Setup") 0;
3643 src#
bool "presentation mode"
3644 (fun () -> conf
.presentation
)
3645 (fun v -> setpresentationmode v);
3647 src#
bool "ignore case in searches"
3648 (fun () -> conf
.icase
)
3649 (fun v -> conf
.icase
<- v);
3652 (fun () -> conf
.preload)
3653 (fun v -> conf
.preload <- v);
3655 src#
bool "highlight links"
3656 (fun () -> conf
.hlinks
)
3657 (fun v -> conf
.hlinks
<- v);
3659 src#
bool "under info"
3660 (fun () -> conf
.underinfo
)
3661 (fun v -> conf
.underinfo
<- v);
3663 src#
bool "persistent bookmarks"
3664 (fun () -> conf
.savebmarks
)
3665 (fun v -> conf
.savebmarks
<- v);
3667 src#fitmodel
"fit model"
3668 (fun () -> FMTE.to_string conf
.fitmodel
)
3669 (fun v -> reqlayout conf
.angle
(FMTE.of_int
v));
3671 src#
bool "trim margins"
3672 (fun () -> conf
.trimmargins
)
3673 (fun v -> settrim v conf
.trimfuzz
; fillsrc prevmode prevuioh
);
3675 src#
bool "persistent location"
3676 (fun () -> conf
.jumpback
)
3677 (fun v -> conf
.jumpback
<- v);
3680 src#
int "inter-page space"
3681 (fun () -> conf
.interpagespace
)
3683 conf
.interpagespace
<- n;
3684 docolumns conf
.columns
;
3686 match state
.layout with
3691 state
.maxy <- calcheight
();
3692 let y = getpagey
pageno in
3697 (fun () -> conf
.pagebias
)
3698 (fun v -> conf
.pagebias
<- v);
3700 src#
int "scroll step"
3701 (fun () -> conf
.scrollstep
)
3702 (fun n -> conf
.scrollstep
<- n);
3704 src#
int "horizontal scroll step"
3705 (fun () -> conf
.hscrollstep
)
3706 (fun v -> conf
.hscrollstep
<- v);
3708 src#
int "auto scroll step"
3710 match state
.autoscroll
with
3712 | _ -> conf
.autoscrollstep
)
3714 let n = boundastep state
.winh
n in
3715 if state
.autoscroll
<> None
3716 then state
.autoscroll
<- Some
n;
3717 conf
.autoscrollstep
<- n);
3720 (fun () -> truncate
(conf
.zoom *. 100.))
3721 (fun v -> setzoom ((float v) /. 100.));
3724 (fun () -> conf
.angle
)
3725 (fun v -> reqlayout v conf
.fitmodel
);
3727 src#
int "scroll bar width"
3728 (fun () -> conf
.scrollbw
)
3731 reshape state
.winw state
.winh
;
3734 src#
int "scroll handle height"
3735 (fun () -> conf
.scrollh
)
3736 (fun v -> conf
.scrollh
<- v;);
3738 src#
int "thumbnail width"
3739 (fun () -> conf
.thumbw
)
3741 conf
.thumbw
<- min
4096 v;
3744 leavebirdseye beye
false;
3751 let mode = state
.mode in
3752 src#
string "columns"
3754 match conf
.columns
with
3756 | Cmulti
(multi
, _) -> multicolumns_to_string multi
3757 | Csplit
(count
, _) -> "-" ^ string_of_int count
3760 let n, a, b = multicolumns_of_string
v in
3761 setcolumns mode n a b);
3764 src#caption
"Pixmap cache" 0;
3765 src#int_with_suffix
"size (advisory)"
3766 (fun () -> conf
.memlimit
)
3767 (fun v -> conf
.memlimit
<- v);
3770 (fun () -> Printf.sprintf
"%s bytes, %d tiles"
3771 (string_with_suffix_of_int state
.memused
)
3772 (Hashtbl.length state
.tilemap
)) 1;
3775 src#caption
"Layout" 0;
3776 src#caption2
"Dimension"
3778 Printf.sprintf
"%dx%d (virtual %dx%d)"
3779 state
.winw state
.winh
3784 src#caption2
"Position" (fun () ->
3785 Printf.sprintf
"%dx%d" state
.x state
.y
3788 src#caption2
"Position" (fun () -> describe_location ()) 1
3792 src#
bool ~offset
:0 ~
btos:(fun v -> if v then "(on)" else "(off)")
3793 "Save these parameters as global defaults at exit"
3794 (fun () -> conf
.bedefault
)
3795 (fun v -> conf
.bedefault
<- v)
3799 let btos b = if b then "@Ulguillemet" else "@Urguillemet" in
3800 src#
bool ~offset
:0 ~
btos "Extended parameters"
3801 (fun () -> !showextended)
3802 (fun v -> showextended := v; fillsrc prevmode prevuioh
);
3806 (fun () -> conf
.checkers
)
3807 (fun v -> conf
.checkers
<- v; setcheckers v);
3808 src#
bool "update cursor"
3809 (fun () -> conf
.updatecurs
)
3810 (fun v -> conf
.updatecurs
<- v);
3811 src#
bool "scroll-bar on the left"
3812 (fun () -> conf
.leftscroll
)
3813 (fun v -> conf
.leftscroll
<- v);
3815 (fun () -> conf
.verbose
)
3816 (fun v -> conf
.verbose
<- v);
3817 src#
bool "invert colors"
3818 (fun () -> conf
.invert
)
3819 (fun v -> conf
.invert
<- v);
3821 (fun () -> conf
.maxhfit
)
3822 (fun v -> conf
.maxhfit
<- v);
3824 (fun () -> conf
.pax
!= None
)
3827 then conf
.pax
<- Some
(ref (now
(), 0, 0))
3828 else conf
.pax
<- None
);
3829 src#
string "uri launcher"
3830 (fun () -> conf
.urilauncher
)
3831 (fun v -> conf
.urilauncher
<- v);
3832 src#
string "path launcher"
3833 (fun () -> conf
.pathlauncher
)
3834 (fun v -> conf
.pathlauncher
<- v);
3835 src#
string "tile size"
3836 (fun () -> Printf.sprintf
"%dx%d" conf
.tilew conf
.tileh
)
3839 let w, h = Scanf.sscanf
v "%dx%d" (fun w h -> w, h) in
3840 conf
.tilew
<- max
64 w;
3841 conf
.tileh
<- max
64 h;
3844 state
.text <- Printf.sprintf
"bad tile size `%s': %s"
3847 src#
int "texture count"
3848 (fun () -> conf
.texcount
)
3851 then conf
.texcount
<- v
3852 else impmsg "failed to set texture count please retry later"
3854 src#
int "slice height"
3855 (fun () -> conf
.sliceheight
)
3857 conf
.sliceheight
<- v;
3858 wcmd "sliceh %d" conf
.sliceheight
;
3860 src#
int "anti-aliasing level"
3861 (fun () -> conf
.aalevel
)
3863 conf
.aalevel
<- bound
v 0 8;
3864 state
.anchor <- getanchor
();
3865 opendoc state
.path state
.password;
3867 src#
string "page scroll scaling factor"
3868 (fun () -> string_of_float conf
.pgscale)
3871 let s = float_of_string
v in
3874 state
.text <- Printf.sprintf
3875 "bad page scroll scaling factor `%s': %s" v @@ exntos exn
3878 src#
int "ui font size"
3879 (fun () -> fstate
.fontsize
)
3880 (fun v -> setfontsize (bound
v 5 100));
3881 src#
int "hint font size"
3882 (fun () -> conf
.hfsize
)
3883 (fun v -> conf
.hfsize
<- bound
v 5 100);
3884 colorp "background color"
3885 (fun () -> conf
.bgcolor
)
3886 (fun v -> conf
.bgcolor
<- v; setbgcol v);
3887 src#
bool "crop hack"
3888 (fun () -> conf
.crophack
)
3889 (fun v -> conf
.crophack
<- v);
3890 src#
string "trim fuzz"
3891 (fun () -> irect_to_string conf
.trimfuzz
)
3894 conf
.trimfuzz
<- irect_of_string
v;
3896 then settrim true conf
.trimfuzz
;
3898 state
.text <- Printf.sprintf
"bad irect `%s': %s" v @@ exntos exn
3900 src#
string "throttle"
3902 match conf
.maxwait
with
3903 | None
-> "show place holder if page is not ready"
3906 then "wait for page to fully render"
3908 "wait " ^ string_of_float
time
3909 ^
" seconds before showing placeholder"
3913 let f = float_of_string
v in
3915 then conf
.maxwait
<- None
3916 else conf
.maxwait
<- Some
f
3918 state
.text <- Printf.sprintf
"bad time `%s': %s" v @@ exntos exn
3920 src#
string "ghyll scroll"
3922 match conf
.ghyllscroll
with
3924 | Some nab
-> ghyllscroll_to_string nab
3927 try conf
.ghyllscroll
<- ghyllscroll_of_string
v
3930 state
.text <- Printf.sprintf
"bad ghyll `%s': %s" v msg
3932 state
.text <- Printf.sprintf
"bad ghyll `%s': %s" v @@ exntos exn
3934 src#
string "selection command"
3935 (fun () -> conf
.selcmd
)
3936 (fun v -> conf
.selcmd
<- v);
3937 src#
string "synctex command"
3938 (fun () -> conf
.stcmd
)
3939 (fun v -> conf
.stcmd
<- v);
3940 src#
string "pax command"
3941 (fun () -> conf
.paxcmd
)
3942 (fun v -> conf
.paxcmd
<- v);
3943 src#
string "ask password command"
3944 (fun () -> conf
.passcmd)
3945 (fun v -> conf
.passcmd <- v);
3946 src#
string "save path command"
3947 (fun () -> conf
.savecmd
)
3948 (fun v -> conf
.savecmd
<- v);
3949 src#colorspace
"color space"
3950 (fun () -> CSTE.to_string conf
.colorspace
)
3952 conf
.colorspace
<- CSTE.of_int
v;
3956 src#paxmark
"pax mark method"
3957 (fun () -> MTE.to_string conf
.paxmark
)
3958 (fun v -> conf
.paxmark
<- MTE.of_int
v);
3962 (fun () -> conf
.usepbo
)
3963 (fun v -> conf
.usepbo
<- v);
3964 src#
bool "mouse wheel scrolls pages"
3965 (fun () -> conf
.wheelbypage
)
3966 (fun v -> conf
.wheelbypage
<- v);
3967 src#
bool "open remote links in a new instance"
3968 (fun () -> conf
.riani
)
3969 (fun v -> conf
.riani
<- v);
3970 src#
bool "edit annotations inline"
3971 (fun () -> conf
.annotinline
)
3972 (fun v -> conf
.annotinline
<- v);
3976 src#caption
"Document" 0;
3977 List.iter
(fun (_, s) -> src#caption
s 1) state
.docinfo
;
3978 src#caption2
"Pages"
3979 (fun () -> string_of_int state
.pagecount
) 1;
3980 src#caption2
"Dimensions"
3981 (fun () -> string_of_int
(List.length state
.pdims
)) 1;
3985 src#caption
"Trimmed margins" 0;
3986 src#caption2
"Dimensions"
3987 (fun () -> string_of_int
(List.length state
.pdims
)) 1;
3991 src#caption
"OpenGL" 0;
3992 src#caption
(Printf.sprintf
"Vendor\t%s" (GlMisc.get_string `vendor
)) 1;
3993 src#caption
(Printf.sprintf
"Renderer\t%s" (GlMisc.get_string `renderer
)) 1;
3996 src#caption
"Location" 0;
3997 if nonemptystr state
.origin
3998 then src#caption
("Orign\t" ^ mbtoutf8 state
.origin
) 1;
3999 src#caption
("Path\t" ^ mbtoutf8 state
.path) 1;
4001 src#reset prevmode prevuioh
;
4006 let prevmode = state
.mode
4007 and prevuioh
= state
.uioh in
4008 fillsrc prevmode prevuioh
;
4009 let source = (src :> lvsource
) in
4010 let modehash = findkeyhash conf
"info" in
4011 state
.uioh <- coe (object (self)
4012 inherit listview ~zebra
:false ~helpmode
:false
4013 ~
source ~trusted
:true ~
modehash as super
4014 val mutable m_prevmemused
= 0
4015 method! infochanged
= function
4017 if m_prevmemused
!= state
.memused
4019 m_prevmemused
<- state
.memused
;
4020 G.postRedisplay "memusedchanged";
4022 | Pdim
-> G.postRedisplay "pdimchanged"
4023 | Docinfo
-> fillsrc prevmode prevuioh
4025 method! key key mask
=
4026 if not
(Wsi.withctrl mask
)
4029 | @left | @kpleft
-> coe (self#updownlevel ~
-1)
4030 | @right
| @kpright
-> coe (self#updownlevel
1)
4031 | _ -> super#
key key mask
4032 else super#
key key mask
4034 G.postRedisplay "info";
4040 inherit lvsourcebase
4041 method getitemcount
= Array.length state
.help
4043 let s, l, _ = state
.help
.(n) in
4046 method exit ~
uioh ~cancel ~
active ~
first ~pan
=
4050 match state
.help
.(active) with
4051 | _, _, Action
f -> Some
(f uioh)
4052 | _, _, Noaction
-> Some
uioh
4061 method hasaction
n =
4062 match state
.help
.(n) with
4063 | _, _, Action
_ -> true
4064 | _, _, Noaction
-> false
4070 let modehash = findkeyhash conf
"help" in
4072 state
.uioh <- coe (new listview
4073 ~zebra
:false ~helpmode
:true
4074 ~
source ~trusted
:true ~
modehash);
4075 G.postRedisplay "help";
4081 inherit lvsourcebase
4082 val mutable m_items
= E.a
4084 method getitemcount
= 1 + Array.length m_items
4089 else m_items
.(n-1), 0
4091 method exit ~
uioh ~cancel ~
active ~
first ~pan
=
4096 then Buffer.clear state
.errmsgs
;
4103 method hasaction
n =
4107 state
.newerrmsgs
<- false;
4108 let l = Str.split newlinere
(Buffer.contents state
.errmsgs
) in
4109 m_items
<- Array.of_list
l
4118 let source = (msgsource :> lvsource
) in
4119 let modehash = findkeyhash conf
"listview" in
4120 state
.uioh <- coe (object
4121 inherit listview ~zebra
:false ~helpmode
:false
4122 ~
source ~trusted
:false ~
modehash as super
4125 then msgsource#reset
;
4128 G.postRedisplay "msgs";
4132 let editor = getenvwithdef
"EDITOR" E.s in
4136 let tmppath = Filename.temp_file
"llpp" "note" in
4139 let oc = open_out
tmppath in
4143 let execstr = editor ^
" " ^
tmppath in
4145 match spawn
execstr [] with
4146 | (exception exn
) ->
4147 impmsg "spawn(%S) failed: %s" execstr @@ exntos exn
;
4150 match Unix.waitpid
[] pid with
4151 | (exception exn
) ->
4152 impmsg "waitpid(%d) failed: %s" pid @@ exntos exn
;
4156 | Unix.WEXITED
0 -> filecontents
tmppath
4158 impmsg "editor process(%s) exited abnormally: %d" execstr n;
4160 | Unix.WSIGNALED
n ->
4161 impmsg "editor process(%s) was killed by signal %d" execstr n;
4163 | Unix.WSTOPPED
n ->
4164 impmsg "editor(%s) process was stopped by signal %d" execstr n;
4167 match Unix.unlink
tmppath with
4168 | (exception exn
) ->
4169 impmsg "failed to ulink %S: %s" tmppath @@ exntos exn
;
4174 let enterannotmode opaque slinkindex
=
4177 inherit lvsourcebase
4178 val mutable m_text
= E.s
4179 val mutable m_items
= E.a
4181 method getitemcount
= Array.length m_items
4184 let label, _func
= m_items
.(n) in
4187 method exit ~
uioh ~cancel ~
active ~
first ~pan
=
4188 ignore
(uioh, first, pan
);
4191 let _label, func
= m_items
.(active) in
4196 method hasaction
n = nonemptystr
@@ fst m_items
.(n)
4199 let rec split accu b i
=
4201 if p = String.length
s
4202 then (String.sub
s b (p-b), unit) :: accu
4204 if (i
> 70 && s.[p] = ' '
) || s.[p] = '
\r'
|| s.[p] = '
\n'
4206 let ss = if i
= 0 then E.s else String.sub
s b i
in
4207 split ((ss, unit)::accu) (p+1) 0
4212 wcmd "freepage %s" (~
> opaque);
4214 Hashtbl.fold (fun key opaque'
accu ->
4215 if opaque'
= opaque'
4216 then key :: accu else accu) state
.pagemap
[]
4218 List.iter
(Hashtbl.remove state
.pagemap
) keys;
4223 delannot
opaque slinkindex
;
4226 let edit inline
() =
4231 modannot
opaque slinkindex
s;
4237 let mode = state
.mode in
4240 ("annotation: ", m_text
, None
, textentry, update, true),
4241 fun _ -> state
.mode <- mode);
4245 let s = getusertext m_text
in
4250 ( "[Copy]", fun () -> selstring m_text
)
4251 :: ("[Delete]", dele)
4252 :: ("[Edit]", edit conf
.annotinline
)
4254 :: split [] 0 0 |> List.rev
|> Array.of_list
4261 let s = getannotcontents
opaque slinkindex
in
4264 let source = (msgsource :> lvsource
) in
4265 let modehash = findkeyhash conf
"listview" in
4266 state
.uioh <- coe (object
4267 inherit listview ~zebra
:false ~helpmode
:false
4268 ~
source ~trusted
:false ~
modehash
4270 G.postRedisplay "enterannotmode";
4273 let gotounder under =
4274 let getpath filename
=
4276 if nonemptystr filename
4278 if Filename.is_relative filename
4280 let dir = Filename.dirname state
.path in
4282 if Filename.is_implicit
dir
4283 then Filename.concat
(Sys.getcwd
()) dir
4286 Filename.concat
dir filename
4290 if Sys.file_exists
path
4295 | Ulinkgoto
(pageno, top) ->
4299 gotopage1 pageno top;
4302 | Ulinkuri
s -> gotouri
s
4304 | Uremote
(filename
, pageno) ->
4305 let path = getpath filename
in
4310 let command = Printf.sprintf
"%s -page %d %S" !selfexec pageno path in
4311 match spawn
command [] with
4313 | (exception exn
) ->
4314 dolog
"failed to execute `%s': %s" command @@ exntos exn
4316 let anchor = getanchor
() in
4317 let ranchor = state
.path, state
.password, anchor, state
.origin
in
4318 state
.origin
<- E.s;
4319 state
.anchor <- (pageno, 0.0, 0.0);
4320 state
.ranchors
<- ranchor :: state
.ranchors
;
4323 else impmsg "cannot find %s" filename
4325 | Uremotedest
(filename
, destname
) ->
4326 let path = getpath filename
in
4331 let command = !selfexec ^
" " ^
path ^
" -dest " ^ destname
in
4332 match spawn
command [] with
4333 | (exception exn
) ->
4334 dolog
"failed to execute `%s': %s" command @@ exntos exn
4337 let anchor = getanchor
() in
4338 let ranchor = state
.path, state
.password, anchor, state
.origin
in
4339 state
.origin
<- E.s;
4340 state
.nameddest
<- destname
;
4341 state
.ranchors
<- ranchor :: state
.ranchors
;
4344 else impmsg "cannot find %s" filename
4346 | Uunexpected
_ | Ulaunch
_ | Unamed
_ | Utext
_ | Unone
-> ()
4347 | Uannotation
(opaque, slinkindex
) -> enterannotmode opaque slinkindex
4350 let gotooutline (_, _, kind
) =
4354 let (pageno, y, _) = anchor in
4356 (if conf
.presentation
then (pageno, y, 1.0) else anchor)
4360 | Ouri
uri -> gotounder (Ulinkuri
uri)
4361 | Olaunch cmd
-> gotounder (Ulaunch cmd
)
4362 | Oremote remote
-> gotounder (Uremote remote
)
4363 | Ohistory hist
-> gotohist hist
4364 | Oremotedest remotedest
-> gotounder (Uremotedest remotedest
)
4367 class outlinesoucebase fetchoutlines
= object (self)
4368 inherit lvsourcebase
4369 val mutable m_items
= E.a
4370 val mutable m_minfo
= E.a
4371 val mutable m_orig_items
= E.a
4372 val mutable m_orig_minfo
= E.a
4373 val mutable m_narrow_patterns
= []
4374 val mutable m_gen
= -1
4376 method getitemcount
= Array.length m_items
4379 let s, n, _ = m_items
.(n) in
4382 method exit ~
(uioh:uioh) ~cancel ~
active ~
(first:int) ~pan
:
4384 ignore
(uioh, first);
4386 if m_narrow_patterns
= []
4387 then m_orig_items
, m_orig_minfo
4388 else m_items
, m_minfo
4395 gotooutline m_items
.(active);
4403 method hasaction
(_:int) = true
4406 if Array.length m_items
!= Array.length m_orig_items
4409 match m_narrow_patterns
with
4411 | many
-> String.concat
"@Uellipsis" (List.rev many
)
4413 "Narrowed to " ^
s ^
" (ctrl-u to restore)"
4417 match m_narrow_patterns
with
4420 | head
:: _ -> "@Uellipsis" ^ head
4422 method narrow
pattern =
4423 match Str.regexp_case_fold
pattern with
4424 | (exception _) -> ()
4426 let rec loop accu minfo n =
4429 m_items
<- Array.of_list
accu;
4430 m_minfo
<- Array.of_list
minfo;
4433 let (s, _, _) as o = m_items
.(n) in
4435 match Str.search_forward re
s 0 with
4436 | (exception Not_found
) -> accu, minfo
4437 | first -> o :: accu, (first, Str.match_end
()) :: minfo
4439 loop accu minfo (n-1)
4441 loop [] [] (Array.length m_items
- 1)
4443 method! getminfo
= m_minfo
4446 m_orig_items
<- fetchoutlines
();
4447 m_minfo
<- m_orig_minfo
;
4448 m_items
<- m_orig_items
4450 method add_narrow_pattern
pattern =
4451 m_narrow_patterns
<- pattern :: m_narrow_patterns
4453 method del_narrow_pattern
=
4454 match m_narrow_patterns
with
4455 | _ :: rest
-> m_narrow_patterns
<- rest
4460 match m_narrow_patterns
with
4461 | pattern :: [] -> self#narrow
pattern; pattern
4463 List.fold_left
(fun accu pattern ->
4464 self#narrow
pattern;
4465 pattern ^
"@Uellipsis" ^
accu) E.s list
4467 method calcactive
(_:anchor) = 0
4469 method reset
anchor items =
4470 if state
.gen
!= m_gen
4472 m_orig_items
<- items;
4474 m_narrow_patterns
<- [];
4476 m_orig_minfo
<- E.a;
4480 if items != m_orig_items
4482 m_orig_items
<- items;
4483 if m_narrow_patterns
== []
4484 then m_items
<- items;
4487 let active = self#calcactive
anchor in
4489 m_first
<- firstof m_first
active
4493 let outlinesource fetchoutlines
=
4495 inherit outlinesoucebase fetchoutlines
4496 method! calcactive
anchor =
4497 let rely = getanchory anchor in
4498 let rec loop n best bestd
=
4499 if n = Array.length m_items
4502 let _, _, kind
= m_items
.(n) in
4505 let orely = getanchory anchor in
4506 let d = abs
(orely - rely) in
4509 else loop (n+1) best bestd
4510 | Onone
| Oremote
_ | Olaunch
_
4511 | Oremotedest
_ | Ouri
_ | Ohistory
_ ->
4512 loop (n+1) best bestd
4518 let enteroutlinemode, enterbookmarkmode
, enterhistmode
=
4519 let mkselector sourcetype
=
4520 let fetchoutlines () =
4521 match sourcetype
with
4522 | `bookmarks
-> Array.of_list state
.bookmarks
4523 | `outlines
-> state
.outlines
4524 | `history
-> genhistoutlines ()
4527 if sourcetype
= `history
4528 then new outlinesoucebase
fetchoutlines
4529 else outlinesource fetchoutlines
4532 let outlines = fetchoutlines () in
4533 if Array.length
outlines = 0
4535 showtext ' ' errmsg
;
4539 Wsi.setcursor
Wsi.CURSOR_INHERIT
;
4540 let anchor = getanchor
() in
4541 source#reset
anchor outlines;
4542 state
.text <- source#greetmsg
;
4544 coe (new outlinelistview ~zebra
:(sourcetype
=`history
) ~
source);
4545 G.postRedisplay "enter selector";
4548 let mkenter sourcetype errmsg
=
4549 let enter = mkselector sourcetype
in
4550 fun () -> enter errmsg
4552 (**)mkenter `
outlines "document has no outline"
4553 , mkenter `bookmarks
"document has no bookmarks (yet)"
4554 , mkenter `history
"history is empty"
4557 let quickbookmark ?title
() =
4558 match state
.layout with
4564 let tm = Unix.localtime
(now
()) in
4566 "Quick (page %d) (bookmarked at %02d/%02d/%d %02d:%02d)"
4570 (tm.Unix.tm_year
+ 1900)
4573 | Some
title -> title
4575 state
.bookmarks
<- (title, 0, Oanchor
(getanchor1
l)) :: state
.bookmarks
4578 let setautoscrollspeed step goingdown
=
4579 let incr = max
1 ((abs step
) / 2) in
4580 let incr = if goingdown
then incr else -incr in
4581 let astep = boundastep state
.winh
(step
+ incr) in
4582 state
.autoscroll
<- Some
astep;
4586 match conf
.columns
with
4588 | Csingle
_ | Cmulti
_ -> state
.x != 0 || conf
.zoom > 1.0
4591 let panbound x = bound
x (-state
.w) (wadjsb () + state
.winw
);;
4593 let existsinrow pageno (columns
, coverA
, coverB
) p =
4594 let last = ((pageno - coverA
) mod columns
) + columns
in
4595 let rec any = function
4598 if l.pageno = coverA
- 1 || l.pageno = state
.pagecount
- coverB
4602 then (if l.pageno = last then false else any rest
)
4610 match state
.layout with
4612 let pageno = page_of_y state
.y in
4613 gotoghyll (getpagey
(pageno+1))
4615 match conf
.columns
with
4617 if conf
.presentation
&& rest
== [] && l.pageh
> l.pagey + l.pagevh
4619 let y = clamp (pgscale state
.winh
) in
4622 let pageno = min
(l.pageno+1) (state
.pagecount
-1) in
4623 gotoghyll (getpagey
pageno)
4624 | Cmulti
((c, _, _) as cl, _) ->
4625 if conf
.presentation
4626 && (existsinrow l.pageno cl
4627 (fun l -> l.pageh
> l.pagey + l.pagevh))
4629 let y = clamp (pgscale state
.winh
) in
4632 let pageno = min
(l.pageno+c) (state
.pagecount
-1) in
4633 gotoghyll (getpagey
pageno)
4635 if l.pageno < state
.pagecount
- 1 || l.pagecol
< n - 1
4637 let pagey, pageh
= getpageyh
l.pageno in
4638 let pagey = pagey + pageh
* l.pagecol
in
4639 let ips = if l.pagecol
= 0 then 0 else conf
.interpagespace
in
4640 gotoghyll (pagey + pageh
+ ips)
4644 match state
.layout with
4646 let pageno = page_of_y state
.y in
4647 gotoghyll (getpagey
(pageno-1))
4649 match conf
.columns
with
4651 if conf
.presentation
&& l.pagey != 0
4653 gotoghyll (clamp (pgscale ~
-(state
.winh
)))
4655 let pageno = max
0 (l.pageno-1) in
4656 gotoghyll (getpagey
pageno)
4657 | Cmulti
((c, _, coverB
) as cl, _) ->
4658 if conf
.presentation
&&
4659 (existsinrow l.pageno cl (fun l -> l.pagey != 0))
4661 gotoghyll (clamp (pgscale ~
-(state
.winh
)))
4664 if l.pageno = state
.pagecount
- coverB
4668 let pageno = max
0 (l.pageno-decr) in
4669 gotoghyll (getpagey
pageno)
4677 let pageno = max
0 (l.pageno-1) in
4678 let pagey, pageh
= getpageyh
pageno in
4681 let pagey, pageh
= getpageyh
l.pageno in
4682 pagey + pageh
* (l.pagecol
-1) - conf
.interpagespace
4688 if emptystr conf
.savecmd
4689 then error
"don't know where to save modified document"
4691 let savecmd = Str.global_replace percentsre state
.path conf
.savecmd in
4694 (fun s -> error
"failed to obtain path to the saved copy: %s" s)
4699 let tmp = path ^
".tmp" in
4701 Unix.rename
tmp path;
4704 let viewkeyboard key mask
=
4706 let mode = state
.mode in
4707 state
.mode <- Textentry
(te, fun _ -> state
.mode <- mode);
4710 G.postRedisplay "view:enttext"
4712 let ctrl = Wsi.withctrl mask
in
4714 if key >= 0xffb0 && key < 0xffb9 then key - 0xffb0 + 48 else key
4720 if hasunsavedchanges
()
4724 if conf
.angle
mod 360 = 0 && not
(isbirdseye state
.mode)
4726 state
.mode <- LinkNav
(Ltgendir
0);
4729 else impmsg "keyboard link navigation does not work under rotation"
4732 begin match state
.mstate
with
4735 G.postRedisplay "kill rect";
4738 | Mscrolly
| Mscrollx
4741 begin match state
.mode with
4744 G.postRedisplay "esc leave linknav"
4748 match state
.ranchors
with
4750 | (path, password, anchor, origin
) :: rest
->
4751 state
.ranchors
<- rest
;
4752 state
.anchor <- anchor;
4753 state
.origin
<- origin
;
4754 state
.nameddest
<- E.s;
4755 opendoc path password
4760 gotoghyll (getnav ~
-1)
4771 Hashtbl.iter
(fun _ opaque ->
4773 Hashtbl.clear state
.prects
) state
.pagemap
;
4774 G.postRedisplay "dehighlight";
4776 | @slash
| @question
->
4777 let ondone isforw
s =
4778 cbput state
.hists
.pat
s;
4779 state
.searchpattern
<- s;
4782 let s = String.make
1 (Char.chr
key) in
4783 enttext (s, E.s, Some
(onhist state
.hists
.pat
),
4784 textentry, ondone (key = @slash
), true)
4786 | @plus
| @kpplus
| @equals
when ctrl ->
4787 let incr = if conf
.zoom +. 0.01 > 0.1 then 0.1 else 0.01 in
4788 setzoom (conf
.zoom +. incr)
4790 | @plus
| @kpplus
->
4793 try int_of_string
s with exc
->
4794 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exc
;
4800 state
.text <- "page bias is now " ^ string_of_int
n;
4803 enttext ("page bias: ", E.s, None
, intentry, ondone, true)
4805 | @minus
| @kpminus
when ctrl ->
4806 let decr = if conf
.zoom -. 0.1 < 0.1 then 0.01 else 0.1 in
4807 setzoom (max
0.01 (conf
.zoom -. decr))
4809 | @minus
| @kpminus
->
4810 let ondone msg
= state
.text <- msg
in
4812 "option [acfhilpstvxACFPRSZTISM]: ", E.s, None
,
4813 optentry state
.mode, ondone, true
4824 | (@1 | @2) when ctrl && conf
.fitmodel
!= FitPage
-> (* ctrl-1/2 *)
4826 match conf
.columns
with
4827 | Csingle
_ | Cmulti
_ -> 1
4828 | Csplit
(n, _) -> n
4830 let h = state
.winh
-
4831 conf
.interpagespace
lsl (if conf
.presentation
then 1 else 0)
4833 let zoom = zoomforh state
.winw
h (vscrollw ()) cols in
4834 if zoom > 0.0 && (key = @2 || zoom < 1.0)
4839 match conf
.fitmodel
with
4840 | FitWidth
-> FitProportional
4841 | FitProportional
-> FitPage
4842 | FitPage
-> FitWidth
4844 state
.text <- "fit model: " ^
FMTE.to_string
fm;
4845 reqlayout conf
.angle
fm
4847 | @4 when ctrl -> (* ctrl-4 *)
4848 let zoom = getmaxw
() /. float state
.winw
in
4849 if zoom > 0.0 then setzoom zoom
4857 | (48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57)
4858 when not
ctrl -> (* 0..9 *)
4861 try int_of_string
s with exc
->
4862 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exc
;
4868 cbput state
.hists
.pag
(string_of_int
n);
4869 gotopage1 (n + conf
.pagebias
- 1) 0;
4872 let pageentry text key =
4873 match Char.unsafe_chr
key with
4874 | '
g'
-> TEdone
text
4875 | _ -> intentry text key
4877 let text = String.make
1 (Char.chr
key) in
4878 enttext (":", text, Some
(onhist state
.hists
.pag
),
4879 pageentry, ondone, true)
4882 conf
.scrollb
<- if conf
.scrollb
= 0 then (scrollbvv
lor scrollbhv
) else 0;
4883 reshape state
.winw state
.winh
;
4886 state
.bzoom
<- not state
.bzoom
;
4888 showtext ' '
("block zoom " ^
if state
.bzoom
then "on" else "off")
4891 conf
.hlinks
<- not conf
.hlinks
;
4892 state
.text <- "highlightlinks " ^
if conf
.hlinks
then "on" else "off";
4893 G.postRedisplay "toggle highlightlinks";
4896 if conf
.angle
mod 360 = 0
4898 state
.glinks
<- true;
4899 let mode = state
.mode in
4902 (":", E.s, None
, linknentry, linknact gotounder, false),
4904 state
.glinks
<- false;
4908 G.postRedisplay "view:linkent(F)"
4910 else impmsg "hint mode does not work under rotation"
4913 state
.glinks
<- true;
4914 let mode = state
.mode in
4915 state
.mode <- Textentry
(
4917 ":", E.s, None
, linknentry, linknact (fun under ->
4918 selstring (undertext under);
4922 state
.glinks
<- false;
4926 G.postRedisplay "view:linkent"
4929 begin match state
.autoscroll
with
4931 conf
.autoscrollstep
<- step
;
4932 state
.autoscroll
<- None
4934 if conf
.autoscrollstep
= 0
4935 then state
.autoscroll
<- Some
1
4936 else state
.autoscroll
<- Some conf
.autoscrollstep
4940 launchpath () (* XXX where do error messages go? *)
4943 setpresentationmode (not conf
.presentation
);
4944 showtext ' '
("presentation mode " ^
4945 if conf
.presentation
then "on" else "off");
4948 if List.mem
Wsi.Fullscreen state
.winstate
4949 then Wsi.reshape conf
.cwinw conf
.cwinh
4950 else Wsi.fullscreen
()
4953 search state
.searchpattern
false
4956 search state
.searchpattern
true
4959 begin match state
.layout with
4962 gotoghyll (getpagey
l.pageno)
4968 | @delete
| @kpdelete
-> (* delete *)
4972 showtext ' '
(describe_location ());
4975 begin match state
.layout with
4978 Wsi.reshape (l.pagew
+ vscrollw ()) l.pageh
;
4983 enterbookmarkmode
()
4991 | @e when Buffer.length state
.errmsgs
> 0 ->
4996 match state
.layout with
5001 (s, 0, Oanchor
(getanchor1
l)) :: state
.bookmarks
5004 enttext ("bookmark: ", E.s, None
, textentry, ondone, true)
5008 showtext ' '
"Quick bookmark added";
5011 begin match state
.layout with
5013 let rect = getpdimrect
l.pagedimno
in
5017 (truncate
(1.8 *. (rect.(1) -. rect.(0))),
5018 truncate
(1.2 *. (rect.(3) -. rect.(0))))
5020 (truncate
(rect.(1) -. rect.(0)),
5021 truncate
(rect.(3) -. rect.(0)))
5023 let w = truncate
((float w)*.conf
.zoom)
5024 and h = truncate
((float h)*.conf
.zoom) in
5027 state
.anchor <- getanchor
();
5028 Wsi.reshape (w + vscrollw ()) (h + conf
.interpagespace
)
5030 G.postRedisplay "z";
5035 | @x -> state
.roam
()
5038 reqlayout (conf
.angle
+
5039 (if key = @Gt
then 30 else -30)) conf
.fitmodel
5043 bound
(conf
.colorscale
+. (if key = 93 then 0.1 else -0.1)) 0.0 1.0
5045 G.postRedisplay "brightness";
5047 | @c when state
.mode = View
->
5052 let m = (wadjsb () + state
.winw
- state
.w) / 2 in
5054 gotoy_and_clear_text state
.y
5058 match state
.prevcolumns
with
5059 | None
-> (1, 0, 0), 1.0
5060 | Some
(columns
, z
) ->
5063 | Csplit
(c, _) -> -c, 0, 0
5064 | Cmulti
((c, a, b), _) -> c, a, b
5065 | Csingle
_ -> 1, 0, 0
5069 setcolumns View
c a b;
5072 | @down
| @up
when ctrl && Wsi.withshift mask
->
5073 let zoom, x = state
.prevzoom
in
5077 | @k
| @up
| @kpup
->
5078 begin match state
.autoscroll
with
5080 begin match state
.mode with
5081 | Birdseye beye
-> upbirdseye 1 beye
5086 then gotoy_and_clear_text (clamp ~
-(state
.winh
/2))
5088 if not
(Wsi.withshift mask
) && conf
.presentation
5090 else gotoghyll1 true (clamp (-conf
.scrollstep
))
5094 setautoscrollspeed n false
5097 | @j
| @down
| @kpdown
->
5098 begin match state
.autoscroll
with
5100 begin match state
.mode with
5101 | Birdseye beye
-> downbirdseye 1 beye
5106 then gotoy_and_clear_text (clamp (state
.winh
/2))
5108 if not
(Wsi.withshift mask
) && conf
.presentation
5110 else gotoghyll1 true (clamp (conf
.scrollstep
))
5114 setautoscrollspeed n true
5117 | @left | @right
| @kpleft
| @kpright
when not
(Wsi.withalt mask
) ->
5123 else conf
.hscrollstep
5125 let dx = if key = @left || key = @kpleft
then dx else -dx in
5126 state
.x <- panbound (state
.x + dx);
5127 gotoy_and_clear_text state
.y
5130 G.postRedisplay "left/right"
5133 | @prior
| @kpprior
->
5137 match state
.layout with
5139 | l :: _ -> state
.y - l.pagey
5141 clamp (pgscale (-state
.winh
))
5145 | @next | @kpnext
->
5149 match List.rev state
.layout with
5151 | l :: _ -> getpagey
l.pageno
5153 clamp (pgscale state
.winh
)
5157 | @g | @home
| @kphome
->
5160 | @G
| @jend
| @kpend
->
5162 gotoghyll (clamp state
.maxy)
5164 | @right
| @kpright
when Wsi.withalt mask
->
5165 gotoghyll (getnav 1)
5166 | @left | @kpleft
when Wsi.withalt mask
->
5167 gotoghyll (getnav ~
-1)
5172 | @v when conf
.debug
->
5175 match getopaque l.pageno with
5178 let x0, y0, x1, y1 = pagebbox
opaque in
5179 let a,b = float x0, float y0 in
5180 let c,d = float x1, float y0 in
5181 let e,f = float x1, float y1 in
5182 let h,j
= float x0, float y1 in
5183 let rect = (a,b,c,d,e,f,h,j
) in
5185 let color = (0.0, 0.0, 1.0 /. (l.pageno mod 3 |> float), 0.5) in
5186 state
.rects
<- (l.pageno, color, rect) :: state
.rects
;
5188 G.postRedisplay "v";
5191 let mode = state
.mode in
5192 let cmd = ref E.s in
5193 let onleave = function
5194 | Cancel
-> state
.mode <- mode
5197 match getopaque l.pageno with
5198 | Some
opaque -> pipesel opaque !cmd
5199 | None
-> ()) state
.layout;
5203 cbput state
.hists
.sel
s;
5207 "| ", !cmd, Some
(onhist state
.hists
.sel
), textentry, ondone, true
5209 G.postRedisplay "|";
5210 state
.mode <- Textentry
(te, onleave);
5213 vlog "huh? %s" (Wsi.keyname
key)
5216 let linknavkeyboard key mask
linknav =
5217 let getpage pageno =
5218 let rec loop = function
5220 | l :: _ when l.pageno = pageno -> Some
l
5221 | _ :: rest
-> loop rest
5222 in loop state
.layout
5224 let doexact (pageno, n) =
5225 match getopaque pageno, getpage pageno with
5226 | Some
opaque, Some
l ->
5227 if key = @enter || key = @kpenter
5229 let under = getlink
opaque n in
5230 G.postRedisplay "link gotounder";
5237 Some
(findlink
opaque LDfirst
), -1
5240 Some
(findlink
opaque LDlast
), 1
5243 Some
(findlink
opaque (LDleft
n)), -1
5246 Some
(findlink
opaque (LDright
n)), 1
5249 Some
(findlink
opaque (LDup
n)), -1
5252 Some
(findlink
opaque (LDdown
n)), 1
5257 begin match findpwl
l.pageno dir with
5261 state
.mode <- LinkNav
(Ltgendir
dir);
5262 let y, h = getpageyh
pageno in
5265 then y + h - state
.winh
5270 begin match getopaque pageno, getpage pageno with
5271 | Some
opaque, Some
_ ->
5273 let ld = if dir > 0 then LDfirst
else LDlast
in
5276 begin match link with
5278 showlinktype (getlink
opaque m);
5279 state
.mode <- LinkNav
(Ltexact
(pageno, m));
5280 G.postRedisplay "linknav jpage";
5281 | Lnotfound
-> notfound dir
5287 begin match opt with
5288 | Some Lnotfound
-> pwl l dir;
5289 | Some
(Lfound
m) ->
5293 let _, y0, _, y1 = getlinkrect
opaque m in
5295 then gotopage1 l.pageno y0
5297 let d = fstate
.fontsize
+ 1 in
5298 if y1 - l.pagey > l.pagevh - d
5299 then gotopage1 l.pageno (y1 - state
.winh
- hscrollh () + d)
5300 else G.postRedisplay "linknav";
5302 showlinktype (getlink
opaque m);
5303 state
.mode <- LinkNav
(Ltexact
(l.pageno, m));
5306 | None
-> viewkeyboard key mask
5308 | _ -> viewkeyboard key mask
5313 G.postRedisplay "leave linknav"
5317 | Ltgendir
_ | Ltnotready
_ -> viewkeyboard key mask
5318 | Ltexact exact
-> doexact exact
5321 let keyboard key mask
=
5322 if (key = @g && Wsi.withctrl mask
) && not
(istextentry state
.mode)
5323 then wcmd "interrupt"
5324 else state
.uioh <- state
.uioh#
key key mask
5327 let birdseyekeyboard key mask
5328 ((oconf
, leftx
, pageno, hooverpageno
, anchor) as beye
) =
5330 match conf
.columns
with
5332 | Cmulti
((c, _, _), _) -> c
5333 | Csplit
_ -> failwith
"bird's eye split mode"
5335 let pgh layout = List.fold_left
5336 (fun m l -> max
l.pageh
m) state
.winh
layout in
5338 | @l when Wsi.withctrl mask
->
5339 let y, h = getpageyh
pageno in
5340 let top = (state
.winh
- h) / 2 in
5341 gotoy (max
0 (y - top))
5342 | @enter | @kpenter
-> leavebirdseye beye
false
5343 | @escape
-> leavebirdseye beye
true
5344 | @up
-> upbirdseye incr beye
5345 | @down
-> downbirdseye incr beye
5346 | @left -> upbirdseye 1 beye
5347 | @right
-> downbirdseye 1 beye
5350 begin match state
.layout with
5354 state
.mode <- Birdseye
(
5355 oconf
, leftx
, l.pageno, hooverpageno
, anchor
5357 gotopage1 l.pageno 0;
5360 let layout = layout state
.x (state
.y-state
.winh
)
5362 (pgh state
.layout) in
5364 | [] -> gotoy (clamp (-state
.winh
))
5366 state
.mode <- Birdseye
(
5367 oconf
, leftx
, l.pageno, hooverpageno
, anchor
5369 gotopage1 l.pageno 0
5372 | [] -> gotoy (clamp (-state
.winh
))
5376 begin match List.rev state
.layout with
5378 let layout = layout state
.x
5379 (state
.y + (pgh state
.layout))
5380 state
.winw state
.winh
in
5381 begin match layout with
5383 let incr = l.pageh
- l.pagevh in
5388 oconf
, leftx
, state
.pagecount
- 1, hooverpageno
, anchor
5390 G.postRedisplay "birdseye pagedown";
5392 else gotoy (clamp (incr + conf
.interpagespace
*2));
5396 Birdseye
(oconf
, leftx
, l.pageno, hooverpageno
, anchor);
5397 gotopage1 l.pageno 0;
5400 | [] -> gotoy (clamp state
.winh
)
5404 state
.mode <- Birdseye
(oconf
, leftx
, 0, hooverpageno
, anchor);
5408 let pageno = state
.pagecount
- 1 in
5409 state
.mode <- Birdseye
(oconf
, leftx
, pageno, hooverpageno
, anchor);
5410 if not
(pagevisible state
.layout pageno)
5413 match List.rev state
.pdims
with
5415 | (_, _, h, _) :: _ -> h
5417 gotoy (max
0 (getpagey
pageno - (state
.winh
- h - conf
.interpagespace
)))
5418 else G.postRedisplay "birdseye end";
5420 | _ -> viewkeyboard key mask
5425 match state
.mode with
5426 | Textentry
_ -> scalecolor 0.4
5428 | View
-> scalecolor 1.0
5429 | Birdseye
(_, _, pageno, hooverpageno
, _) ->
5430 if l.pageno = hooverpageno
5433 if l.pageno = pageno
5435 let c = scalecolor 1.0 in
5437 GlDraw.line_width
3.0;
5438 let dispx = xadjsb () + l.pagedispx in
5440 (float (dispx-1)) (float (l.pagedispy-1))
5441 (float (dispx+l.pagevw+1))
5442 (float (l.pagedispy+l.pagevh+1))
5444 GlDraw.line_width
1.0;
5453 let postdrawpage l linkindexbase
=
5454 match getopaque l.pageno with
5456 if tileready l l.pagex
l.pagey
5458 let x = l.pagedispx - l.pagex
+ xadjsb ()
5459 and y = l.pagedispy - l.pagey in
5461 match conf
.columns
with
5462 | Csingle
_ | Cmulti
_ ->
5463 (if conf
.hlinks
then 1 else 0)
5465 && not
(isbirdseye state
.mode) then 2 else 0)
5469 match state
.mode with
5470 | Textentry
((_, s, _, _, _, _), _) when state
.glinks
-> s
5476 Hashtbl.find_all state
.prects
l.pageno |>
5477 List.iter
(fun vals
-> drawprect
opaque x y vals
);
5478 postprocess
opaque hlmask x y (linkindexbase
, s, conf
.hfsize
);
5483 let scrollindicator () =
5484 let sbw, ph
, sh = state
.uioh#
scrollph in
5485 let sbh, pw, sw = state
.uioh#scrollpw
in
5490 else ((state
.winw
- sbw), state
.winw
, 0)
5493 GlDraw.color (0.64, 0.64, 0.64);
5494 filledrect (float x0) 0. (float x1) (float state
.winh
);
5496 (float hx0
) (float (state
.winh
- sbh))
5497 (float (hx0
+ wadjsb () + state
.winw
)) (float state
.winh
)
5499 GlDraw.color (0.0, 0.0, 0.0);
5501 filledrect (float x0) ph
(float x1) (ph
+. sh);
5502 let pw = pw +. float hx0
in
5503 filledrect pw (float (state
.winh
- sbh)) (pw +. sw) (float state
.winh
);
5507 match state
.mstate
with
5508 | Mnone
| Mscrolly
| Mscrollx
| Mpan
_ | Mzoom
_ | Mzoomrect
_ ->
5511 | Msel
((x0, y0), (x1, y1)) ->
5512 let identify opaque l px py = Some
(opaque, l.pageno, px, py) in
5513 let o0,n0
,px0
,py0
= onppundermouse identify x0 y0 (~
< E.s, -1, 0, 0) in
5514 let _o1,n1
,px1
,py1
= onppundermouse identify x1 y1 (~
< E.s, -1, 0, 0) in
5515 if n0
!= -1 && n0
= n1
then seltext
o0 (px0
, py0
, px1
, py1
);
5518 let showrects = function [] -> () | rects
->
5520 GlDraw.color (0.0, 0.0, 1.0) ~
alpha:0.5;
5521 GlFunc.blend_func ~
src:`src_alpha ~dst
:`one_minus_src_alpha
;
5523 (fun (pageno, c, (x0, y0, x1, y1, x2
, y2
, x3
, y3
)) ->
5525 if l.pageno = pageno
5527 let dx = float (l.pagedispx - l.pagex
) in
5528 let dy = float (l.pagedispy - l.pagey) in
5529 let r, g, b, alpha = c in
5530 GlDraw.color (r, g, b) ~
alpha;
5531 Raw.sets_float state
.vraw ~
pos:0
5536 GlArray.vertex `two state
.vraw
;
5537 GlArray.draw_arrays `triangle_strip ~
first:0 ~count
:4;
5546 GlClear.color (scalecolor2 conf
.bgcolor
);
5547 GlClear.clear
[`
color];
5548 List.iter
drawpage state
.layout;
5550 match state
.mode with
5551 | LinkNav
(Ltexact
(pageno, linkno
)) ->
5552 begin match getopaque pageno with
5554 let dx = xadjsb () in
5555 let x0, y0, x1, y1 = getlinkrect
opaque linkno
in
5556 let x0 = x0 + dx and x1 = x1 + dx in
5557 let color = (0.0, 0.0, 0.5, 0.5) in
5564 | None
-> state
.rects
5566 | LinkNav
(Ltgendir
_) | LinkNav
(Ltnotready
_)
5569 | View
-> state
.rects
5572 let rec postloop linkindexbase
= function
5574 let linkindexbase = linkindexbase + postdrawpage l linkindexbase in
5575 postloop linkindexbase rest
5579 postloop 0 state
.layout;
5581 begin match state
.mstate
with
5582 | Mzoomrect
((x0, y0), (x1, y1)) ->
5584 GlDraw.color (0.3, 0.3, 0.3) ~
alpha:0.5;
5585 GlFunc.blend_func ~
src:`src_alpha ~dst
:`one_minus_src_alpha
;
5586 filledrect (float x0) (float y0) (float x1) (float y1);
5590 | Mscrolly
| Mscrollx
5599 let zoomrect x y x1 y1 =
5602 and y0 = min
y y1 in
5603 gotoy (state
.y + y0);
5604 state
.anchor <- getanchor
();
5605 let zoom = (float state
.w) /. float (x1 - x0) in
5608 let adjw = wadjsb () + state
.winw
in
5610 then (adjw - state
.w) / 2
5613 match conf
.fitmodel
with
5614 | FitWidth
| FitProportional
-> simple ()
5616 match conf
.columns
with
5618 onppundermouse (fun _ l _ _ -> Some
l.pagedispx) x0 y0 x0
5619 | Cmulti
_ | Csingle
_ -> simple ()
5621 state
.x <- (state
.x + margin) - x0;
5626 let annot inline
x y =
5627 match unproject x y with
5628 | Some
(opaque, n, ux
, uy
) ->
5630 addannot
opaque ux uy
text;
5631 wcmd "freepage %s" (~
> opaque);
5632 Hashtbl.remove state
.pagemap
(n, state
.gen
);
5638 let ondone s = add s in
5639 let mode = state
.mode in
5640 state
.mode <- Textentry
(
5641 ("annotation: ", E.s, None
, textentry, ondone, true),
5642 fun _ -> state
.mode <- mode);
5645 G.postRedisplay "annot"
5647 add @@ getusertext E.s
5652 let g opaque l px py =
5653 match rectofblock
opaque px py with
5655 let x0 = a.(0) -. 20. in
5656 let x1 = a.(1) +. 20. in
5657 let y0 = a.(2) -. 20. in
5658 let zoom = (float state
.w) /. (x1 -. x0) in
5659 let pagey = getpagey
l.pageno in
5660 gotoy_and_clear_text (pagey + truncate
y0);
5661 state
.anchor <- getanchor
();
5662 let margin = (state
.w - l.pagew
)/2 in
5663 state
.x <- -truncate
x0 - margin;
5668 match conf
.columns
with
5670 impmsg "block zooming does not work properly in split columns mode"
5671 | Cmulti
_ | Csingle
_ -> onppundermouse g x y ()
5675 let winw = wadjsb () + state
.winw - 1 in
5676 let s = float x /. float winw in
5677 let destx = truncate
(float (state
.w + winw) *. s) in
5678 state
.x <- winw - destx;
5679 gotoy_and_clear_text state
.y;
5680 state
.mstate
<- Mscrollx
;
5684 let s = float y /. float state
.winh
in
5685 let desty = truncate
(float (state
.maxy - state
.winh
) *. s) in
5686 gotoy_and_clear_text desty;
5687 state
.mstate
<- Mscrolly
;
5690 let viewmulticlick clicks
x y mask
=
5691 let g opaque l px py =
5699 if markunder
opaque px py mark
5703 match getopaque l.pageno with
5705 | Some
opaque -> pipesel opaque cmd
5707 state
.roam
<- (fun () -> dopipe conf
.paxcmd
);
5708 if not
(Wsi.withctrl mask
) then dopipe conf
.selcmd
;
5713 G.postRedisplay "viewmulticlick";
5714 onppundermouse g x y (fun () -> impmsg "nothing to select") ();
5718 match conf
.columns
with
5720 | Csingle
_ | Cmulti
_ -> conf
.angle
mod 360 = 0
5723 let viewmouse button down
x y mask
=
5725 | n when (n == 4 || n == 5) && not down
->
5726 if Wsi.withctrl mask
5728 match state
.mstate
with
5729 | Mzoom
(oldn
, i
) ->
5737 if conf
.zoom +. 0.01 > 0.1 then 0.1 else 0.01
5739 if conf
.zoom -. 0.1 < 0.1 then -0.01 else -0.1
5741 let zoom = conf
.zoom -. incr in
5743 state
.mstate
<- Mzoom
(n, 0);
5745 state
.mstate
<- Mzoom
(n, i
+1);
5747 else state
.mstate
<- Mzoom
(n, 0)
5751 | Mscrolly
| Mscrollx
5753 | Mnone
-> state
.mstate
<- Mzoom
(n, 0)
5756 match state
.autoscroll
with
5757 | Some step
-> setautoscrollspeed step
(n=4)
5759 if conf
.wheelbypage
|| conf
.presentation
5768 then -conf
.scrollstep
5769 else conf
.scrollstep
5771 let incr = incr * 2 in
5772 let y = clamp incr in
5773 gotoy_and_clear_text y
5776 | n when (n = 6 || n = 7) && not down
&& canpan () ->
5778 panbound (state
.x + (if n = 7 then -2 else 2) * conf
.hscrollstep
);
5779 gotoy_and_clear_text state
.y
5781 | 1 when Wsi.withshift mask
->
5782 state
.mstate
<- Mnone
;
5785 match unproject x y with
5787 | Some
(_, pageno, ux
, uy
) ->
5788 let cmd = Printf.sprintf
5790 conf
.stcmd state
.path pageno ux uy
5792 match spawn
cmd [] with
5793 | (exception exn
) ->
5794 impmsg "execution of synctex command(%S) failed: %S"
5795 conf
.stcmd
@@ exntos exn
5799 | 1 when Wsi.withctrl mask
->
5802 Wsi.setcursor
Wsi.CURSOR_FLEUR
;
5803 state
.mstate
<- Mpan
(x, y)
5806 state
.mstate
<- Mnone
5811 if Wsi.withshift mask
5813 annot conf
.annotinline
x y;
5814 G.postRedisplay "addannot"
5818 Wsi.setcursor
Wsi.CURSOR_CYCLE
;
5819 state
.mstate
<- Mzoomrect
(p, p)
5822 match state
.mstate
with
5823 | Mzoomrect
((x0, y0), _) ->
5824 if abs
(x-x0) > 10 && abs
(y - y0) > 10
5825 then zoomrect x0 y0 x y
5828 G.postRedisplay "kill accidental zoom rect";
5832 | Mscrolly
| Mscrollx
5838 | 1 when vscrollhit x ->
5841 let _, position, sh = state
.uioh#
scrollph in
5842 if y > truncate
position && y < truncate
(position +. sh)
5843 then state
.mstate
<- Mscrolly
5846 state
.mstate
<- Mnone
5848 | 1 when y > state
.winh
- hscrollh () ->
5851 let _, position, sw = state
.uioh#scrollpw
in
5852 if x > truncate
position && x < truncate
(position +. sw)
5853 then state
.mstate
<- Mscrollx
5856 state
.mstate
<- Mnone
5858 | 1 when state
.bzoom
-> if not down
then zoomblock x y
5861 let dest = if down
then getunder x y else Unone
in
5862 begin match dest with
5865 | Uremote
_ | Uremotedest
_
5866 | Uunexpected
_ | Ulaunch
_ | Unamed
_ ->
5869 | Unone
when down
->
5870 Wsi.setcursor
Wsi.CURSOR_FLEUR
;
5871 state
.mstate
<- Mpan
(x, y);
5873 | Uannotation
(opaque, slinkindex
) -> enterannotmode opaque slinkindex
5875 | Unone
| Utext
_ ->
5880 state
.mstate
<- Msel
((x, y), (x, y));
5881 G.postRedisplay "mouse select";
5885 match state
.mstate
with
5888 | Mzoom
_ | Mscrollx
| Mscrolly
->
5889 state
.mstate
<- Mnone
5891 | Mzoomrect
((x0, y0), _) ->
5895 Wsi.setcursor
Wsi.CURSOR_INHERIT
;
5896 state
.mstate
<- Mnone
5898 | Msel
((x0, y0), (x1, y1)) ->
5899 let rec loop = function
5903 let a0 = l.pagedispy in
5904 let a1 = a0 + l.pagevh in
5905 let b0 = l.pagedispx in
5906 let b1 = b0 + l.pagevw in
5907 ((y0 >= a0 && y0 <= a1) || (y1 >= a0 && y1 <= a1))
5908 && ((x0 >= b0 && x0 <= b1) || (x1 >= b0 && x1 <= b1))
5912 match getopaque l.pageno with
5915 match Unix.pipe
() with
5916 | (exception exn
) ->
5917 impmsg "cannot create sel pipe: %s" @@
5921 Ne.clo fd
(fun msg
->
5922 dolog
"%s close failed: %s" what msg
)
5925 try spawn
cmd [r, 0; w, -1]
5927 dolog
"cannot execute %S: %s"
5934 G.postRedisplay "copysel";
5936 else clo "Msel pipe/w" w;
5937 clo "Msel pipe/r" r;
5939 dosel conf
.selcmd
();
5940 state
.roam
<- dosel conf
.paxcmd
;
5952 let birdseyemouse button down
x y mask
5953 (conf
, leftx
, _, hooverpageno
, anchor) =
5956 let rec loop = function
5959 if y > l.pagedispy && y < l.pagedispy + l.pagevh
5960 && x > l.pagedispx && x < l.pagedispx + l.pagevw
5962 leavebirdseye (conf
, leftx
, l.pageno, hooverpageno
, anchor) false;
5968 | _ -> viewmouse button down
x y mask
5974 method key key mask
=
5975 begin match state
.mode with
5976 | Textentry
textentry -> textentrykeyboard key mask
textentry
5977 | Birdseye
birdseye -> birdseyekeyboard key mask
birdseye
5978 | View
-> viewkeyboard key mask
5979 | LinkNav
linknav -> linknavkeyboard key mask
linknav
5983 method button button bstate
x y mask
=
5984 begin match state
.mode with
5986 | View
-> viewmouse button bstate
x y mask
5987 | Birdseye beye
-> birdseyemouse button bstate
x y mask beye
5992 method multiclick clicks
x y mask
=
5993 begin match state
.mode with
5995 | View
-> viewmulticlick clicks
x y mask
6002 begin match state
.mode with
6004 | View
| Birdseye
_ | LinkNav
_ ->
6005 match state
.mstate
with
6006 | Mzoom
_ | Mnone
-> ()
6011 state
.mstate
<- Mpan
(x, y);
6013 then state
.x <- panbound (state
.x + dx);
6015 gotoy_and_clear_text y
6018 state
.mstate
<- Msel
(a, (x, y));
6019 G.postRedisplay "motion select";
6022 let y = min state
.winh
(max
0 y) in
6026 let x = min state
.winw (max
0 x) in
6029 | Mzoomrect
(p0
, _) ->
6030 state
.mstate
<- Mzoomrect
(p0
, (x, y));
6031 G.postRedisplay "motion zoomrect";
6035 method pmotion
x y =
6036 begin match state
.mode with
6037 | Birdseye
(conf
, leftx
, pageno, hooverpageno
, anchor) ->
6038 let rec loop = function
6040 if hooverpageno
!= -1
6042 state
.mode <- Birdseye
(conf
, leftx
, pageno, -1, anchor);
6043 G.postRedisplay "pmotion birdseye no hoover";
6046 if y > l.pagedispy && y < l.pagedispy + l.pagevh
6047 && x > l.pagedispx && x < l.pagedispx + l.pagevw
6049 state
.mode <- Birdseye
(conf
, leftx
, pageno, l.pageno, anchor);
6050 G.postRedisplay "pmotion birdseye hoover";
6060 match state
.mstate
with
6061 | Mpan
_ | Msel
_ | Mzoom
_ | Mscrolly
| Mscrollx
| Mzoomrect
_ -> ()
6069 let past, _, _ = !r in
6071 let delta = now -. past in
6074 else r := (now, x, y)
6078 method infochanged
_ = ()
6081 let maxy = state
.maxy - (if conf
.maxhfit
then state
.winh
else 0) in
6084 then 0.0, float state
.winh
6085 else scrollph state
.y maxy
6090 let winw = wadjsb () + state
.winw in
6091 let fwinw = float winw in
6093 let sw = fwinw /. float state
.w in
6094 let sw = fwinw *. sw in
6095 max
sw (float conf
.scrollh
)
6098 let maxx = state
.w + winw in
6099 let x = winw - state
.x in
6100 let percent = float x /. float maxx in
6101 (fwinw -. sw) *. percent
6103 hscrollh (), position, sw
6107 match state
.mode with
6108 | LinkNav
_ -> "links"
6109 | Textentry
_ -> "textentry"
6110 | Birdseye
_ -> "birdseye"
6113 findkeyhash conf
modename
6115 method eformsgs
= true
6116 method alwaysscrolly
= false
6119 let adderrmsg src msg
=
6120 Buffer.add_string state
.errmsgs msg
;
6121 state
.newerrmsgs
<- true;
6125 let adderrfmt src fmt
=
6126 Format.ksprintf
(fun s -> adderrmsg src s) fmt
;
6129 let addrect pageno r g b a x0 y0 x1 y1 =
6130 Hashtbl.add state
.prects
pageno [|r; g; b; a; x0; y0; x1; y1|];
6134 let cl = splitatspace cmds
in
6136 try Scanf.sscanf
s fmt
f
6138 adderrfmt "remote exec"
6139 "error processing '%S': %s\n" cmds
@@ exntos exn
6141 let rectx s pageno (r, g, b, a) x0 y0 x1 y1 =
6142 vlog "%s page %d color (%f %f %f %f) x0,y0,x1,y1 = %f %f %f %f"
6143 s pageno r g b a x0 y0 x1 y1;
6147 let _,w1,h1
,_ = getpagedim
pageno in
6148 let sw = float w1 /. float w
6149 and sh = float h1
/. float h in
6153 and y1s
= y1 *. sh in
6154 let rect = (x0s,y0s
,x1s
,y0s
,x1s
,y1s
,x0s,y1s
) in
6155 let color = (r, g, b, a) in
6156 if conf
.verbose
then debugrect rect;
6157 state
.rects <- (pageno, color, rect) :: state
.rects;
6162 | "reload" :: [] -> reload ()
6163 | "goto" :: args
:: [] ->
6164 scan args
"%u %f %f"
6166 let cmd, _ = state
.geomcmds
in
6168 then gotopagexy !wtmode pageno x y
6171 gotopagexy !wtmode pageno x y;
6174 state
.reprf
<- f state
.reprf
6176 | "goto1" :: args
:: [] -> scan args
"%u %f" gotopage
6177 | "gotor" :: args
:: [] ->
6179 (fun filename
pageno -> gotounder (Uremote
(filename
, pageno)))
6180 | "gotord" :: args
:: [] ->
6182 (fun filename
dest -> gotounder (Uremotedest
(filename
, dest)))
6183 | "rect" :: args
:: [] ->
6184 scan args
"%u %u %f %f %f %f"
6185 (fun pageno c x0 y0 x1 y1 ->
6186 let color = (0.0, 0.0, 1.0 /. float c, 0.5) in
6187 rectx "rect" pageno color x0 y0 x1 y1;
6189 | "prect" :: args
:: [] ->
6190 scan args
"%u %f %f %f %f %f %f %f %f"
6191 (fun pageno r g b alpha x0 y0 x1 y1 ->
6192 addrect pageno r g b alpha x0 y0 x1 y1;
6193 G.postRedisplay "prect"
6195 | "pgoto" :: args
:: [] ->
6196 scan args
"%u %f %f"
6199 match getopaque pageno with
6200 | Some
opaque -> opaque
6203 pgoto optopaque pageno x y;
6204 let rec fixx = function
6207 if l.pageno = pageno
6209 state
.x <- state
.x - l.pagedispx;
6216 match conf
.columns
with
6217 | Csingle
_ | Csplit
_ -> 1
6218 | Cmulti
((n, _, _), _) -> n
6220 layout 0 state
.y (state
.winw * mult) state
.winh
6224 | "activatewin" :: [] -> Wsi.activatewin
()
6225 | "quit" :: [] -> raise Quit
6226 | "clearrects" :: [] ->
6227 Hashtbl.clear state
.prects
;
6228 G.postRedisplay "clearrects"
6230 adderrfmt "remote command"
6231 "error processing remote command: %S\n" cmds
;
6235 let scratch = Bytes.create
80 in
6236 let buf = Buffer.create
80 in
6238 match tempfailureretry
(Unix.read fd
scratch 0) 80 with
6239 | (exception Unix.Unix_error
(Unix.EAGAIN
, _, _)) -> None
6242 if Buffer.length
buf > 0
6244 let s = Buffer.contents
buf in
6252 match Bytes.index_from
scratch ppos '
\n'
with
6253 | pos -> if pos >= n then -1 else pos
6254 | (exception Not_found
) -> -1
6258 Buffer.add_subbytes
buf scratch ppos
(nlpos-ppos
);
6259 let s = Buffer.contents
buf in
6265 Buffer.add_subbytes
buf scratch ppos
(n-ppos
);
6271 let remoteopen path =
6272 try Some
(Unix.openfile
path [Unix.O_NONBLOCK
; Unix.O_RDONLY
] 0o0)
6274 adderrfmt "remoteopen" "error opening %S: %s" path @@ exntos exn
;
6279 let gcconfig = ref E.s in
6280 let trimcachepath = ref E.s in
6281 let rcmdpath = ref E.s in
6282 let pageno = ref None
in
6283 let rootwid = ref 0 in
6284 let openlast = ref false in
6285 let nofc = ref false in
6286 let doreap = ref false in
6287 selfexec := Sys.executable_name
;
6290 [("-p", Arg.String
(fun s -> state
.password <- s),
6291 "<password> Set password");
6295 Config.fontpath
:= s;
6296 selfexec := !selfexec ^
" -f " ^
Filename.quote
s;
6298 "<path> Set path to the user interface font");
6302 selfexec := !selfexec ^
" -c " ^
Filename.quote
s;
6303 Config.confpath
:= s),
6304 "<path> Set path to the configuration file");
6306 ("-last", Arg.Set
openlast, " Open last document");
6308 ("-page", Arg.Int
(fun pageno1
-> pageno := Some
(pageno1
-1)),
6309 "<page-number> Jump to page");
6311 ("-tcf", Arg.String
(fun s -> trimcachepath := s),
6312 "<path> Set path to the trim cache file");
6314 ("-dest", Arg.String
(fun s -> state
.nameddest
<- s),
6315 "<named-destination> Set named destination");
6317 ("-wtmode", Arg.Set
wtmode, " Operate in wt mode");
6318 ("-cxack", Arg.Set
cxack, " Cut corners");
6320 ("-remote", Arg.String
(fun s -> rcmdpath := s),
6321 "<path> Set path to the remote commands source");
6323 ("-origin", Arg.String
(fun s -> state
.origin
<- s),
6324 "<original-path> Set original path");
6326 ("-gc", Arg.Set_string
gcconfig,
6327 "<script-path> Collect garbage with the help of a script");
6329 ("-nofc", Arg.Set
nofc, " Do not use fontconfig");
6331 ("-v", Arg.Unit
(fun () ->
6333 "%s\nconfiguration path: %s\n"
6337 exit
0), " Print version and exit");
6339 ("-embed", Arg.Set_int
rootwid,
6340 "<window-id> Embed into window")
6343 (fun s -> state
.path <- s)
6344 ("Usage: " ^
Sys.argv
.(0) ^
" [options] some.pdf\nOptions:")
6347 then selfexec := !selfexec ^
" -wtmode";
6349 let histmode = emptystr state
.path && not
!openlast in
6351 if not
(Config.load !openlast)
6352 then dolog
"failed to load configuration";
6353 begin match !pageno with
6354 | Some
pageno -> state
.anchor <- (pageno, 0.0, 0.0)
6358 if nonemptystr
!gcconfig
6361 match Unix.socketpair
Unix.PF_UNIX
Unix.SOCK_STREAM
0 with
6362 | (exception exn
) -> error
"socketpair for gc failed: %s" @@ exntos exn
6365 match spawn
!gcconfig [(c, 0); (c, 1); (s, -1)] with
6366 | (exception exn
) -> error
"failed to execute gc script: %s" @@ exntos exn
6368 Ne.clo c @@ (fun s -> error
"failed to close gc fd %s" s);
6373 let wsfd, winw, winh
= Wsi.init
(object (self)
6374 val mutable m_clicks
= 0
6375 val mutable m_click_x
= 0
6376 val mutable m_click_y
= 0
6377 val mutable m_lastclicktime
= infinity
6379 method private cleanup =
6380 state
.roam
<- noroam
;
6381 Hashtbl.iter
(fun _ opaque -> clearmark
opaque) state
.pagemap
6382 method expose
= G.postRedisplay "expose"
6386 | Wsi.Unobscured
-> "unobscured"
6387 | Wsi.PartiallyObscured
-> "partiallyobscured"
6388 | Wsi.FullyObscured
-> "fullyobscured"
6390 vlog "visibility change %s" name
6391 method display = display ()
6392 method map mapped
= vlog "mapped %b" mapped
6393 method reshape w h =
6396 method mouse
b d x y m =
6397 if d && canselect ()
6399 (* http://blogs.msdn.com/b/oldnewthing/archive/2004/10/18/243925.aspx *)
6405 if abs
x - m_click_x
> 10
6406 || abs
y - m_click_y
> 10
6407 || abs_float
(t -. m_lastclicktime
) > 0.3
6409 m_clicks
<- m_clicks
+ 1;
6410 m_lastclicktime
<- t;
6414 G.postRedisplay "cleanup";
6415 state
.uioh <- state
.uioh#button
b d x y m;
6417 else state
.uioh <- state
.uioh#multiclick m_clicks
x y m
6422 m_lastclicktime
<- infinity
;
6423 state
.uioh <- state
.uioh#button
b d x y m
6427 state
.uioh <- state
.uioh#button
b d x y m
6430 state
.mpos
<- (x, y);
6431 state
.uioh <- state
.uioh#motion
x y
6432 method pmotion
x y =
6433 state
.mpos
<- (x, y);
6434 state
.uioh <- state
.uioh#pmotion
x y
6436 let mascm = m land (
6437 Wsi.altmask
+ Wsi.shiftmask
+ Wsi.ctrlmask
+ Wsi.metamask
6440 let x = state
.x and y = state
.y in
6442 if x != state
.x || y != state
.y then self#
cleanup
6444 match state
.keystate
with
6446 let km = k
, mascm in
6449 let modehash = state
.uioh#
modehash in
6450 try Hashtbl.find modehash km
6452 try Hashtbl.find (findkeyhash conf
"global") km
6453 with Not_found
-> KMinsrt
(k
, m)
6455 | KMinsrt
(k
, m) -> keyboard k
m
6456 | KMinsrl
l -> List.iter
(fun (k
, m) -> keyboard k
m) l
6457 | KMmulti
(l, r) -> state
.keystate
<- KSinto
(l, r)
6459 | KSinto
((k'
, m'
) :: [], insrt
) when k'
=k
&& m'
land mascm = m'
->
6460 List.iter
(fun (k
, m) -> keyboard k
m) insrt
;
6461 state
.keystate
<- KSnone
6462 | KSinto
((k'
, m'
) :: keys, insrt
) when k'
=k
&& m'
land mascm = m'
->
6463 state
.keystate
<- KSinto
(keys, insrt
)
6464 | KSinto
_ -> state
.keystate
<- KSnone
6467 state
.mpos
<- (x, y);
6468 state
.uioh <- state
.uioh#pmotion
x y
6469 method leave = state
.mpos
<- (-1, -1)
6470 method winstate wsl
= state
.winstate
<- wsl
6471 method quit
= raise Quit
6472 end) !rootwid conf
.cwinw conf
.cwinh platform
in
6474 setbgcol conf
.bgcolor
;
6478 List.exists
GlMisc.check_extension
6479 [ "GL_ARB_texture_rectangle"
6480 ; "GL_EXT_texture_recangle"
6481 ; "GL_NV_texture_rectangle" ]
6483 then (dolog
"OpenGL does not suppport rectangular textures"; exit
1);
6486 let r = GlMisc.get_string `renderer
in
6487 let p = "Mesa DRI Intel(" in
6488 let l = String.length
p in
6489 String.length
r > l && String.sub
r 0 l = p
6492 defconf
.sliceheight
<- 1024;
6493 defconf
.texcount
<- 32;
6494 defconf
.usepbo
<- true;
6498 match Unix.socketpair
Unix.PF_UNIX
Unix.SOCK_STREAM
0 with
6499 | (exception exn
) ->
6500 dolog
"socketpair failed: %s" @@ exntos exn
;
6508 setcheckers conf
.checkers
;
6511 conf
.angle
, conf
.fitmodel
, (conf
.trimmargins
, conf
.trimfuzz
),
6512 conf
.texcount
, conf
.sliceheight
, conf
.mustoresize
, conf
.colorspace
,
6513 !Config.fontpath
, !trimcachepath,
6514 GlMisc.check_extension
"GL_ARB_pixel_buffer_object",
6517 List.iter
GlArray.enable
[`texture_coord
; `vertex
];
6519 reshape ~firsttime
:true winw winh
;
6523 Wsi.settitle
"llpp (history)";
6527 state
.text <- "Opening " ^
(mbtoutf8 state
.path);
6528 opendoc state
.path state
.password;
6532 Wsi.setcursor
Wsi.CURSOR_INHERIT
;
6533 Sys.set_signal
Sys.sighup
(Sys.Signal_handle
(fun _ -> reload ()));
6536 match Unix.waitpid
[Unix.WNOHANG
] ~
-1 with
6537 | (exception (Unix.Unix_error
(Unix.ECHILD
, _, _))) -> ()
6538 | (exception exn
) -> dolog
"Unix.waitpid: %s" @@ exntos exn
6540 | _pid
, _status
-> reap ()
6542 Sys.set_signal
Sys.sigchld
(Sys.Signal_handle
(fun _ -> doreap := true));
6546 if nonemptystr
!rcmdpath
6547 then remoteopen !rcmdpath
6552 let rec loop deadline
=
6558 let r = [state
.ss; state
.wsfd] in
6562 | Some fd
-> fd
:: r
6566 state
.redisplay
<- false;
6573 if deadline
= infinity
6575 else max
0.0 (deadline
-. now)
6580 try Unix.select
r [] [] timeout
6581 with Unix.Unix_error
(Unix.EINTR
, _, _) -> [], [], []
6587 if state
.ghyll
== noghyll
6589 match state
.autoscroll
with
6590 | Some step
when step
!= 0 ->
6591 let y = state
.y + step
in
6595 else if y >= state
.maxy then 0 else y
6597 if state
.mode = View
6598 then gotoy_and_clear_text y
6602 else deadline
+. 0.01
6607 let rec checkfds = function
6609 | fd
:: rest
when fd
= state
.ss ->
6610 let cmd = readcmd state
.ss in
6614 | fd
:: rest
when fd
= state
.wsfd ->
6618 | fd
:: rest
when Some fd
= !optrfd ->
6619 begin match remote fd
with
6620 | None
-> optrfd := remoteopen !rcmdpath;
6621 | opt -> optrfd := opt
6626 dolog
"select returned unknown descriptor";
6632 if deadline
= infinity
6636 match state
.autoscroll
with
6637 | Some step
when step
!= 0 -> deadline1
6638 | _ -> if state
.ghyll
== noghyll
then infinity
else deadline1
6646 Config.save leavebirdseye;
6647 if hasunsavedchanges
()